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