home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / sparc / lapgen.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  22.4 KB  |  680 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapgen.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; RTL Rules for SPARC.  Shared utilities.
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Register-Allocator Interface
  28.  
  29. (define (register->register-transfer source target)
  30.   (if (not (register-types-compatible? source target))
  31.       (error "Moving between incompatible register types" source target))
  32.   (case (register-type source)
  33.     ((GENERAL) (copy source target))
  34.     ((FLOAT) (fp-copy source target))
  35.     (else (error "unknown register type" source))))
  36.  
  37. (define (home->register-transfer source target)
  38.   (memory->register-transfer (pseudo-register-displacement source)
  39.                  regnum:regs-pointer
  40.                  target))
  41.  
  42. (define (register->home-transfer source target)
  43.   (register->memory-transfer source
  44.                  (pseudo-register-displacement target)
  45.                  regnum:regs-pointer))
  46.  
  47. (define (reference->register-transfer source target)
  48.   (case (ea/mode source)
  49.     ((GR)
  50.      (copy (register-ea/register source) target))
  51.     ((FPR)
  52.      (fp-copy (fpr->float-register (register-ea/register source)) target))
  53.     ((OFFSET)
  54.      (memory->register-transfer (offset-ea/offset source)
  55.                 (offset-ea/register source)
  56.                 target))
  57.     (else
  58.      (error "unknown effective-address mode" source))))
  59.  
  60. (define (pseudo-register-home register)
  61.   ;; Register block consists of 16 4-byte registers followed by 256
  62.   ;; 8-byte temporaries.
  63.   (INST-EA (OFFSET ,(pseudo-register-displacement register)
  64.            ,regnum:regs-pointer)))
  65.  
  66. (define-integrable (sort-machine-registers registers)
  67.   registers)
  68.  
  69. (define available-machine-registers
  70.   (list
  71.    ;; g0 g1
  72.    g2 g3 g4
  73.    ;; g5 g6 g7
  74.    
  75.    g22 g23 ;; g24
  76.    g28 g29 g30
  77.    
  78.    g8 g9 g10 g11 g12 g13
  79.    
  80.    ;; g14 g15
  81.    ;; g16 g17 g18 g19 g20 g21 g22
  82.    ;; g25 g26 g27 g28
  83.    ;; g31                ; could be available if handled right
  84.    
  85.    fp0 fp2 fp4 fp6 fp8 fp10 fp12 fp14
  86.    fp16 fp18 fp20 fp22 fp24 fp26 fp28 fp30
  87.    ;; fp1 fp3 fp5 fp7 fp9 fp11 fp13 fp15
  88.    ;; fp17 fp19 fp21 fp23 fp25 fp27 fp29 fp31
  89.    ))
  90.  
  91. (define-integrable (float-register? register)
  92.   (eq? (register-type register) 'FLOAT))
  93.  
  94. (define-integrable (general-register? register)
  95.   (eq? (register-type register) 'GENERAL))
  96.  
  97. (define-integrable (word-register? register)
  98.   (eq? (register-type register) 'GENERAL))
  99.       
  100. (define (register-types-compatible? type1 type2)
  101.   (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
  102.  
  103. (define (register-type register)
  104.   (cond ((machine-register? register)
  105.      (vector-ref
  106.       '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
  107.          GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
  108.          GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
  109.          GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
  110.          FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
  111.          FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
  112.          FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
  113.          FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
  114.       register))
  115.     ((register-value-class=word? register) 'GENERAL)
  116.     ((register-value-class=float? register) 'FLOAT)
  117.     (else (error "unable to determine register type" register))))
  118.  
  119. (define register-reference
  120.   (let ((references (make-vector number-of-machine-registers)))
  121.     (let loop ((register 0))
  122.       (if (< register 32)
  123.       (begin
  124.         (vector-set! references register (INST-EA (GR ,register)))
  125.         (loop (1+ register)))))
  126.     (let loop ((register 32) (fpr 0))
  127.       (if (< register 48)
  128.       (begin
  129.         (vector-set! references register (INST-EA (FPR ,fpr)))
  130.         (loop (1+ register) (1+ fpr)))))
  131.     (lambda (register)
  132.       (vector-ref references register))))
  133.  
  134. ;;;; Useful Cliches
  135.  
  136. (define (memory->register-transfer offset base target)
  137.   (case (register-type target)
  138.     ((GENERAL) (LAP (LD ,target (OFFSET ,offset ,base)) (NOP)))
  139.     ((FLOAT) (fp-load-doubleword offset base target #T))
  140.     (else (error "unknown register type" target))))
  141.  
  142. (define (register->memory-transfer source offset base)
  143.   (case (register-type source)
  144.     ((GENERAL) (LAP (ST ,source (OFFSET ,offset ,base))))
  145.     ((FLOAT) (fp-store-doubleword offset base source))
  146.     (else (error "unknown register type" source))))
  147.  
  148. (define (load-constant target constant delay-slot? record?)
  149.   ;; Load a Scheme constant into a machine register.
  150.   (if (non-pointer-object? constant)
  151.       (load-immediate target (non-pointer->literal constant) record?)
  152.       (load-pc-relative target
  153.             'CONSTANT
  154.             (constant->label constant)
  155.             delay-slot?)))
  156.  
  157. (define (deposit-type-address type source target)
  158.   (deposit-type-datum (fix:xor (quotient #x10 type-scale-factor) type)
  159.               source
  160.               target))
  161.  
  162. (define (deposit-type-datum type source target)
  163.   (with-values
  164.       (lambda ()
  165.     (immediate->register (make-non-pointer-literal type 0)))
  166.     (lambda (prefix alias)
  167.       (LAP ,@prefix
  168.        (XORR ,target ,alias ,source)))))
  169.  
  170. (define (non-pointer->literal constant)
  171.   (make-non-pointer-literal (object-type constant)
  172.                 (careful-object-datum constant)))
  173.  
  174. (define-integrable (make-non-pointer-literal type datum)
  175.   (+ (* type (expt 2 scheme-datum-width)) datum))
  176.  
  177. (define-integrable (deposit-type type-num target-reg)
  178.   (if (= target-reg regnum:assembler-temp)
  179.       (error "deposit-type: into register 1"))
  180.   (LAP (ANDR ,target-reg ,target-reg ,regnum:address-mask)
  181.        ,@(put-type type-num target-reg)))
  182.  
  183. (define-integrable (put-type type-num target-reg)
  184.   ; Assumes that target-reg has 0 in type bits
  185.   (LAP (SETHI ,regnum:assembler-temp ,(* type-num #x4000000))
  186.        (ORR  ,target-reg ,regnum:assembler-temp ,target-reg)))
  187.  
  188.  
  189. ;;;; Regularized Machine Instructions
  190.  
  191. (define (adjusted:high n)
  192.   (let ((n (->unsigned n)))
  193.     (if (< (remainder n #x10000) #x8000)
  194.     (quotient n #x10000)
  195.     (+ (quotient n #x10000) 1))))
  196.  
  197. (define (adjusted:low n)
  198.   (let ((remainder (remainder (->unsigned n) #x10000)))
  199.     (if (< remainder #x8000)
  200.     remainder
  201.     (- remainder #x10000))))
  202.  
  203. (define (low-bits offset)
  204.   (let ((bits (signed-integer->bit-string 32 offset)))
  205.     (bit-substring bits 0 10)))
  206.  
  207. (define (high-bits offset)
  208.   (let ((bits (signed-integer->bit-string 32 offset)))
  209.     (bit-substring bits 10 32)))
  210.  
  211. (define-integrable (top-16-bits n)
  212.   (quotient (->unsigned n) #x10000))
  213.  
  214. (define-integrable (bottom-16-bits n)
  215.   (remainder (->unsigned n) #x10000))
  216.  
  217. (define-integrable (bottom-10-bits n)
  218.   (remainder (->unsigned n) #x400))
  219.  
  220. (define-integrable (bottom-13-bits n)
  221.   (remainder (->unsigned n) #x2000))
  222.  
  223. (define-integrable (top-22-bits n)
  224.   (quotient (->unsigned n) #x400))
  225.  
  226. (define (->unsigned n)
  227.   (if (negative? n) (+ #x100000000 n) n))
  228.  
  229. (define-integrable (fits-in-16-bits-signed? value)
  230.   (<= #x-8000 value #x7fff))
  231.  
  232. (define-integrable (fits-in-16-bits-unsigned? value)
  233.   (<= #x0 value #xffff))
  234.  
  235. (define-integrable (fits-in-13-bits-signed? value)
  236.   (<= #x-2000 value #x1fff))
  237.  
  238. (define-integrable (fits-in-13-bits-unsigned? value)
  239.   (<= #x0 value #x1fff))
  240.  
  241. (define-integrable (top-16-bits-only? value)
  242.   (zero? (bottom-16-bits value)))
  243.  
  244. (define-integrable (top-22-bits-only? value)
  245.   (zero? (bottom-10-bits value)))
  246.  
  247. (define (copy r t)
  248.   (if (= r t)
  249.       (LAP)
  250.       (LAP (ADD ,t 0 ,r))))
  251.  
  252. (define (fp-copy from to)
  253.   (if (= to from)
  254.       (LAP)
  255.       (let ((to-reg (float-register->fpr to))
  256.         (from-reg (float-register->fpr from)))
  257.     (LAP (FMOVS ,to-reg ,from-reg)
  258.          (FMOVS ,(+ to-reg 1) ,(+ from-reg 1))))))
  259.  
  260. ;; Handled by VARIABLE-WIDTH in instr1.scm
  261.  
  262. (define (fp-load-doubleword offset base target NOP?)
  263.   (let* ((least (float-register->fpr target))
  264.      (most (+ least 1)))
  265.     (LAP (LDDF ,least (OFFSET ,offset ,base))
  266.      ,@(if NOP? (LAP (NOP)) (LAP)))))
  267.  
  268. (define (fp-store-doubleword offset base source)
  269.   (let* ((least (float-register->fpr source))
  270.      (most (+ least 1)))
  271.     (LAP (SDDF ,least (OFFSET ,offset ,base))
  272.      ,@(if NOP? (LAP (NOP)) (LAP)))))
  273.  
  274. ;;;; PC-relative addresses
  275.  
  276. (define (load-pc-relative target type label delay-slot?)
  277.   ;; Load a pc-relative location's contents into a machine register.
  278.   ;; Optimization: if there is a register that contains the value of
  279.   ;; another label, use that register as the base register.
  280.   ;; Otherwise, allocate a temporary and load it with the value of the
  281.   ;; label, then use the temporary as the base register.  This
  282.   ;; strategy of loading a temporary wins if the temporary is used
  283.   ;; again, but loses if it isn't, since loading the temporary takes
  284.   ;; two instructions in addition to the LW instruction, while doing a
  285.   ;; pc-relative LW instruction takes only two instructions total.
  286.   ;; But pc-relative loads of various kinds are quite common, so this
  287.   ;; should almost always be advantageous.
  288.   (with-values (lambda () (get-typed-label type))
  289.     (lambda (label* alias)
  290.       (if label*
  291.       (LAP (LD ,target (OFFSET (- ,label ,label*) ,alias))
  292.            ,@(if delay-slot? (LAP (NOP)) (LAP)))
  293.       (let ((temporary (standard-temporary!)))
  294.         (set-typed-label! type label temporary)
  295.         (LAP ,@(%load-pc-relative-address temporary label)
  296.          (LD ,target (OFFSET 0 ,temporary))
  297.          ,@(if delay-slot? (LAP (NOP)) (LAP))))))))
  298.  
  299. (define (load-pc-relative-address target type label)
  300.   ;; Load address of a pc-relative location into a machine register.
  301.   ;; Optimization: if there is another register that contains the
  302.   ;; value of another label, add the difference between the labels to
  303.   ;; that register's contents instead.  The ADDI takes one
  304.   ;; instruction, while the %LOAD-PC-RELATIVE-ADDRESS takes two, so
  305.   ;; this is always advantageous.
  306.   (let ((instructions
  307.      (with-values (lambda () (get-typed-label type))
  308.        (lambda (label* alias)
  309.          (if label*
  310.          (LAP (ADDI ,target ,alias (- ,label ,label*)))
  311.          (%load-pc-relative-address target label))))))
  312.     (set-typed-label! type label target)
  313.     instructions))
  314.  
  315. (define (%load-pc-relative-address target label)
  316.   (let ((label* (generate-label)))
  317.     (LAP (CALL 4)
  318.      (LABEL ,label*)
  319.      (ADDI ,target ,regnum:call-result (- ,label (- ,label* 4))))))
  320.  
  321. ;;; Typed labels provide further optimization.  There are two types,
  322. ;;; CODE and CONSTANT, that say whether the label is located in the
  323. ;;; code block or the constants block of the output.  Statistically,
  324. ;;; a label is likely to be closer to another label of the same type
  325. ;;; than to a label of the other type.
  326.  
  327. (define (get-typed-label type)
  328.   (let ((entries (register-map-labels *register-map* 'GENERAL)))
  329.     (let loop ((entries* entries))
  330.       (cond ((null? entries*)
  331.          ;; If no entries of the given type, use any entry that is
  332.          ;; available.
  333.          (let loop ((entries entries))
  334.            (cond ((null? entries)
  335.               (values false false))
  336.              ((pair? (caar entries))
  337.               (values (cdaar entries) (cadar entries)))
  338.              (else
  339.               (loop (cdr entries))))))
  340.         ((and (pair? (caar entries*))
  341.           (eq? type (caaar entries*)))
  342.          (values (cdaar entries*) (cadar entries*)))
  343.         (else
  344.          (loop (cdr entries*)))))))
  345.  
  346. (define (set-typed-label! type label alias)
  347.   (set! *register-map*
  348.     (set-machine-register-label *register-map* alias (cons type label)))
  349.   unspecific)
  350.  
  351. (define (immediate->register immediate)
  352.   (let ((register (get-immediate-alias immediate)))
  353.     (if register
  354.     (values (LAP) register)
  355.     (let ((temporary (standard-temporary!)))
  356.       (set! *register-map*
  357.         (set-machine-register-label *register-map*
  358.                         temporary
  359.                         immediate))
  360.       (values (%load-immediate temporary immediate) temporary)))))
  361.  
  362. (define (get-immediate-alias immediate)
  363.   (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
  364.     (cond ((null? entries)
  365.        false)
  366.       ((eqv? (caar entries) immediate)
  367.        (cadar entries))
  368.       (else
  369.        (loop (cdr entries))))))
  370.  
  371. (define (load-immediate target immediate record?)
  372.   (let ((registers (get-immediate-aliases immediate)))
  373.     (if (memv target registers)
  374.     (LAP)
  375.     (begin
  376.       (if record?
  377.           (set! *register-map*
  378.             (set-machine-register-label *register-map*
  379.                         target
  380.                         immediate)))
  381.       (if (not (null? registers))
  382.           (LAP (ADD ,target 0 ,(car registers)))
  383.           (%load-immediate target immediate))))))
  384.  
  385. (define (get-immediate-aliases immediate)
  386.   (let loop ((entries (register-map-labels *register-map* 'GENERAL)))
  387.     (cond ((null? entries)
  388.        '())
  389.       ((eqv? (caar entries) immediate)
  390.        (append (cdar entries) (loop (cdr entries))))
  391.       (else
  392.        (loop (cdr entries))))))
  393.  
  394. (define (%load-immediate target immediate)
  395.   (cond ((top-22-bits-only? immediate)
  396.      (LAP (SETHI ,target ,immediate)))
  397.     ((fits-in-13-bits-signed? immediate)
  398.      (LAP (ORI ,target ,regnum:zero  ,(bottom-13-bits immediate))))
  399.     (else
  400.      (LAP (SETHI ,target ,immediate)
  401.           (ORI ,target ,target ,(bottom-10-bits immediate))))))
  402.  
  403. (define (add-immediate immediate source target)
  404.   (if (fits-in-13-bits-signed? immediate)
  405.       (LAP (ADDI ,target ,source ,immediate))
  406.       (with-values (lambda () (immediate->register immediate))
  407.     (lambda (prefix alias)
  408.       (LAP ,@prefix
  409.            (ADDU ,target ,source ,alias))))))
  410.  
  411. ;;;; Comparisons
  412.  
  413. (define (compare-immediate comp immediate source)
  414.   ; Branch if immediate <comp> source
  415.   (let ((cc (invert-condition-noncommutative comp)))
  416.     ;; This machine does register <op> immediate; you can
  417.     ;; now think of cc in this way
  418.     (if (zero? immediate)
  419.     (begin
  420.       (branch-generator! cc
  421.         `(BE) `(BL) `(BG)
  422.         `(BNE) `(BGE) `(BLE))
  423.       (LAP (SUBCCI 0 ,source 0)))
  424.     (with-values (lambda () (immediate->register immediate))
  425.       (lambda (prefix alias)
  426.         (LAP ,@prefix
  427.          ,@(compare comp alias source)))))))
  428.  
  429. (define (compare condition r1 r2)
  430.   ; Branch if r1 <cc> r2
  431.   (if (= r1 r2)
  432.       (let ((branch
  433.          (lambda (label) (LAP (BA (@PCR ,label)) (NOP))))
  434.         (dont-branch
  435.          (lambda (label) label (LAP))))
  436.     (if (memq condition '(< > <>))
  437.         (set-current-branches! dont-branch branch)
  438.         (set-current-branches! branch dont-branch))
  439.     (LAP (SUBCC 0 ,r1 ,r2)))
  440.       (begin
  441.     (branch-generator! condition
  442.       `(BE) `(BL) `(BG) `(BNE) `(BGE) `(BLE))
  443.     (LAP (SUBCC 0 ,r1 ,r2)))))
  444.  
  445. (define (branch-generator! cc = < > <> >= <=)
  446.   (let ((forward
  447.      (case cc
  448.        ((=)   =) ((<)  <)  ((>)  >)
  449.        ((<>) <>) ((>=) >=) ((<=) <=)))
  450.     (inverse
  451.      (case cc
  452.        ((=)  <>) ((<)  >=) ((>)  <=)
  453.        ((<>) =)  ((>=) <)  ((<=) >))))
  454.     (set-current-branches!
  455.      (lambda (label)
  456.        (LAP (,@forward (@PCR ,label)) (NOP)))
  457.      (lambda (label)
  458.        (LAP (,@inverse (@PCR ,label)) (NOP))))))
  459.  
  460. (define (invert-condition condition)
  461.   (let ((place (assq condition condition-inversion-table)))
  462.     (if (not place)
  463.     (error "unknown condition" condition))
  464.     (cadr place)))
  465.  
  466. (define (invert-condition-noncommutative condition)
  467.   (let ((place (assq condition condition-inversion-table)))
  468.     (if (not place)
  469.     (error "unknown condition" condition))
  470.     (caddr place)))
  471.  
  472. (define condition-inversion-table
  473.   ; A OP B  NOT (A OP B)      B OP A
  474.   ;           invert      invert non-comm.
  475.   '((=        <>        =)
  476.     (<        >=        >)
  477.     (>        <=        <)
  478.     (<>        =        <>)
  479.     (<=        >        >=)
  480.     (>=        <        <=)))
  481.  
  482. ;;;; Miscellaneous
  483.  
  484. (define-integrable (object->type source target)
  485.   ; Type extraction
  486.   (LAP (SRL ,target ,source ,(- 32 scheme-type-width))))
  487.  
  488. (define-integrable (object->datum source target)
  489.   ; Zero out the type field; don't put in the quad bits
  490.   (LAP (ANDR ,target ,source ,regnum:address-mask)))
  491.  
  492. (define (object->address source target)
  493.   ; Drop in the segment bits 
  494.   (LAP (ANDR ,target ,source ,regnum:address-mask)
  495.        (ADD ,target ,regnum:quad-bits ,target)))
  496.  
  497. (define (standard-unary-conversion source target conversion)
  498.   ;; `source' is any register, `target' a pseudo register.
  499.   (let ((source (standard-source! source)))
  500.     (conversion source (standard-target! target))))
  501.  
  502. (define (standard-binary-conversion source1 source2 target conversion)
  503.   (let ((source1 (standard-source! source1))
  504.     (source2 (standard-source! source2)))
  505.     (conversion source1 source2 (standard-target! target))))
  506.  
  507. (define (standard-source! register)
  508.   (load-alias-register! register (register-type register)))
  509.  
  510. (define (standard-target! register)
  511.   (delete-dead-registers!)
  512.   (allocate-alias-register! register (register-type register)))
  513.  
  514. (define-integrable (standard-temporary!)
  515.   (allocate-temporary-register! 'GENERAL))
  516.  
  517. (define (standard-move-to-target! source target)
  518.   (move-to-alias-register! source (register-type source) target))
  519.  
  520. (define (standard-move-to-temporary! source)
  521.   (move-to-temporary-register! source (register-type source)))
  522.  
  523. (define (register-expression expression)
  524.   (case (rtl:expression-type expression)
  525.     ((REGISTER)
  526.      (rtl:register-number expression))
  527.     ((CONSTANT)
  528.      (let ((object (rtl:constant-value expression)))
  529.        (and (zero? (object-type object))
  530.         (zero? (object-datum object))
  531.         0)))
  532.     ((CONS-NON-POINTER)
  533.      (and (let ((type (rtl:cons-non-pointer-type expression)))
  534.         (and (rtl:machine-constant? type)
  535.          (zero? (rtl:machine-constant-value type))))
  536.       (let ((datum (rtl:cons-non-pointer-datum expression)))
  537.         (and (rtl:machine-constant? datum)
  538.          (zero? (rtl:machine-constant-value datum))))
  539.       0))
  540.     (else false)))
  541.  
  542. (define (define-arithmetic-method operator methods method)
  543.   (let ((entry (assq operator (cdr methods))))
  544.     (if entry
  545.     (set-cdr! entry method)
  546.     (set-cdr! methods (cons (cons operator method) (cdr methods)))))
  547.   operator)
  548.  
  549. (define (lookup-arithmetic-method operator methods)
  550.   (cdr (or (assq operator (cdr methods))
  551.        (error "Unknown operator" operator))))
  552.  
  553. (define-integrable (ea/mode ea) (car ea))
  554. (define-integrable (register-ea/register ea) (cadr ea))
  555. (define-integrable (offset-ea/offset ea) (cadr ea))
  556. (define-integrable (offset-ea/register ea) (caddr ea))
  557.  
  558. (define (pseudo-register-displacement register)
  559.   ;; Register block consists of 16 4-byte registers followed by 256
  560.   ;; 8-byte temporaries.
  561.   (+ (* 4 16) (* 8 (register-renumber register))))
  562.  
  563. (define-integrable (float-register->fpr register)
  564.   ;; Float registers are represented by 32 through 47 in the RTL,
  565.   ;; corresponding to even registers 0 through 30 in the machine.
  566.   (- register 32))
  567.  
  568. (define-integrable (fpr->float-register register)
  569.   (+ register 32))
  570.  
  571. (define-integrable reg:memtop
  572.   (INST-EA (OFFSET #x0000 ,regnum:regs-pointer)))
  573.  
  574. (define-integrable reg:environment
  575.   (INST-EA (OFFSET #x000C ,regnum:regs-pointer)))
  576.  
  577. (define-integrable reg:lexpr-primitive-arity
  578.   (INST-EA (OFFSET #x001C ,regnum:regs-pointer)))
  579.  
  580. (define-integrable reg:closure-limit
  581.   (INST-EA (OFFSET #x0024 ,regnum:regs-pointer)))
  582.  
  583. (define-integrable reg:stack-guard
  584.   (INST-EA (OFFSET #x002C ,regnum:regs-pointer)))
  585.  
  586. (define (lap:make-label-statement label)
  587.   (INST (LABEL ,label)))
  588.  
  589. (define (lap:make-unconditional-branch label)
  590.   (LAP (BA (@PCR ,label))
  591.        (NOP)))
  592.  
  593. (define (lap:make-entry-point label block-start-label)
  594.   block-start-label
  595.   (LAP (ENTRY-POINT ,label)
  596.        ,@(make-external-label expression-code-word label)))
  597.  
  598. ;;;; Codes and Hooks
  599.  
  600. (let-syntax ((define-codes
  601.            (macro (start . names)
  602.          (define (loop names index)
  603.            (if (null? names)
  604.                '()
  605.                (cons `(DEFINE-INTEGRABLE
  606.                 ,(symbol-append 'CODE:COMPILER-
  607.                         (car names))
  608.                 ,index)
  609.                  (loop (cdr names) (1+ index)))))
  610.          `(BEGIN ,@(loop names start)))))
  611.   (define-codes #x012
  612.     primitive-apply primitive-lexpr-apply
  613.     apply error lexpr-apply link
  614.     interrupt-closure interrupt-dlink interrupt-procedure 
  615.     interrupt-continuation interrupt-ic-procedure
  616.     assignment-trap cache-reference-apply
  617.     reference-trap safe-reference-trap unassigned?-trap
  618.     -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
  619.     access lookup safe-lookup unassigned? unbound?
  620.     set! define lookup-apply))
  621.  
  622. (define-integrable (link-to-interface code)
  623.   ;; Jump to link-to-interface with link in C_arg1
  624.   (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -4)
  625.        (JALR ,regnum:first-arg ,regnum:assembler-temp)
  626.        (ADDI ,regnum:interface-index 0 ,(* 4 code))))
  627.  
  628. (define-integrable (link-to-trampoline code)
  629.   ;; Jump, with link in 31, to trampoline_to_interface
  630.   ;; Jump, with link in C_arg1 to scheme-to-interface
  631.   (LAP (JALR ,regnum:first-arg ,regnum:scheme-to-interface)
  632.        (ADDI ,regnum:interface-index 0 ,(* 4 code))))
  633.  
  634. (define-integrable (invoke-interface code)
  635.   ;; Jump to scheme-to-interface
  636.   (LAP (JALR ,regnum:assembler-temp ,regnum:scheme-to-interface)
  637.        (ADDI ,regnum:interface-index 0 ,(* 4 code))))
  638.  
  639. (define (load-interface-args! first second third fourth)
  640.   (let ((clear-regs
  641.      (apply clear-registers!
  642.         (append (if first (list regnum:first-arg) '())
  643.             (if second (list regnum:second-arg) '())
  644.             (if third (list regnum:third-arg) '())
  645.             (if fourth (list regnum:fourth-arg) '()))))
  646.     (load-reg
  647.      (lambda (reg arg)
  648.        (if reg (load-machine-register! reg arg) (LAP)))))
  649.     (let ((load-regs
  650.        (LAP ,@(load-reg first regnum:first-arg)
  651.         ,@(load-reg second regnum:second-arg)
  652.         ,@(load-reg third regnum:third-arg)
  653.         ,@(load-reg fourth regnum:fourth-arg))))
  654.       (LAP ,@clear-regs
  655.        ,@load-regs
  656.        ,@(clear-map!)))))
  657.  
  658. (define (require-register! machine-reg)
  659.   (flush-register! machine-reg)
  660.   (need-register! machine-reg))
  661.  
  662. (define-integrable (flush-register! machine-reg)
  663.   (prefix-instructions! (clear-registers! machine-reg)))
  664.  
  665. (define (rtl-target:=machine-register! rtl-reg machine-reg)
  666.   (if (machine-register? rtl-reg)
  667.       (begin
  668.     (require-register! machine-reg)
  669.     (if (not (= rtl-reg machine-reg))
  670.         (suffix-instructions!
  671.          (register->register-transfer machine-reg rtl-reg))))
  672.       (begin
  673.     (delete-register! rtl-reg)
  674.     (flush-register! machine-reg)
  675.     (add-pseudo-register-alias! rtl-reg machine-reg))))
  676.  
  677.  
  678. (define (pre-lapgen-analysis rgraphs)
  679.   rgraphs
  680.   unspecific)