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 / rules3.scm < prev    next >
Text File  |  1999-01-02  |  30KB  |  802 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules3.scm,v 1.2 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. ;;;; LAP Generation Rules: Invocations and Entries
  23. ;;; package: (compiler lap-syntaxer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Invocations
  28.  
  29. (define-rule statement
  30.   (POP-RETURN)
  31.   (pop-return))
  32.  
  33. (define (pop-return)
  34.   (let ((temp (standard-temporary!)))
  35.     (LAP ,@(clear-map!)
  36.      (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
  37.      (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
  38.      ,@(object->address temp temp)
  39.      (JR ,temp)
  40.      (NOP))))            ; DELAY SLOT
  41.  
  42. (define-rule statement
  43.   (INVOCATION:APPLY (? frame-size) (? continuation))
  44.   continuation                ;ignore
  45.   (LAP ,@(clear-map!)
  46.        ,@(load-immediate regnum:second-arg frame-size #F)
  47.        (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
  48.        (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
  49.        ,@(invoke-interface code:compiler-apply)))
  50.  
  51. (define-rule statement
  52.   (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
  53.   frame-size continuation        ;ignore
  54.   (LAP ,@(clear-map!)
  55.        (BA (@PCR ,label))
  56.        (NOP)))                ; DELAY SLOT
  57.  
  58. (define-rule statement
  59.   (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
  60.   frame-size continuation        ;ignore
  61.   ;; It expects the procedure at the top of the stack
  62.   (pop-return))
  63.  
  64. (define-rule statement
  65.   (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
  66.   continuation                ;ignore
  67.   (let* ((clear-second-arg (clear-registers! regnum:first-arg))
  68.      (load-second-arg
  69.       (load-pc-relative-address regnum:first-arg 'CODE label)))
  70.     (LAP ,@clear-second-arg
  71.      ,@load-second-arg
  72.      ,@(clear-map!)
  73.      ,@(load-immediate regnum:second-arg number-pushed #F)
  74.      ,@(invoke-interface code:compiler-lexpr-apply))))
  75.  
  76. (define-rule statement
  77.   (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
  78.   continuation                ;ignore
  79.   ;; Destination address is at TOS; pop it into second-arg
  80.   (LAP ,@(clear-map!)
  81.        (LD ,regnum:first-arg (OFFSET 0 ,regnum:stack-pointer))
  82.        (ADDI ,regnum:stack-pointer ,regnum:stack-pointer 4)
  83.        ,@(object->address regnum:first-arg regnum:first-arg)
  84.        ,@(load-immediate regnum:second-arg number-pushed #F)
  85.        ,@(invoke-interface code:compiler-lexpr-apply)))
  86.  
  87. (define-rule statement
  88.   (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
  89.   continuation                ;ignore
  90.   (LAP ,@(clear-map!)
  91.        (BA (@PCR ,(free-uuo-link-label name frame-size)))
  92.        (NOP)))
  93.  
  94. (define-rule statement
  95.   (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
  96.   continuation                ;ignore
  97.   (LAP ,@(clear-map!)
  98.        (BA (@PCR ,(global-uuo-link-label name frame-size)))
  99.        (NOP)))                ; DELAY SLOT
  100.  
  101. (define-rule statement
  102.   (INVOCATION:CACHE-REFERENCE (? frame-size)
  103.                   (? continuation)
  104.                   (? extension register-expression))
  105.   continuation                ;ignore
  106.   (let* ((clear-third-arg (clear-registers! regnum:second-arg))
  107.      (load-third-arg
  108.       (load-pc-relative-address regnum:second-arg 'CODE *block-label*)))
  109.     (LAP ,@clear-third-arg
  110.      ,@load-third-arg
  111.      ,@(load-interface-args! extension false false false)
  112.      ,@(load-immediate regnum:third-arg frame-size #F)
  113.      ,@(invoke-interface code:compiler-cache-reference-apply))))
  114.  
  115. (define-rule statement
  116.   (INVOCATION:LOOKUP (? frame-size)
  117.              (? continuation)
  118.              (? environment register-expression)
  119.              (? name))
  120.   continuation                ;ignore
  121.   (LAP ,@(load-interface-args! environment false false false)
  122.        ,@(load-constant regnum:second-arg name #F #F)
  123.        ,@(load-immediate regnum:third-arg frame-size #F)
  124.        ,@(invoke-interface code:compiler-lookup-apply)))
  125.  
  126. (define-rule statement
  127.   (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
  128.   continuation                ;ignore
  129.   (if (eq? primitive compiled-error-procedure)
  130.       (LAP ,@(clear-map!)
  131.        ,@(load-immediate regnum:first-arg frame-size #F)
  132.        ,@(invoke-interface code:compiler-error))
  133.       (let* ((clear-second-arg (clear-registers! regnum:second-arg))
  134.          (load-second-arg
  135.           (load-pc-relative regnum:first-arg
  136.                 'CONSTANT
  137.                 (constant->label primitive)
  138.                 false)))
  139.     (LAP ,@clear-second-arg
  140.          ,@load-second-arg
  141.          ,@(clear-map!)
  142.          ,@(let ((arity (primitive-procedure-arity primitive)))
  143.          (cond ((not (negative? arity))
  144.             (invoke-interface code:compiler-primitive-apply))
  145.                ((= arity -1)
  146.             (LAP ,@(load-immediate regnum:assembler-temp
  147.                         (-1+ frame-size)
  148.                         #F)
  149.                  (ST ,regnum:assembler-temp
  150.                  ,reg:lexpr-primitive-arity)
  151.                  ,@(invoke-interface
  152.                 code:compiler-primitive-lexpr-apply)))
  153.                (else
  154.             ;; Unknown primitive arity.  Go through apply.
  155.             (LAP ,@(load-immediate regnum:second-arg frame-size #F)
  156.                  ,@(invoke-interface code:compiler-apply)))))))))
  157.  
  158. (let-syntax
  159.     ((define-special-primitive-invocation
  160.        (macro (name)
  161.      `(DEFINE-RULE STATEMENT
  162.         (INVOCATION:SPECIAL-PRIMITIVE
  163.          (? FRAME-SIZE)
  164.          (? CONTINUATION)
  165.          ,(make-primitive-procedure name true))
  166.         FRAME-SIZE CONTINUATION
  167.         ,(list 'LAP
  168.            (list 'UNQUOTE-SPLICING '(CLEAR-MAP!))
  169.            (list 'UNQUOTE-SPLICING
  170.              `(INVOKE-INTERFACE
  171.                ,(symbol-append 'CODE:COMPILER- name))))))))
  172.   (define-special-primitive-invocation &+)
  173.   (define-special-primitive-invocation &-)
  174.   (define-special-primitive-invocation &*)
  175.   (define-special-primitive-invocation &/)
  176.   (define-special-primitive-invocation &=)
  177.   (define-special-primitive-invocation &<)
  178.   (define-special-primitive-invocation &>)
  179.   (define-special-primitive-invocation 1+)
  180.   (define-special-primitive-invocation -1+)
  181.   (define-special-primitive-invocation zero?)
  182.   (define-special-primitive-invocation positive?)
  183.   (define-special-primitive-invocation negative?))
  184.  
  185. ;;;; Invocation Prefixes
  186.  
  187. ;;; (INVOCATION-PREFIX:MOVE-FRAME-UP frame-size address)
  188.  
  189. ;;; Move the topmost <frame-size> words of the stack downward so that
  190. ;;; the bottommost of these words is at location <address>, and set
  191. ;;; the stack pointer to the topmost of the moved words.  That is,
  192. ;;; discard the words between <address> and SP+<frame-size>, close the
  193. ;;; resulting gap by shifting down the words from above the gap, and
  194. ;;; adjust SP to point to the new topmost word.
  195.  
  196. (define-rule statement
  197.   ;; Move up 0 words back to top of stack : a No-Op
  198.   (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 3))
  199.   (LAP))
  200.  
  201. (define-rule statement
  202.   ;; Move <frame-size> words back to dynamic link marker
  203.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 11))
  204.   (generate/move-frame-up frame-size
  205.     (lambda (reg) (LAP (ADD ,reg 0 ,regnum:dynamic-link)))))
  206.  
  207. (define-rule statement
  208.   ;; Move <frame-size> words back to dynamic link marker
  209.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? dest)))
  210.   (generate/move-frame-up frame-size
  211.     (lambda (reg) (LAP (ADD ,reg 0 ,dest)))))
  212.  
  213. (define-rule statement
  214.   ;; Move <frame-size> words back to SP+offset
  215.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
  216.                    (OFFSET-ADDRESS (REGISTER 3) (? offset)))
  217.   (let ((how-far (* 4 (- offset frame-size))))
  218.     (cond ((zero? how-far)
  219.        (LAP))
  220.       ((negative? how-far)
  221.        (error "invocation-prefix:move-frame-up: bad specs"
  222.           frame-size offset))
  223.       ((zero? frame-size)
  224.        (add-immediate how-far regnum:stack-pointer regnum:stack-pointer))
  225.       ((= frame-size 1)
  226.        (let ((temp (standard-temporary!)))
  227.          (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
  228.           (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
  229.           (STW ,temp (OFFSET 0 ,regnum:stack-pointer)))))
  230.       ((= frame-size 2)
  231.        (let ((temp1 (standard-temporary!))
  232.          (temp2 (standard-temporary!)))
  233.          (LAP (LD ,temp1 (OFFSET 0 ,regnum:stack-pointer))
  234.           (LD ,temp2 (OFFSET 4 ,regnum:stack-pointer))
  235.           (ADDI ,regnum:stack-pointer ,regnum:stack-pointer ,how-far)
  236.           (ST ,temp1 (OFFSET 0 ,regnum:stack-pointer))
  237.           (ST ,temp2 (OFFSET 4 ,regnum:stack-pointer)))))
  238.       (else
  239.        (generate/move-frame-up frame-size
  240.          (lambda (reg)
  241.            (add-immediate (* 4 offset) regnum:stack-pointer reg)))))))
  242.  
  243. (define-rule statement
  244.   ;; Move <frame-size> words back to base virtual register + offset
  245.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
  246.                    (OFFSET-ADDRESS (REGISTER (? base))
  247.                            (? offset)))
  248.   (QUALIFIER (not (= base 3)))
  249.   (generate/move-frame-up frame-size
  250.     (lambda (reg)
  251.       (add-immediate (* 4 offset) (standard-source! base) reg))))
  252.  
  253. (define (generate/move-frame-up frame-size destination-generator)
  254.   (let ((temp (standard-temporary!)))
  255.     (LAP ,@(destination-generator temp)
  256.      ,@(generate/move-frame-up* frame-size temp))))
  257.  
  258. ;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
  259. ;;; and <current dynamic link> as arguments.  They pop the stack by
  260. ;;; removing the lesser of the amount needed to move the stack pointer
  261. ;;; back to the <new frame end> or <current dynamic link>.  The last
  262. ;;; <frame-size> words on the stack (the stack frame for the procedure
  263. ;;; about to be called) are then put back onto the newly adjusted
  264. ;;; stack.
  265.  
  266. (define-rule statement
  267.   (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
  268.                   (REGISTER (? source))
  269.                   (REGISTER 11))
  270.   (if (and (zero? frame-size)
  271.        (= source regnum:stack-pointer))
  272.       (LAP)
  273.       (let ((env-reg (standard-move-to-temporary! source))
  274.         (label (generate-label)))
  275.     (LAP (SLTU ,regnum:assembler-temp ,env-reg ,regnum:dynamic-link)
  276.          (BNE 0 ,regnum:assembler-temp (@PCR ,label))
  277.          (NOP)
  278.          (ADD ,env-reg 0 ,regnum:dynamic-link)
  279.          (LABEL ,label)
  280.          ,@(generate/move-frame-up* frame-size env-reg)))))
  281.  
  282. (define (generate/move-frame-up* frame-size destination)
  283.   ;; Destination is guaranteed to be a machine register number; that
  284.   ;; register has the destination base address for the frame.  The stack
  285.   ;; pointer is reset to the top end of the copied area.
  286.   (LAP ,@(case frame-size
  287.        ((0)
  288.         (LAP))
  289.        ((1)
  290.         (let ((temp (standard-temporary!)))
  291.           (LAP (LD ,temp (OFFSET 0 ,regnum:stack-pointer))
  292.            (ADDI ,destination ,destination -4)
  293.            (ST ,temp (OFFSET 0 ,destination)))))
  294.        (else
  295.         (let ((from (standard-temporary!))
  296.           (temp1 (standard-temporary!))
  297.           (temp2 (standard-temporary!)))
  298.           (LAP ,@(add-immediate (* 4 frame-size) regnum:stack-pointer from)
  299.            ,@(if (<= frame-size 3)
  300.              ;; This code can handle any number > 1
  301.              ;; (handled above), but we restrict it to 3
  302.              ;; for space reasons.
  303.              (let loop ((n frame-size))
  304.                (case n
  305.                  ((0)
  306.                   (LAP))
  307.                  ((3)
  308.                   (let ((temp3 (standard-temporary!)))
  309.                 (LAP (LD ,temp1 (OFFSET -4 ,from))
  310.                      (LD ,temp2 (OFFSET -8 ,from))
  311.                      (LD ,temp3 (OFFSET -12 ,from))
  312.                      (ADDI ,from ,from -12)
  313.                      (ST ,temp1 (OFFSET -4 ,destination))
  314.                      (ST ,temp2 (OFFSET -8 ,destination))
  315.                      (ST ,temp3 (OFFSET -12 ,destination))
  316.                      (ADDI ,destination ,destination -12))))
  317.                  (else
  318.                   (LAP (LD ,temp1 (OFFSET -4 ,from))
  319.                    (LD ,temp2 (OFFSET -8 ,from))
  320.                    (ADDI ,from ,from -8)
  321.                    (ST ,temp1 (OFFSET  -4 ,destination))
  322.                    (ST ,temp2 (OFFSET -8 ,destination))
  323.                    (ADDI ,destination ,destination -8)
  324.                    ,@(loop (- n 2))))))
  325.              (let ((label (generate-label)))
  326.                (LAP ,@(load-immediate temp2 frame-size #F)
  327.                 (LABEL ,label)
  328.                 (LD ,temp1 (OFFSET -4 ,from))
  329.                 (ADDI ,from ,from -4)
  330.                 (ADDI ,temp2 ,temp2 -1)
  331.                 (ADDI ,destination ,destination -4)
  332.                 (BNE ,temp2 0 (@PCR ,label))
  333.                 (ST ,temp1 (OFFSET 0 ,destination)))))))))
  334.        (ADD ,regnum:stack-pointer 0 ,destination)))
  335.  
  336. ;;;; External Labels
  337.  
  338. (define (make-external-label code label)
  339.   (set! *external-labels* (cons label *external-labels*))
  340.   (LAP (EXTERNAL-LABEL ,code (@PCR ,label))
  341.        (LABEL ,label)))
  342.  
  343. ;;; Entry point types
  344.  
  345. (define-integrable (make-code-word min max)
  346.   (+ (* #x100 min) max))
  347.  
  348. (define (make-procedure-code-word min max)
  349.   ;; The "min" byte must be less than #x80; the "max" byte may not
  350.   ;; equal #x80 but can take on any other value.
  351.   (if (or (negative? min) (>= min #x80))
  352.       (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
  353.   (if (>= (abs max) #x80)
  354.       (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
  355.   (make-code-word min (if (negative? max) (+ #x100 max) max)))
  356.  
  357. (define expression-code-word
  358.   (make-code-word #xff #xff))
  359.  
  360. (define internal-entry-code-word
  361.   (make-code-word #xff #xfe))
  362.  
  363. (define internal-continuation-code-word
  364.   (make-code-word #xff #xfc))
  365.  
  366. (define (continuation-code-word label)
  367.   (frame-size->code-word
  368.    (if label
  369.        (rtl-continuation/next-continuation-offset (label->object label))
  370.        0)
  371.    internal-continuation-code-word))
  372.  
  373. (define (internal-procedure-code-word rtl-proc)
  374.   ;; represented as return addresses so the debugger will
  375.   ;; not barf when it sees them (on the stack if interrupted).
  376.   (frame-size->code-word
  377.    (rtl-procedure/next-continuation-offset rtl-proc)
  378.    internal-entry-code-word))
  379.  
  380. (define (frame-size->code-word offset default)
  381.   (cond ((not offset)
  382.      default)
  383.     ((< offset #x2000)
  384.      ;; This uses up through (#xff #xdf).
  385.      (let ((qr (integer-divide offset #x80)))
  386.        (make-code-word (+ #x80 (integer-divide-remainder qr))
  387.                (+ #x80 (integer-divide-quotient qr)))))
  388.     (else
  389.      (error "Unable to encode continuation offset" offset))))
  390.  
  391. ;;;; Procedure headers
  392.  
  393. ;;; The following calls MUST appear as the first thing at the entry
  394. ;;; point of a procedure.  They assume that the register map is clear
  395. ;;; and that no register contains anything of value.
  396. ;;;
  397. ;;; The only reason that this is true is that no register is live
  398. ;;; across calls.  If that were not true, then we would have to save
  399. ;;; any such registers on the stack so that they would be GC'ed
  400. ;;; appropriately.
  401. ;;;
  402. ;;; The only exception is the dynamic link register, handled
  403. ;;; specially.  Procedures that require a dynamic link use a different
  404. ;;; interrupt handler that saves and restores the dynamic link
  405. ;;; register.
  406.  
  407. (define (simple-procedure-header code-word label code)
  408.   (let ((gc-label (generate-label)))    
  409.     (LAP (LABEL ,gc-label)
  410.      ,@(link-to-interface code)
  411.      ,@(make-external-label code-word label)
  412.      ,@(interrupt-check gc-label))))
  413.  
  414. (define (dlink-procedure-header code-word label)
  415.   (let ((gc-label (generate-label)))    
  416.     (LAP (LABEL ,gc-label)
  417.      (ADD ,regnum:third-arg 0 ,regnum:dynamic-link)
  418.      ,@(link-to-interface code:compiler-interrupt-dlink)
  419.      ,@(make-external-label code-word label)
  420.      ,@(interrupt-check gc-label))))
  421.  
  422. (define (interrupt-check gc-label)
  423.   (LAP (SUBCC ,regnum:assembler-temp ,regnum:memtop ,regnum:free)
  424.        (BGE (@PCR ,gc-label))
  425.        (LD ,regnum:memtop ,reg:memtop)
  426.        ))
  427.  
  428. (define-rule statement
  429.   (CONTINUATION-ENTRY (? internal-label))
  430.   (make-external-label (continuation-code-word internal-label)
  431.                internal-label))
  432.  
  433. (define-rule statement
  434.   (CONTINUATION-HEADER (? internal-label))
  435.   (simple-procedure-header (continuation-code-word internal-label)
  436.                internal-label
  437.                code:compiler-interrupt-continuation))
  438.  
  439. (define-rule statement
  440.   (IC-PROCEDURE-HEADER (? internal-label))
  441.   (let ((procedure (label->object internal-label)))
  442.     (let ((external-label (rtl-procedure/external-label procedure)))
  443.     (LAP (ENTRY-POINT ,external-label)
  444.      (EQUATE ,external-label ,internal-label)
  445.      ,@(simple-procedure-header expression-code-word
  446.                     internal-label
  447.                     code:compiler-interrupt-ic-procedure)))))
  448.  
  449. (define-rule statement
  450.   (OPEN-PROCEDURE-HEADER (? internal-label))
  451.   (let ((rtl-proc (label->object internal-label)))
  452.     (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
  453.      ,@((if (rtl-procedure/dynamic-link? rtl-proc)
  454.         dlink-procedure-header 
  455.         (lambda (code-word label)
  456.           (simple-procedure-header code-word label
  457.                        code:compiler-interrupt-procedure)))
  458.         (internal-procedure-code-word rtl-proc)
  459.         internal-label))))
  460.  
  461. (define-rule statement
  462.   (PROCEDURE-HEADER (? internal-label) (? min) (? max))
  463.   (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
  464.            ,internal-label)
  465.        ,@(simple-procedure-header (make-procedure-code-word min max)
  466.                   internal-label
  467.                   code:compiler-interrupt-procedure)))
  468.  
  469. ;;;; Closures.
  470.  
  471. ;; Magic for compiled entries.
  472.  
  473. (define-rule statement
  474.   (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
  475.   entry            ; ignored -- non-RISCs only
  476.   (if (zero? nentries)
  477.       (error "Closure header for closure with no entries!"
  478.          internal-label))
  479.   (let ((rtl-proc (label->object internal-label)))
  480.     (let ((gc-label (generate-label))
  481.       (external-label (rtl-procedure/external-label rtl-proc)))
  482.       (LAP (LABEL ,gc-label)
  483.        ,@(invoke-interface code:compiler-interrupt-closure)
  484.        ,@(make-external-label
  485.           (internal-procedure-code-word rtl-proc)
  486.           external-label)
  487.        (ADDI ,regnum:assembler-temp ,regnum:assembler-temp -12)
  488.        ;; Code below here corresponds to code and count in cmpint2.h
  489.        ,@(fluid-let ((*register-map* *register-map*))
  490.            (let ((temporary (standard-temporary!)))
  491.          ;; Don't cache type constant here, because it won't be
  492.          ;; in the register if the closure is entered from the
  493.          ;; internal label.
  494.          (LAP
  495.           (ADDI ,temporary ,regnum:assembler-temp 0) 
  496.           ,@(put-type (ucode-type compiled-entry) temporary)
  497.           (ADDI ,regnum:stack-pointer ,regnum:stack-pointer -4)
  498.           (ST ,temporary (OFFSET 0 ,regnum:stack-pointer))
  499.           (NOP))))
  500.        (LABEL ,internal-label)
  501.        ,@(interrupt-check gc-label)))))
  502.  
  503. (define (build-gc-offset-word offset code-word)
  504.   (let ((encoded-offset (quotient offset 2)))
  505.     (if (eq? endianness 'LITTLE)
  506.     (+ (* encoded-offset #x10000) code-word)
  507.     (+ (* code-word #x10000) encoded-offset))))
  508.  
  509. (define (closure-bump-size nentries nvars)
  510.   (* (* 4 closure-entry-size)
  511.      (1+ (quotient (+ (+ nvars (-1+ (* closure-entry-size nentries)))
  512.               (-1+ closure-entry-size))
  513.            closure-entry-size))))
  514.  
  515. (define (closure-test-size nentries nvars)
  516.   (* 4
  517.      (+ nvars
  518.     (-1+ (* nentries closure-entry-size)))))
  519.  
  520. (define (cons-closure target label min max nvars)
  521.   
  522.   ;; Invoke an out-of-line handler to set up the closure's entry point.
  523.   ;; Arguments:
  524.   ;; - C_arg1: "Return address"
  525.   ;; - C_arg2: Delta from header data to real closure code
  526.   ;; - C_arg3: Closure size in bytes
  527.   ;; After jumping to the out of line handler, the return address should
  528.   ;; point to the header data.
  529.   ;; Returns closure in regnum:second-arg
  530.   
  531.   (need-register! regnum:first-arg)
  532.   (need-register! regnum:second-arg)
  533.   (need-register! regnum:third-arg)
  534.   (need-register! regnum:fourth-arg)
  535.   (let* ((label-arg (generate-label))
  536.      (dest (standard-target! target)))
  537.     (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -108)
  538.      (ADDI ,regnum:second-arg 0 (- ,(rtl-procedure/external-label (label->object label))
  539.                        ,label-arg))
  540.      (ADDI ,regnum:third-arg 0 ,(+ 20 (* nvars 4)))
  541.      (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
  542.      (ADDI ,regnum:first-arg ,regnum:first-arg 8)
  543.        (LABEL ,label-arg)
  544.          (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
  545.                         (+ closure-entry-size nvars)))
  546.      (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
  547.      (ADDI ,dest ,regnum:second-arg 0)
  548.      ))
  549.   )
  550.  
  551. (define-rule statement
  552.   (ASSIGN (REGISTER (? target))
  553.       (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
  554.             (? min) (? max) (? nvars)))
  555.   (cons-closure target procedure-label min max nvars))
  556.  
  557. (define-rule statement
  558.   (ASSIGN (REGISTER (? target))
  559.       (CONS-MULTICLOSURE (? nentries) (? nvars) (? entries)))
  560.   ;; entries is a vector of all the entry points
  561.   (case nentries
  562.     ((0)
  563.      (let ((dest (standard-target! target))
  564.        (temp (standard-temporary!)))
  565.        (LAP (ADD ,dest 0 ,regnum:free)
  566.         ,@(load-immediate
  567.            temp
  568.            (make-non-pointer-literal (ucode-type manifest-vector) nvars)
  569.            #T)
  570.         (ST ,temp (OFFSET 0 ,regnum:free))
  571.         (ADDI ,regnum:free ,regnum:free ,(* 4 (+ nvars 1))))))
  572.     ((1)
  573.      (let ((entry (vector-ref entries 0)))
  574.        (cons-closure target (car entry) (cadr entry) (caddr entry) nvars)))
  575.     (else
  576.      (cons-multiclosure target nentries nvars (vector->list entries)))))
  577.  
  578. (define (cons-multiclosure target nentries nvars entries)
  579.   ;; Invoke an out-of-line handler to set up the closure's entry points.
  580.   ;; Arguments:
  581.   ;; - C_arg1: Linkage address
  582.   ;; - C_arg2: Number of entries
  583.   ;; - C_arg3: Number of bytes taken up by closures
  584.   
  585.   ;;   C_arg1 points to a manifest closure header word, followed by
  586.   ;;   nentries two-word structures, followed by the actual
  587.   ;;   instructions to return to.
  588.   ;;   The first word of each descriptor is the format+gc-offset word of
  589.   ;;    the corresponding entry point of the generated closure.
  590.   ;;   The second word is the PC-relative JAL instruction.
  591.   ;;    It is transformed into an absolute instruction by adding the shifted
  592.   ;;    "return address".
  593.   ;; Returns closure in regnum:second-arg.
  594.   (rtl-target:=machine-register! target regnum:second-arg)
  595.   (require-register! regnum:first-arg)
  596.   (require-register! regnum:second-arg)
  597.   (require-register! regnum:third-arg)
  598.   (require-register! regnum:fourth-arg)
  599.   (let ((label-arg (generate-label))
  600.     (dest (standard-target! target)))
  601.     (LAP (ADDI ,regnum:assembler-temp ,regnum:scheme-to-interface -256)
  602.      (ADDI ,regnum:second-arg 0 ,nentries)
  603.      (ADDI ,regnum:third-arg ,regnum:free 0)
  604.      (JMPL ,regnum:first-arg ,regnum:assembler-temp 0)
  605.      (ADDI ,regnum:first-arg ,regnum:first-arg 8)
  606.      (LABEL ,label-arg)
  607.          (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
  608.                         (+ 1
  609.                            (* nentries closure-entry-size)
  610.                            nvars)))
  611.          ,@(let expand ((offset 12) (entries entries))
  612.          (if (null? entries)
  613.          (LAP)
  614.          (let ((entry (car entries)))
  615.            (LAP 
  616.             (LONG U ,(build-gc-offset-word
  617.                   offset
  618.                   (make-procedure-code-word (cadr entry)
  619.                             (caddr entry))))
  620.             (LONG U (- ,(rtl-procedure/external-label (label->object (car entry)))
  621.                    ,label-arg))
  622.             ,@(expand (+ offset (* 4 closure-entry-size))
  623.                   (cdr entries))))))
  624.      (ADDI ,dest ,regnum:free 12)
  625.      (ADDI ,regnum:free ,regnum:free ,(* (+ (* nentries closure-entry-size) 2 nvars) 4))
  626.      )))
  627.  
  628. ;;;; Entry Header
  629. ;;; This is invoked by the top level of the LAP generator.
  630.  
  631. (define (generate/quotation-header environment-label free-ref-label n-sections)
  632.   ;; Calls the linker
  633.   ;; On SPARC, regnum:first-arg is used as a temporary here since
  634.   ;; load-pc-relative-address uses the assembler temporary.
  635.   (in-assembler-environment (empty-register-map)
  636.                 (list regnum:first-arg regnum:second-arg
  637.                   regnum:third-arg regnum:fourth-arg)
  638.   (lambda ()
  639.     (let* ((i1
  640.         (load-pc-relative-address regnum:second-arg
  641.                      'CONSTANT environment-label))
  642.        (i2 (load-pc-relative-address regnum:second-arg
  643.                      'CODE *block-label*))
  644.        (i3 (load-pc-relative-address regnum:third-arg
  645.                      'CONSTANT free-ref-label)))
  646.       (LAP (LD ,regnum:first-arg ,reg:environment)
  647.        ,@i1
  648.        (ST ,regnum:first-arg (OFFSET 0 ,regnum:second-arg))
  649.        ,@i2
  650.        ,@i3
  651.        ,@(load-immediate regnum:fourth-arg n-sections #F)
  652.        ,@(link-to-interface code:compiler-link)
  653.        ,@(make-external-label (continuation-code-word false)
  654.                   (generate-label)))))))
  655.  
  656. (define (generate/remote-link code-block-label
  657.                   environment-offset
  658.                   free-ref-offset
  659.                   n-sections)
  660.   ;; Link all of the top level procedures within the file
  661.   (in-assembler-environment (empty-register-map)
  662.                 (list regnum:first-arg regnum:second-arg
  663.                   regnum:third-arg regnum:fourth-arg)
  664.       (lambda ()
  665.     (let ((i1 (load-pc-relative regnum:second-arg 'CODE code-block-label false)))
  666.       (LAP ,@i1
  667.            (LD ,regnum:fourth-arg ,reg:environment)
  668.            ,@(object->address regnum:second-arg regnum:second-arg)
  669.            ,@(add-immediate environment-offset regnum:second-arg regnum:first-arg)
  670.            (ST ,regnum:fourth-arg (OFFSET 0 ,regnum:first-arg))
  671.            ,@(add-immediate free-ref-offset regnum:second-arg regnum:third-arg)
  672.            ,@(load-immediate regnum:fourth-arg n-sections #F)
  673.            ,@(link-to-interface code:compiler-link)
  674.            ,@(make-external-label (continuation-code-word false)
  675.                       (generate-label)))))))
  676.  
  677. (define (in-assembler-environment map needed-registers thunk)
  678.   (fluid-let ((*register-map* map)
  679.           (*prefix-instructions* (LAP))
  680.           (*suffix-instructions* (LAP))
  681.           (*needed-registers* needed-registers))
  682.     (let ((instructions (thunk)))
  683.       (LAP ,@*prefix-instructions*
  684.        ,@instructions
  685.        ,@*suffix-instructions*))))
  686.  
  687. (define (generate/constants-block constants references assignments uuo-links
  688.                   global-links static-vars)
  689.   (let ((constant-info
  690.      (declare-constants 0 (transmogrifly uuo-links)
  691.        (declare-constants 1 references
  692.          (declare-constants 2 assignments
  693.            (declare-constants 3 (transmogrifly global-links)
  694.          (declare-constants false
  695.              (map (lambda (pair)
  696.                 (cons false (cdr pair)))
  697.               static-vars)
  698.            (declare-constants false constants
  699.              (cons false (LAP))))))))))
  700.     (let ((free-ref-label (car constant-info))
  701.       (constants-code (cdr constant-info))
  702.       (debugging-information-label (allocate-constant-label))
  703.       (environment-label (allocate-constant-label))
  704.       (n-sections
  705.        (+ (if (null? uuo-links) 0 1)
  706.           (if (null? references) 0 1)
  707.           (if (null? assignments) 0 1)
  708.           (if (null? global-links) 0 1))))
  709.       (values
  710.        (LAP ,@constants-code
  711.         ;; Place holder for the debugging info filename
  712.         (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
  713.         ;; Place holder for the load time environment if needed
  714.         (SCHEME-OBJECT ,environment-label
  715.                ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
  716.        environment-label
  717.        free-ref-label
  718.        n-sections))))
  719.  
  720. (define (declare-constants tag constants info)
  721.   (define (inner constants)
  722.     (if (null? constants)
  723.     (cdr info)
  724.     (let ((entry (car constants)))
  725.       (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
  726.            ,@(inner (cdr constants))))))
  727.   (if (and tag (not (null? constants)))
  728.       (let ((label (allocate-constant-label)))
  729.     (cons label
  730.           (inner
  731.            `((,(let ((datum (length constants)))
  732.              (if (> datum #xffff)
  733.              (error "datum too large" datum))
  734.              (+ (* tag #x10000) datum))
  735.           . ,label)
  736.          ,@constants))))
  737.       (cons (car info) (inner constants))))
  738.  
  739. (define (transmogrifly uuos)
  740.   (define (inner name assoc)
  741.     (if (null? assoc)
  742.     (transmogrifly (cdr uuos))
  743.     ; produces ((name . label) (0 . label) ... (frame-size . label) ...)
  744.         ; where the (0 . label) is repeated to fill out the size required
  745.         ; as specified in machin.scm
  746.     `((,name . ,(cdar assoc))        ; uuo-label
  747.       ,@(let loop ((count (max 0 (- execute-cache-size 2))))
  748.           (if (= count 0)
  749.           '()
  750.           (cons `(0 . ,(allocate-constant-label))
  751.             (loop (- count 1)))))
  752.       (,(caar assoc) .            ; frame-size
  753.        ,(allocate-constant-label))
  754.       ,@(inner name (cdr assoc)))))
  755.   (if (null? uuos)
  756.       '()
  757.       ;; caar is name, cdar is alist of frame sizes
  758.       (inner (caar uuos) (cdar uuos))))
  759. #|
  760. (define (cons-closure target label min max nvars)
  761.   ;; Invoke an out-of-line handler to set up the closure's entry point.
  762.   ;; Arguments:
  763.   ;; - GR31: "Return address"
  764.   ;;   GR31 points to a manifest closure header word, followed by a
  765.   ;;    two-word closure descriptor, followed by the actual
  766.   ;;    instructions to return to.
  767.   ;;   The first word of the descriptor is the format+gc-offset word of
  768.   ;;    the generated closure.
  769.   ;;   The second word is the PC-relative JAL instruction.
  770.   ;;    It is transformed into an absolute instruction by adding the shifted
  771.   ;;    "return address".
  772.   ;; - GR4: Value to compare to closure free.
  773.   ;; - GR5: Increment for closure free.
  774.   ;; Returns closure in regnum:first-arg (GR4)
  775.   (rtl-target:=machine-register! target regnum:first-arg)
  776.   (require-register! regnum:first-arg)
  777.   (require-register! regnum:second-arg)
  778.   (require-register! regnum:third-arg)
  779.   (require-register! regnum:fourth-arg)
  780.   (let ((label-arg (generate-label)))
  781.     (LAP (ADDI ,regnum:second-arg ,regnum:scheme-to-interface -72)
  782.      (ADDI ,regnum:first-arg ,regnum:closure-free
  783.            ,(closure-test-size 1 nvars))
  784.      (JALR 31 ,regnum:second-arg)
  785.      (ADDI ,regnum:second-arg 0 ,(closure-bump-size 1 nvars))
  786.        (LABEL ,label-arg)
  787.          (LONG U ,(make-non-pointer-literal (ucode-type manifest-closure)
  788.                         (+ closure-entry-size nvars)))
  789.      (LONG U ,(build-gc-offset-word 8 (make-procedure-code-word min max)))
  790.      (LONG U
  791.            (+ #x0c000000        ; JAL opcode
  792.           (/ (- ,(rtl-procedure/external-label (label->object label))
  793.             ,label-arg)
  794.              4))))))
  795. |#
  796.  
  797.  
  798.  
  799. ;;; Local Variables: ***
  800. ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
  801. ;;; End: ***
  802.