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 / spectrum / rules3.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  44.8 KB  |  1,253 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules3.scm,v 4.42 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.      ;; This assumes that the return address is always longword aligned
  37.      ;; (it better be, since instructions should be longword aligned).
  38.      ;; Thus the bottom two bits of temp are 0, representing the
  39.      ;; highest privilege level, and the privilege level will
  40.      ;; not be changed by the BV instruction.
  41.      (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp)
  42.      ,@(object->address temp)
  43.      (BV (N) 0 ,temp))))
  44.  
  45. (define-rule statement
  46.   (INVOCATION:APPLY (? frame-size) (? continuation))
  47.   continuation                ;ignore
  48.   (LAP ,@(clear-map!)
  49.        ,@(case frame-size
  50.        ((1) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-1 4
  51.                      ,regnum:scheme-to-interface-ble))))
  52.        ((2) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-2 4
  53.                      ,regnum:scheme-to-interface-ble))))
  54.        ((3) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-3 4
  55.                      ,regnum:scheme-to-interface-ble))))
  56.        ((4) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-4 4
  57.                      ,regnum:scheme-to-interface-ble))))
  58.        ((5) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-5 4
  59.                      ,regnum:scheme-to-interface-ble))))
  60.        ((6) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-6 4
  61.                      ,regnum:scheme-to-interface-ble))))
  62.        ((7) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-7 4
  63.                      ,regnum:scheme-to-interface-ble))))
  64.        ((8) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-8 4
  65.                      ,regnum:scheme-to-interface-ble))))
  66.        (else
  67.         (LAP ,@(load-immediate frame-size regnum:second-arg)
  68.          (BLE () (OFFSET ,hook:compiler-shortcircuit-apply 4
  69.                  ,regnum:scheme-to-interface-ble)))))
  70.        (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)))
  71.  
  72. (define-rule statement
  73.   (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
  74.   frame-size continuation        ;ignore
  75.   (LAP ,@(clear-map!)
  76.        (B (N) (@PCR ,label))))
  77.  
  78. (define-rule statement
  79.   (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
  80.   frame-size continuation        ;ignore
  81.   ;; It expects the procedure at the top of the stack
  82.   (pop-return))
  83.  
  84. (define-rule statement
  85.   (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
  86.   continuation                ;ignore
  87.   (LAP ,@(clear-map!)
  88.        ,@(load-immediate number-pushed regnum:second-arg)
  89.        ,@(load-pc-relative-address label regnum:first-arg 'CODE)
  90.        ,@(invoke-interface code:compiler-lexpr-apply)))
  91.  
  92. (define-rule statement
  93.   (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
  94.   continuation                ;ignore
  95.   ;; Destination address is at TOS; pop it into first-arg
  96.   (LAP ,@(clear-map!)
  97.        (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)
  98.        ,@(load-immediate number-pushed regnum:second-arg)
  99.        ,@(object->address regnum:first-arg)
  100.        ,@(invoke-interface code:compiler-lexpr-apply)))
  101.  
  102. (define-rule statement
  103.   (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
  104.   continuation                ;ignore
  105.   (LAP ,@(clear-map!)
  106.        (B (N) (@PCR ,(free-uuo-link-label name frame-size)))))
  107.  
  108. (define-rule statement
  109.   (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
  110.   continuation                ;ignore
  111.   (LAP ,@(clear-map!)
  112.        (B (N) (@PCR ,(global-uuo-link-label name frame-size)))))
  113.  
  114. (define-rule statement
  115.   (INVOCATION:CACHE-REFERENCE (? frame-size)
  116.                   (? continuation)
  117.                   (? extension register-expression))
  118.   continuation                ;ignore
  119.   (LAP ,@(load-interface-args! extension false false false)
  120.        ,@(load-immediate frame-size regnum:third-arg)
  121.        ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
  122.        ,@(invoke-interface code:compiler-cache-reference-apply)))
  123.  
  124. (define-rule statement
  125.   (INVOCATION:LOOKUP (? frame-size)
  126.              (? continuation)
  127.              (? environment register-expression)
  128.              (? name))
  129.   continuation                ;ignore
  130.   (LAP ,@(load-interface-args! environment false false false)
  131.        ,(load-constant name regnum:second-arg)
  132.        ,(load-immediate frame-size regnum:third-arg)
  133.        ,@(invoke-interface code:compiler-lookup-apply)))
  134.  
  135. (define-rule statement
  136.   (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
  137.   continuation                ;ignore
  138.   (if (eq? primitive compiled-error-procedure)
  139.       (LAP ,@(clear-map!)
  140.        ,@(load-immediate frame-size regnum:first-arg)
  141.        ,@(invoke-interface code:compiler-error))
  142.       (let ((arity (primitive-procedure-arity primitive)))
  143.     (if (not (negative? arity))
  144.         (invoke-primitive primitive
  145.                   hook:compiler-invoke-primitive)
  146.         (LAP ,@(clear-map!)
  147.          ,@(load-pc-relative (constant->label primitive)
  148.                      regnum:first-arg
  149.                      'CONSTANT)
  150.          ,@(cond ((= arity -1)
  151.               (LAP ,@(load-immediate (-1+ frame-size) 1)
  152.                    (STW () 1 ,reg:lexpr-primitive-arity)
  153.                    ,@(invoke-interface
  154.                   code:compiler-primitive-lexpr-apply)))
  155.              #|
  156.              ((not (negative? arity))
  157.               (invoke-interface code:compiler-primitive-apply))
  158.              |#
  159.              (else
  160.               ;; Unknown primitive arity.  Go through apply.
  161.               (LAP ,@(load-immediate frame-size regnum:second-arg)
  162.                    ,@(invoke-interface code:compiler-apply)))))))))
  163.  
  164. (define (invoke-primitive primitive hook)
  165.   ;; Only for known, fixed-arity primitives
  166.   (LAP ,@(clear-map!)
  167.        ,@(invoke-hook hook)
  168.        (WORD () (- ,(constant->label primitive) *PC*))))
  169.  
  170. (let-syntax
  171.     ((define-special-primitive-invocation
  172.        (macro (name)
  173.      `(define-rule statement
  174.         (INVOCATION:SPECIAL-PRIMITIVE
  175.          (? frame-size)
  176.          (? continuation)
  177.          ,(make-primitive-procedure name true))
  178.         frame-size continuation
  179.         (special-primitive-invocation
  180.          ,(symbol-append 'CODE:COMPILER- name)))))
  181.  
  182.      (define-optimized-primitive-invocation
  183.        (macro (name)
  184.      `(define-rule statement
  185.         (INVOCATION:SPECIAL-PRIMITIVE
  186.          (? frame-size)
  187.          (? continuation)
  188.          ,(make-primitive-procedure name true))
  189.         frame-size continuation
  190.         (optimized-primitive-invocation
  191.          ,(symbol-append 'HOOK:COMPILER- name)))))
  192.  
  193.      (define-allocation-primitive
  194.        (macro (name)
  195.      (let ((prim (make-primitive-procedure name true)))
  196.      `(define-rule statement
  197.         (INVOCATION:SPECIAL-PRIMITIVE
  198.          (? frame-size)
  199.          (? continuation)
  200.          ,prim)
  201.         (open-code-block-allocation ',name ',prim
  202.                     ,(symbol-append 'HOOK:COMPILER- name)
  203.                     frame-size continuation))))))
  204.  
  205.   (define-optimized-primitive-invocation &+)
  206.   (define-optimized-primitive-invocation &-)
  207.   (define-optimized-primitive-invocation &*)
  208.   (define-optimized-primitive-invocation &/)
  209.   (define-optimized-primitive-invocation &=)
  210.   (define-optimized-primitive-invocation &<)
  211.   (define-optimized-primitive-invocation &>)
  212.   (define-optimized-primitive-invocation 1+)
  213.   (define-optimized-primitive-invocation -1+)
  214.   (define-optimized-primitive-invocation zero?)
  215.   (define-optimized-primitive-invocation positive?)
  216.   (define-optimized-primitive-invocation negative?)
  217.   (define-special-primitive-invocation quotient)
  218.   (define-special-primitive-invocation remainder)
  219.   (define-allocation-primitive vector-cons)
  220.   (define-allocation-primitive string-allocate)
  221.   (define-allocation-primitive floating-vector-cons))
  222.  
  223. (define (special-primitive-invocation code)
  224.   (LAP ,@(clear-map!)
  225.        ,@(invoke-interface code)))
  226.  
  227. (define (optimized-primitive-invocation hook)
  228.   (LAP ,@(clear-map!)
  229.        ,@(invoke-hook/no-return hook)))
  230.  
  231. (define (open-code-block-allocation name prim hook frame-size cont-label)
  232.   name frame-size cont-label            ; ignored
  233.   (invoke-primitive prim hook))
  234.  
  235. #|
  236. (define (open-code-block-allocation name prim hook frame-size cont-label)
  237.   ;; One argument (length in units) on top of the stack.
  238.   ;; Note: The length checked is not necessarily the complete length
  239.   ;; of the object, but is off by a constant number of words, which
  240.   ;; is OK, since we can cons a finite number of words without
  241.   ;; checking.
  242.   (define (default)
  243.     (LAP ,@(clear-map!)
  244.      ,@(load-pc-relative (constant->label prim)
  245.                  regnum:first-arg
  246.                  'CONSTANT)
  247.      ,@(invoke-interface code:compiler-primitive-apply)))
  248.  
  249.   hook                    ; ignored
  250.   (cond ((not (= frame-size 2))
  251.      (error "open-code-allocate-block: Wrong number of arguments"
  252.         prim frame-size))
  253.     ((not compiler:open-code-primitives?)
  254.      (default))
  255.     (else
  256.      (let ((label (generate-label))
  257.            (rsp regnum:stack-pointer)
  258.            (rfp regnum:free-pointer)
  259.            (rmp regnum:memtop-pointer)
  260.            (ra1 regnum:first-arg)
  261.            (ra2 regnum:second-arg)
  262.            (ra3 regnum:third-arg)
  263.            (rrv regnum:return-value))
  264.  
  265.        (define (end tag rl)
  266.          (LAP ,@(deposit-type (ucode-type manifest-nm-vector) rl)
  267.           (STW () ,rl (OFFSET 0 0 ,rrv))
  268.           ,@(deposit-type tag rrv)
  269.           (LDO () (OFFSET ,(* 4 frame-size) 0 ,rsp) ,rsp)
  270.           (B (N) (@PCR ,cont-label))
  271.           (LABEL ,label)
  272.           ,@(default)))
  273.          
  274.        (case name
  275.          ((STRING-ALLOCATE)
  276.           (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
  277.            (COPY () ,rfp ,rrv)
  278.            ,@(object->datum ra1 ra1)
  279.            (ADD () ,ra1 ,rfp ,ra2)
  280.            (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
  281.            (STB () 0 (OFFSET 8 0 ,ra2))
  282.            (SHD () 0 ,ra1 2 ,ra3)
  283.            (LDO () (OFFSET 2 0 ,ra3) ,ra3)
  284.            (STWS (MB) ,ra1 (OFFSET 4 0 ,rfp))
  285.            (SH2ADD () ,ra3 ,rfp ,rfp)
  286.            ,@(end (ucode-type string) ra3)))
  287.          ((FLOATING-VECTOR-CONS)
  288.           (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
  289.            ;; (STW () 0 (OFFSET 0 0 ,rfp))
  290.            (DEPI () #b100 31 3 ,rfp)
  291.            (COPY () ,rfp ,rrv)
  292.            ,@(object->datum ra1 ra1)
  293.            (SH3ADD () ,ra1 ,rfp ,ra2)
  294.            (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
  295.            (SHD () ,ra1 0 31 ,ra1)
  296.            (LDO () (OFFSET 4 0 ,ra2) ,rfp)
  297.            ,@(end (ucode-type flonum) ra1)))
  298.          (else
  299.           (error "open-code-block-allocation: Unknown primitive"
  300.              name)))))))
  301. |#            
  302.  
  303. ;;;; Invocation Prefixes
  304.  
  305. ;;; MOVE-FRAME-UP size address
  306. ;;;
  307. ;;; Moves up the last <size> words of the stack so that the first of
  308. ;;; these words is at location <address>, and resets the stack pointer
  309. ;;; to the last of these words.  That is, it pops off all the words
  310. ;;; between <address> and TOS+/-<size>.
  311.  
  312. (define-rule statement
  313.   ;; Move up 0 words back to top of stack : a No-Op
  314.   (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? reg)))
  315.   (QUALIFIER (= reg regnum:stack-pointer))
  316.   (LAP))
  317.  
  318. (define-rule statement
  319.   ;; Move <frame-size> words back to dynamic link marker
  320.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg)))
  321.   (QUALIFIER (= reg regnum:dynamic-link))
  322.   (generate/move-frame-up frame-size
  323.               (lambda (reg)
  324.                 (LAP (COPY () ,regnum:dynamic-link ,reg)))))
  325.  
  326. (define-rule statement
  327.   ;; Move <frame-size> words back to SP+offset
  328.   (INVOCATION-PREFIX:MOVE-FRAME-UP
  329.    (? frame-size)
  330.    (OFFSET-ADDRESS (REGISTER (? reg))
  331.            (MACHINE-CONSTANT (? offset))))
  332.   (QUALIFIER (= reg regnum:stack-pointer))
  333.   (let ((how-far (* 4 (- offset frame-size))))
  334.     (cond ((zero? how-far)
  335.        (LAP))
  336.       ((negative? how-far)
  337.        (error "invocation-prefix:move-frame-up: bad specs"
  338.           frame-size offset))
  339.       ((zero? frame-size)
  340.        (load-offset how-far regnum:stack-pointer regnum:stack-pointer))
  341.       ((= frame-size 1)
  342.        (let ((temp (standard-temporary!)))
  343.          (LAP (LDWM () (OFFSET ,how-far 0 ,regnum:stack-pointer) ,temp)
  344.           (STW () ,temp (OFFSET 0 0 ,regnum:stack-pointer)))))
  345.       ((= frame-size 2)
  346.        (let ((temp1 (standard-temporary!))
  347.          (temp2 (standard-temporary!)))
  348.          (LAP (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp1)
  349.           (LDWM () (OFFSET ,(- how-far 4) 0 ,regnum:stack-pointer)
  350.             ,temp2)
  351.           (STW () ,temp1 (OFFSET 0 0 ,regnum:stack-pointer))
  352.           (STW () ,temp2 (OFFSET 4 0 ,regnum:stack-pointer)))))
  353.       (else
  354.        (generate/move-frame-up frame-size
  355.          (lambda (reg)
  356.            (load-offset (* 4 offset) regnum:stack-pointer reg)))))))
  357.  
  358. (define-rule statement
  359.   ;; Move <frame-size> words back to base virtual register + offset
  360.   (INVOCATION-PREFIX:MOVE-FRAME-UP
  361.    (? frame-size)
  362.    (OFFSET-ADDRESS (REGISTER (? base))
  363.            (MACHINE-CONSTANT (? offset))))
  364.   (generate/move-frame-up frame-size
  365.     (lambda (reg)
  366.       (load-offset (* 4 offset) (standard-source! base) reg))))
  367.  
  368. ;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
  369. ;;; and <current dynamic link> as arguments.  They pop the stack by
  370. ;;; removing the lesser of the amount needed to move the stack pointer
  371. ;;; back to the <new frame end> or <current dynamic link>.  The last
  372. ;;; <frame-size> words on the stack (the stack frame for the procedure
  373. ;;; about to be called) are then put back onto the newly adjusted
  374. ;;; stack.
  375.  
  376. (define-rule statement
  377.   (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
  378.                   (REGISTER (? source))
  379.                   (REGISTER (? reg)))
  380.   (QUALIFIER (= reg regnum:dynamic-link))
  381.   (if (and (zero? frame-size)
  382.        (= source regnum:stack-pointer))
  383.       (LAP)
  384.       (let ((env-reg (standard-move-to-temporary! source)))
  385.     (LAP
  386.      ;; skip if env LS dyn link
  387.      (SUB (<<=) ,env-reg ,regnum:dynamic-link 0)
  388.      ;; env <- dyn link
  389.      (COPY () ,regnum:dynamic-link ,env-reg)
  390.      ,@(generate/move-frame-up* frame-size env-reg)))))
  391.  
  392. (define (generate/move-frame-up frame-size destination-generator)
  393.   (let ((temp (standard-temporary!)))
  394.     (LAP ,@(destination-generator temp)
  395.      ,@(generate/move-frame-up* frame-size temp))))
  396.  
  397. (define (generate/move-frame-up* frame-size destination)
  398.   ;; Destination is guaranteed to be a machine register number; that
  399.   ;; register has the destination base address for the frame.  The stack
  400.   ;; pointer is reset to the top end of the copied area.
  401.   (LAP ,@(case frame-size
  402.        ((0)
  403.         (LAP))
  404.        ((1)
  405.         (let ((temp (standard-temporary!)))
  406.           (LAP (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,temp)
  407.            (STWM () ,temp (OFFSET -4 0 ,destination)))))
  408.        (else
  409.         (generate/move-frame-up** frame-size destination)))
  410.        (COPY () ,destination ,regnum:stack-pointer)))
  411.  
  412. (define (generate/move-frame-up** frame-size dest)
  413.   (let ((from (standard-temporary!))
  414.     (temp1 (standard-temporary!))
  415.     (temp2 (standard-temporary!)))
  416.     (LAP ,@(load-offset (* 4 frame-size) regnum:stack-pointer from)
  417.      ,@(if (<= frame-size 3)
  418.            ;; This code can handle any number > 1 (handled above),
  419.            ;; but we restrict it to 3 for space reasons.
  420.            (let loop ((n frame-size))
  421.          (case n
  422.            ((0)
  423.             (LAP))
  424.            ((3)
  425.             (let ((temp3 (standard-temporary!)))
  426.               (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
  427.                (LDWM () (OFFSET -4 0 ,from) ,temp2)
  428.                (LDWM () (OFFSET -4 0 ,from) ,temp3)
  429.                (STWM () ,temp1 (OFFSET -4 0 ,dest))
  430.                (STWM () ,temp2 (OFFSET -4 0 ,dest))
  431.                (STWM () ,temp3 (OFFSET -4 0 ,dest)))))
  432.            (else
  433.             (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
  434.              (LDWM () (OFFSET -4 0 ,from) ,temp2)
  435.              (STWM () ,temp1 (OFFSET -4 0 ,dest))
  436.              (STWM () ,temp2 (OFFSET -4 0 ,dest))
  437.              ,@(loop (- n 2))))))
  438.            (LAP ,@(load-immediate frame-size temp2)
  439.             (LDWM () (OFFSET -4 0 ,from) ,temp1)
  440.             (ADDIBF (=) -1 ,temp2 (@PCO -12))
  441.             (STWM () ,temp1 (OFFSET -4 0 ,dest)))))))
  442.  
  443. ;;;; External Labels
  444.  
  445. (define (make-external-label code label)
  446.   (set! *external-labels* (cons label *external-labels*))
  447.   (LAP (EXTERNAL-LABEL () ,code (@PCR ,label))
  448.        (LABEL ,label)))
  449.  
  450. ;;; Entry point types
  451.  
  452. (define-integrable (make-code-word min max)
  453.   (+ (* #x100 min) max))
  454.  
  455. (define (make-procedure-code-word min max)
  456.   ;; The "min" byte must be less than #x80; the "max" byte may not
  457.   ;; equal #x80 but can take on any other value.
  458.   (if (or (negative? min) (>= min #x80))
  459.       (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
  460.   (if (>= (abs max) #x80)
  461.       (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
  462.   (make-code-word min (if (negative? max) (+ #x100 max) max)))
  463.  
  464. (define expression-code-word
  465.   (make-code-word #xff #xff))
  466.  
  467. (define internal-entry-code-word
  468.   (make-code-word #xff #xfe))
  469.  
  470. (define internal-continuation-code-word
  471.   (make-code-word #xff #xfc))
  472.  
  473. ;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface
  474.  
  475. (define internal-closure-code-word
  476.   (make-code-word #xff #xfa))
  477.  
  478. (define (continuation-code-word label)
  479.   (frame-size->code-word
  480.    (if label
  481.        (rtl-continuation/next-continuation-offset (label->object label))
  482.        0)
  483.    internal-continuation-code-word))
  484.  
  485. (define (internal-procedure-code-word rtl-proc)
  486.   ;; represented as return addresses so the debugger will
  487.   ;; not barf when it sees them (on the stack if interrupted).
  488.   (frame-size->code-word
  489.    (rtl-procedure/next-continuation-offset rtl-proc)
  490.    internal-entry-code-word))
  491.  
  492. (define (frame-size->code-word offset default)
  493.   (cond ((not offset)
  494.      default)
  495.     ((< offset #x2000)
  496.      ;; This uses up through (#xff #xdf).
  497.      (let ((qr (integer-divide offset #x80)))
  498.        (make-code-word (+ #x80 (integer-divide-remainder qr))
  499.                (+ #x80 (integer-divide-quotient qr)))))
  500.     (else
  501.      (error "Unable to encode continuation offset" offset))))
  502.  
  503. ;;;; Procedure headers
  504.  
  505. ;;; The following calls MUST appear as the first thing at the entry
  506. ;;; point of a procedure.  They assume that the register map is clear
  507. ;;; and that no register contains anything of value.
  508. ;;;
  509. ;;; The only reason that this is true is that no register is live
  510. ;;; across calls.  If that were not true, then we would have to save
  511. ;;; any such registers on the stack so that they would be GC'ed
  512. ;;; appropriately.
  513. ;;;
  514. ;;; The only exception is the dynamic link register, handled
  515. ;;; specially.  Procedures that require a dynamic link use a different
  516. ;;; interrupt handler that saves and restores the dynamic link
  517. ;;; register.
  518.  
  519. (define (simple-procedure-header code-word label code)
  520.   (let ((gc-label (generate-label)))    
  521.     (LAP (LABEL ,gc-label)
  522.      ,@(invoke-interface-ble code)
  523.      ,@(make-external-label code-word label)
  524.      ,@(interrupt-check label gc-label))))
  525.  
  526. (define (dlink-procedure-header code-word label)
  527.   (let ((gc-label (generate-label)))    
  528.     (LAP (LABEL ,gc-label)
  529.      (COPY () ,regnum:dynamic-link ,regnum:second-arg)
  530.      ,@(invoke-interface-ble code:compiler-interrupt-dlink)
  531.      ,@(make-external-label code-word label)
  532.      ,@(interrupt-check label gc-label))))
  533.  
  534. (define (interrupt-check label gc-label)
  535.   (case (let ((object (label->object label)))
  536.       (and (rtl-procedure? object)
  537.            (not (rtl-procedure/stack-leaf? object))
  538.            compiler:generate-stack-checks?))
  539.     ((#F)
  540.      (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
  541.         (@PCR ,gc-label))
  542.       (LDW () ,reg:memtop ,regnum:memtop-pointer)))
  543.     ((OUT-OF-LINE)
  544.      (let ((label (generate-label)))
  545.        (LAP (BLE ()
  546.          (OFFSET ,hook:compiler-stack-and-interrupt-check
  547.              4
  548.              ,regnum:scheme-to-interface-ble))
  549.         ;; Assumes that (<= #x-2000 (- ,gc-label ,label) #x1fff)
  550.         ;; otherwise this assembles to two instructions, and it
  551.         ;; won't fit in the branch-delay slot.
  552.         (LDI () (- ,gc-label ,label) ,regnum:first-arg)
  553.         (LABEL ,label))))
  554.     (else
  555.      (LAP (LDW () ,reg:stack-guard ,regnum:first-arg)
  556.       (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
  557.         (@PCR ,gc-label))
  558.       (COMB (<=) ,regnum:stack-pointer ,regnum:first-arg (@PCR ,gc-label))
  559.       (LDW () ,reg:memtop ,regnum:memtop-pointer)))))
  560.  
  561. (define-rule statement
  562.   (CONTINUATION-ENTRY (? internal-label))
  563.   (make-external-label (continuation-code-word internal-label)
  564.                internal-label))
  565.  
  566. (define-rule statement
  567.   (CONTINUATION-HEADER (? internal-label))
  568.   (simple-procedure-header (continuation-code-word internal-label)
  569.                internal-label
  570.                code:compiler-interrupt-continuation))
  571.  
  572. (define-rule statement
  573.   (IC-PROCEDURE-HEADER (? internal-label))
  574.   (let ((procedure (label->object internal-label)))
  575.     (let ((external-label (rtl-procedure/external-label procedure)))
  576.     (LAP (ENTRY-POINT ,external-label)
  577.      (EQUATE ,external-label ,internal-label)
  578.      ,@(simple-procedure-header expression-code-word
  579.                     internal-label
  580.                     code:compiler-interrupt-ic-procedure)))))
  581.  
  582. (define-rule statement
  583.   (OPEN-PROCEDURE-HEADER (? internal-label))
  584.   (let ((rtl-proc (label->object internal-label)))
  585.     (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
  586.      ,@((if (rtl-procedure/dynamic-link? rtl-proc)
  587.         dlink-procedure-header 
  588.         (lambda (code-word label)
  589.           (simple-procedure-header code-word label
  590.                        code:compiler-interrupt-procedure)))
  591.         (internal-procedure-code-word rtl-proc)
  592.         internal-label))))
  593.  
  594. (define-rule statement
  595.   (PROCEDURE-HEADER (? internal-label) (? min) (? max))
  596.   (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
  597.            ,internal-label)
  598.        ,@(simple-procedure-header (make-procedure-code-word min max)
  599.                   internal-label
  600.                   code:compiler-interrupt-procedure)))
  601.  
  602. ;;;; Closures.  These two statements are intertwined:
  603.  
  604. (define-rule statement
  605.   ;; This depends on the following facts:
  606.   ;; 1- TC_COMPILED_ENTRY is a multiple of two.
  607.   ;; 2- all the top 6 bits in a data address are 0 except the quad bit
  608.   ;; 3- type codes are 6 bits long.
  609.   (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
  610.   entry                ; Used only if entries may not be word-aligned.
  611.   (if (zero? nentries)
  612.       (error "Closure header for closure with no entries!"
  613.          internal-label))
  614.  
  615.   ;; Closures used to use (internal-procedure-code-word rtl-proc)
  616.   ;; instead of internal-closure-code-word.
  617.   ;; This confused the bkpt utilties and was unnecessary because
  618.   ;; these entry points cannot properly be used as return addresses.
  619.  
  620.   (let* ((rtl-proc (label->object internal-label))
  621.      (external-label (rtl-procedure/external-label rtl-proc)))
  622.     (let ((suffix
  623.        (lambda (gc-label)
  624.          (LAP ,@(make-external-label internal-closure-code-word
  625.                      external-label)
  626.           ,@(address->entry g25)
  627.           (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer))
  628.           (LABEL ,internal-label)
  629.           ,@(interrupt-check internal-label gc-label)))))
  630.       (share-instruction-sequence!
  631.        'CLOSURE-GC-STUB
  632.        suffix
  633.        (lambda (gc-label)
  634.      (LAP (LABEL ,gc-label)
  635.           ,@(invoke-interface code:compiler-interrupt-closure)
  636.           ,@(suffix gc-label)))))))
  637.  
  638. (define-rule statement
  639.   (ASSIGN (REGISTER (? target))
  640.       (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
  641.             (? min) (? max) (? size)))
  642.   (cons-closure target procedure-label min max size))
  643.  
  644. (define-rule statement
  645.   (ASSIGN (REGISTER (? target))
  646.       (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
  647.   ;; entries is a vector of all the entry points
  648.   (case nentries
  649.     ((0)
  650.      (let ((dest (standard-target! target)))
  651.        (LAP ,@(load-non-pointer (ucode-type manifest-vector)
  652.                 size
  653.                 dest)
  654.         (STW () ,dest (OFFSET 0 0 ,regnum:free-pointer))
  655.         (COPY () ,regnum:free-pointer ,dest)
  656.         ,@(load-offset (* 4 (1+ size))
  657.                regnum:free-pointer
  658.                regnum:free-pointer))))
  659.     ((1)
  660.      (let ((entry (vector-ref entries 0)))
  661.        (cons-closure
  662.     target (car entry) (cadr entry) (caddr entry) size)))
  663.     (else
  664.      (cons-multiclosure target nentries size (vector->list entries)))))
  665.  
  666. #|
  667. ;;; Old style closure consing -- Out of line.
  668.  
  669. (define (%cons-closure target total-size size core)
  670.   (let* ((flush-reg (require-registers! regnum:first-arg
  671.                     #| regnum:addil-result |#
  672.                         regnum:ble-return))
  673.      (target (standard-target! target)))
  674.     (LAP ,@flush-reg
  675.      ;; Vector header
  676.      ,@(load-non-pointer (ucode-type manifest-closure)
  677.                  total-size
  678.                  regnum:first-arg)
  679.      (STWS (MA C) ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer))
  680.      ;; Make entries and store result
  681.      ,@(core target)
  682.      ;; Allocate space for closed-over variables
  683.      ,@(load-offset (* 4 size)
  684.             regnum:free-pointer
  685.             regnum:free-pointer))))
  686.  
  687. (define (cons-closure target entry min max size)
  688.   (%cons-closure
  689.    target
  690.    (+ size closure-entry-size)
  691.    size
  692.    (lambda (target)
  693.      (LAP ;; Entry point is result.
  694.      ,@(load-offset 4 regnum:free-pointer target)
  695.      ,@(cons-closure-entry entry min max 8)))))
  696.  
  697. (define (cons-multiclosure target nentries size entries)
  698.   (define (generate-entries offset entries)
  699.     (if (null? entries)
  700.     (LAP)
  701.     (let ((entry (car entries)))
  702.       (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry)
  703.                      offset)
  704.            ,@(generate-entries (+ offset (* 4 closure-entry-size))
  705.                    (cdr entries))))))
  706.  
  707.   (%cons-closure
  708.    target
  709.    (+ 1 (* closure-entry-size nentries) size)
  710.    size
  711.    (lambda (target)
  712.      (LAP ;; Number of closure entries
  713.      ,@(load-entry-format nentries 0 target)
  714.      (STWS (MA C) ,target (OFFSET 4 0 ,regnum:free-pointer))
  715.      ;; First entry point is result.
  716.      ,@(load-offset 4 regnum:free-pointer target)
  717.      ,@(generate-entries 12 entries)))))
  718.  
  719. ;; Utilities for old-style closure consing.
  720.  
  721. (define (load-entry-format code-word gc-offset dest)
  722.   (load-immediate (+ (* code-word #x10000)
  723.              (quotient gc-offset 2))
  724.           dest))
  725.  
  726. (define (cons-closure-entry entry min max offset)
  727.   ;; Call an out-of-line hook to do this.
  728.   ;; Making the instructions is a lot of work!
  729.   ;; Perhaps there should be a closure hook invoked and the real
  730.   ;; entry point could follow.  It would also be easier on the GC.
  731.   (let ((entry-label (rtl-procedure/external-label (label->object entry))))
  732.     (LAP ,@(load-entry-format (make-procedure-code-word min max)
  733.                   offset
  734.                   regnum:first-arg)
  735.      #|
  736.      ;; This does not work!!! The LDO may overflow.
  737.      ;; A new pseudo-op has been introduced for this purpose.
  738.      (BLE ()
  739.           (OFFSET ,hook:compiler-store-closure-entry
  740.               4
  741.               ,regnum:scheme-to-interface-ble))
  742.      (LDO ()
  743.           (OFFSET (- ,entry-label (+ *PC* 4))
  744.               0
  745.               ,regnum:ble-return)
  746.           ,regnum:addil-result)
  747.      |#
  748.      (PCR-HOOK ()
  749.            ,regnum:addil-result
  750.            (OFFSET ,hook:compiler-store-closure-entry
  751.                4
  752.                ,regnum:scheme-to-interface-ble)
  753.            (@PCR ,entry-label)))))
  754. |#
  755.  
  756. ;; Magic for compiled entries.
  757.  
  758. (define compiled-entry-type-im5
  759.   (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
  760.      (immed (integer-divide-quotient qr)))
  761.     (if (or (not (= scheme-type-width 6))
  762.         (not (zero? (integer-divide-remainder qr)))
  763.         (not (<= 0 immed #x1F)))
  764.     (error "HPPA RTL rules3: closure header rule assumptions violated!"))
  765.     (if (<= immed #x0F)
  766.     immed
  767.     (- immed #x20))))
  768.  
  769. (define-integrable (address->entry register)
  770.   (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
  771.  
  772. ;;; New style closure consing using compiler-prepared and
  773. ;;; linker-maintained patterns
  774.  
  775. ;; Compiled code blocks are aligned like floating-point numbers and vectors.
  776. ;; That is, the address of their header word is congruent 4 mod 8
  777.  
  778. (define *initial-dword-offset* 4)
  779. (define *closure-padding-bitstring* (make-bit-string 32 false))
  780.  
  781. ;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h
  782.  
  783. (define *ldil/ble-split*
  784.   ;; (expt 2 13) ***
  785.   8192)
  786.  
  787. (define *ldil-factor*
  788.   ;; (/ *ldil/ble-split* ldil-scale)
  789.   4)
  790.  
  791. (define (declare-closure-pattern! pattern)
  792.   (add-extra-code!
  793.    (or (find-extra-code-block 'CLOSURE-PATTERNS)
  794.        (let ((section-label (generate-label))
  795.          (ev-label (generate-label)))
  796.      (let ((block (declare-extra-code-block!
  797.                'CLOSURE-PATTERNS
  798.                'LAST
  799.                `(((/ (- ,ev-label ,section-label) 4)
  800.               . ,ev-label)))))
  801.        (add-extra-code! block
  802.                 (LAP (LABEL ,section-label)))
  803.        block)))
  804.    (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*)
  805.     ,@pattern)))
  806.  
  807. (define (generate-closure-entry offset pattern label min max)
  808.   (let ((entry-label (rtl-procedure/external-label (label->object label))))
  809.     (LAP (USHORT ()
  810.          ,(make-procedure-code-word min max)
  811.          ,(quotient offset 2))
  812.      ;; This contains an offset -- the linker turns it to an abs. addr.
  813.      (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label)
  814.                    ,*ldil/ble-split*)
  815.              ,*ldil-factor*)
  816.            26)
  817.      (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label)
  818.                     ,*ldil/ble-split*)
  819.              5 26))
  820.      (ADDI () -15 31 25))))
  821.  
  822. (define (cons-closure target entry-label min max size)
  823.   (let ((offset 8)
  824.     (total-size (+ size closure-entry-size))
  825.     (pattern (generate-label)))
  826.  
  827.     (declare-closure-pattern!
  828.      (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label))
  829.       (LABEL ,pattern)
  830.       (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
  831.                            total-size))
  832.       ,@(generate-closure-entry offset pattern entry-label min max)))
  833.     #|
  834.     ;; This version uses ordinary integer instructions
  835.  
  836.     (let* ((offset* (* 4 (1+ closure-entry-size)))
  837.        (target (standard-target! target))
  838.        (temp1 (standard-temporary!))
  839.        (temp2 (standard-temporary!))
  840.        (temp3 (standard-temporary!)))
  841.  
  842.       (LAP ,@(load-pc-relative-address pattern target 'CODE)
  843.        (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
  844.        (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
  845.        (LDWS (MA) (OFFSET 4 0 ,target) ,temp3)
  846.        (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
  847.        (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
  848.        (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer))
  849.  
  850.        (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
  851.        (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
  852.        (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
  853.        (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
  854.        (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target)
  855.        (FDC () (INDEX 0 0 ,target))
  856.        (FDC () (INDEX 0 0 ,regnum:free-pointer))
  857.        (SYNC ())
  858.        (FIC () (INDEX 0 5 ,target))
  859.        (SYNC ())
  860.        (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
  861.         ,regnum:free-pointer)))
  862.     |#
  863.  
  864.     #|
  865.     ;; This version is faster by using floating-point (doubleword) moves
  866.  
  867.     (let* ((offset* (* 4 (1+ closure-entry-size)))
  868.        (target (standard-target! target))
  869.        (dwtemp1 (flonum-temporary!))
  870.        (dwtemp2 (flonum-temporary!))
  871.        (swtemp (standard-temporary!)))
  872.  
  873.       (LAP ,@(load-pc-relative-address pattern target 'CODE)
  874.        (DEPI () #b100 31 3 ,regnum:free-pointer)        ; quad align
  875.        (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp)
  876.            (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1)
  877.        (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer))
  878.        (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2)
  879.        (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
  880.        (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer)
  881.         ,target)
  882.        (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
  883.        (FDC () (INDEX 0 0 ,target))
  884.        (FDC () (INDEX 0 0 ,regnum:free-pointer))
  885.        (SYNC ())
  886.        (FIC () (INDEX 0 5 ,target))
  887.        (SYNC ())
  888.        (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
  889.         ,regnum:free-pointer)))
  890.     |#
  891.  
  892.     ;; This version does the copy out of line, using fp instructions.
  893.  
  894.     (let* ((hook-label (generate-label))
  895.        (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
  896.                       #| regnum:addil-result |#
  897.                       regnum:ble-return)))
  898.       (delete-register! target)
  899.       (delete-dead-registers!)
  900.       (add-pseudo-register-alias! target g25)
  901.       (LAP ,@flush-reg
  902.        ,@(invoke-hook hook:compiler-copy-closure-pattern)
  903.        (LABEL ,hook-label)
  904.        (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
  905.        (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
  906.         ,regnum:free-pointer)))))
  907.  
  908. (define (cons-multiclosure target nentries size entries)
  909.   ;; nentries > 1
  910.   (let ((offset 12)
  911.     (total-size (+ (+ 1 (* closure-entry-size nentries)) size))
  912.     (pattern (generate-label)))
  913.  
  914.     (declare-closure-pattern!
  915.      (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries)))
  916.       (LABEL ,pattern)
  917.       (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
  918.                            total-size))
  919.       (USHORT () ,nentries 0)
  920.       ,@(let make-entries ((entries entries)
  921.                    (offset offset))
  922.           (if (null? entries)
  923.           (LAP)
  924.           (let ((entry (car entries)))
  925.             (LAP ,@(generate-closure-entry offset
  926.                            pattern
  927.                            (car entry)
  928.                            (cadr entry)
  929.                            (caddr entry))
  930.              ,@(make-entries (cdr entries)
  931.                      (+ offset
  932.                         (* 4 closure-entry-size)))))))))
  933.     #|
  934.     ;; This version uses ordinary integer instructions
  935.  
  936.     (let ((target (standard-target! target)))
  937.       (let ((temp1 (standard-temporary!))
  938.         (temp2 (standard-temporary!))
  939.         (ctr (standard-temporary!))
  940.         (srcptr (standard-temporary!))
  941.         (index (standard-temporary!))
  942.         (loop-label (generate-label)))
  943.  
  944.     (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
  945.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
  946.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
  947.          (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
  948.          (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
  949.          (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target)
  950.          (LDI () -16 ,index)
  951.          (LDI () ,nentries ,ctr)
  952.          ;; The loop copies 16 bytes, and the architecture specifies
  953.          ;; that a cache line must be a multiple of this value.
  954.          ;; Therefore we only need to flush once per loop,
  955.          ;; and once more (D only) to take care of phase.
  956.          (LABEL ,loop-label)
  957.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
  958.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
  959.          (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
  960.          (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
  961.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
  962.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
  963.          (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
  964.          (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
  965.          (FDC () (INDEX ,index 0 ,regnum:free-pointer))
  966.          (SYNC ())
  967.          (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label))
  968.          (FIC () (INDEX ,index 5 ,regnum:free-pointer))
  969.          (FDC () (INDEX 0 0 ,regnum:free-pointer))
  970.          (SYNC ())
  971.          (FIC () (INDEX 0 5 ,regnum:free-pointer))
  972.          (SYNC ())
  973.          (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
  974.           ,regnum:free-pointer))))
  975.     |#
  976.  
  977.     #|
  978.     ;; This version is faster by using floating-point (doubleword) moves
  979.  
  980.     (let ((target (standard-target! target)))
  981.       (let ((dwtemp1 (flonum-temporary!))
  982.         (dwtemp2 (flonum-temporary!))
  983.         (temp (standard-temporary!))
  984.         (ctr (standard-temporary!))
  985.         (srcptr (standard-temporary!))
  986.         (index (standard-temporary!))
  987.         (loop-label (generate-label)))
  988.  
  989.     (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
  990.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
  991.          (DEPI () #b100 31 3 ,regnum:free-pointer)        ; quad align
  992.          (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
  993.          (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target)
  994.          (LDI () -16 ,index)
  995.          (LDI () ,nentries ,ctr)
  996.  
  997.          ;; The loop copies 16 bytes, and the architecture specifies
  998.          ;; that a cache line must be a multiple of this value.
  999.          ;; Therefore we only need to flush (D) once per loop,
  1000.          ;; and once more to take care of phase.
  1001.          ;; We only need to flush the I cache once because it is
  1002.          ;; newly allocated memory.
  1003.  
  1004.          (LABEL ,loop-label)
  1005.          (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1)
  1006.          (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2)
  1007.          (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
  1008.          (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
  1009.          (ADDIB (>) -1 ,ctr (@PCR ,loop-label))
  1010.          (FDC () (INDEX ,index 0 ,regnum:free-pointer))
  1011.         
  1012.          (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
  1013.          (LDI () ,(* -4 (1+ size)) ,index)
  1014.          (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer))
  1015.          (FDC () (INDEX ,index 0 ,regnum:free-pointer))
  1016.          (SYNC ())
  1017.          (FIC () (INDEX 0 5 ,target))
  1018.          (SYNC ()))))
  1019.     |#
  1020.     
  1021.     ;; This version does the copy out of line, using fp instructions.
  1022.  
  1023.     (let* ((hook-label (generate-label))
  1024.        (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
  1025.                       #| regnum:addil-result |#
  1026.                       regnum:ble-return)))
  1027.       (delete-register! target)
  1028.       (delete-dead-registers!)
  1029.       (add-pseudo-register-alias! target g25)
  1030.       (LAP ,@flush-reg
  1031.        (LDI () ,nentries 1)
  1032.        ,@(invoke-hook hook:compiler-copy-multiclosure-pattern)
  1033.        (LABEL ,hook-label)
  1034.        (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
  1035.        (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
  1036.         ,regnum:free-pointer)))))
  1037.  
  1038. ;;;; Entry Header
  1039. ;;; This is invoked by the top level of the LAP generator.
  1040.  
  1041. (define (generate/quotation-header environment-label free-ref-label n-sections)
  1042.   ;; Calls the linker
  1043.   (in-assembler-environment
  1044.    (empty-register-map)
  1045.    (list regnum:first-arg regnum:second-arg
  1046.      regnum:third-arg regnum:fourth-arg)
  1047.    (lambda ()
  1048.      (let ((segment (load-pc-relative-address environment-label 1 'CONSTANT)))
  1049.        (LAP (LDW () ,reg:environment 2)
  1050.         ,@segment
  1051.         (STW () 2 (OFFSET 0 0 1))
  1052.         ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
  1053.         ,@(load-pc-relative-address free-ref-label regnum:third-arg
  1054.                     'CONSTANT)
  1055.         ,@(load-immediate n-sections regnum:fourth-arg)
  1056.         ,@(invoke-interface-ble code:compiler-link)
  1057.         ,@(make-external-label (continuation-code-word false)
  1058.                    (generate-label)))))))
  1059.  
  1060. (define (generate/remote-link code-block-label
  1061.                   environment-offset
  1062.                   free-ref-offset
  1063.                   n-sections)
  1064.   ;; Link all of the top level procedures within the file
  1065.   (in-assembler-environment
  1066.    (empty-register-map)
  1067.    (list regnum:first-arg regnum:second-arg
  1068.      regnum:third-arg regnum:fourth-arg)
  1069.    (lambda ()
  1070.      (let ((segment (load-pc-relative code-block-label regnum:second-arg
  1071.                       'CONSTANT)))
  1072.        (LAP ,@segment
  1073.         ,@(object->address regnum:second-arg)
  1074.         (LDW () ,reg:environment 2)
  1075.         ,@(load-offset environment-offset regnum:second-arg 1)
  1076.         (STW () 2 (OFFSET 0 0 1))
  1077.         ,@(load-offset free-ref-offset regnum:second-arg regnum:third-arg)
  1078.         ,@(load-immediate n-sections regnum:fourth-arg)
  1079.         ,@(invoke-interface-ble code:compiler-link)
  1080.         ,@(make-external-label (continuation-code-word false)
  1081.                    (generate-label)))))))
  1082.  
  1083. (define (in-assembler-environment map needed-registers thunk)
  1084.   (fluid-let ((*register-map* map)
  1085.           (*prefix-instructions* (LAP))
  1086.           (*suffix-instructions* (LAP))
  1087.           (*needed-registers* needed-registers))
  1088.     (let ((instructions (thunk)))
  1089.       (LAP ,@*prefix-instructions*
  1090.        ,@instructions
  1091.        ,@*suffix-instructions*))))
  1092.  
  1093. (define (generate/remote-links n-code-blocks code-blocks-label n-sections)
  1094.   (if (= n-code-blocks 0)
  1095.       (LAP)
  1096.       (let ((loop (generate-label))
  1097.         (bytes (generate-label))
  1098.         (after-bytes (generate-label)))
  1099.     (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))
  1100.          (COPY () 0 ,regnum:first-arg)
  1101.          (LABEL ,loop)
  1102.          (LDO () (OFFSET 1 0 ,regnum:first-arg) ,regnum:second-arg)
  1103.          (STW () ,regnum:second-arg (OFFSET 0 0 ,regnum:stack-pointer))
  1104.          (BL () ,regnum:third-arg (@PCR ,after-bytes))
  1105.          (DEP () 0 31 2 ,regnum:third-arg)
  1106.          (LABEL ,bytes)
  1107.          ,@(sections->bytes n-code-blocks n-sections)
  1108.          (LABEL ,after-bytes)
  1109.          (LDBX () (INDEX ,regnum:first-arg 0 ,regnum:third-arg)
  1110.            ,regnum:fourth-arg)
  1111.          (LDW () (OFFSET (- ,code-blocks-label ,bytes) 0 ,regnum:third-arg)
  1112.           ,regnum:third-arg)
  1113.          ,@(object->address regnum:third-arg)
  1114.          (LDWX (S) (INDEX ,regnum:second-arg 0 ,regnum:third-arg)
  1115.            ,regnum:second-arg)
  1116.          ,@(object->address regnum:second-arg)
  1117.          (LDW () (OFFSET 4 0 ,regnum:second-arg) ,regnum:third-arg)
  1118.          (LDW () (OFFSET 0 0 ,regnum:second-arg) ,regnum:first-arg)
  1119.          (LDW () ,reg:environment 2)
  1120.          ,@(object->datum regnum:third-arg regnum:third-arg)
  1121.          ,@(object->datum regnum:first-arg regnum:first-arg)
  1122.          (SH2ADD () ,regnum:third-arg ,regnum:second-arg ,regnum:third-arg)
  1123.          (SH2ADD () ,regnum:first-arg ,regnum:second-arg
  1124.              ,regnum:first-arg)
  1125.          (LDO () (OFFSET 8 0 ,regnum:third-arg) ,regnum:third-arg)
  1126.          (STW () 2 (OFFSET 0 0 ,regnum:first-arg))
  1127.          ,@(invoke-interface-ble code:compiler-link)
  1128.          ,@(make-external-label (continuation-code-word false)
  1129.                     (generate-label))     
  1130.          (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,regnum:first-arg)
  1131.          ,@(cond ((fits-in-5-bits-signed? n-code-blocks)
  1132.               (LAP (COMIBF (<=) ,n-code-blocks ,regnum:first-arg
  1133.                    (@PCR ,loop))
  1134.                (NOP ())))
  1135.              ((fits-in-11-bits-signed? n-code-blocks)
  1136.               (LAP (COMICLR (<=) ,n-code-blocks ,regnum:first-arg 0)
  1137.                (B (N) (@PCR ,loop))))
  1138.              (else
  1139.               (LAP (LDI () ,n-code-blocks ,regnum:second-arg)
  1140.                (COMBF (<=) ,regnum:second-arg ,regnum:first-arg
  1141.                   (@PCR ,loop))
  1142.                (NOP ()))))
  1143.          (LDO () (OFFSET 4 0 ,regnum:stack-pointer)
  1144.           ,regnum:stack-pointer)))))
  1145.  
  1146. (define (sections->bytes n-code-blocks n-sections)
  1147.   (let walk ((bytes
  1148.           (append (vector->list n-sections)
  1149.               (let ((left (remainder n-code-blocks 4)))
  1150.             (if (zero? left)
  1151.                 '()
  1152.                 (make-list (- 4 left) 0))))))
  1153.     (if (null? bytes)
  1154.     (LAP)
  1155.     (let ((hi (car bytes))
  1156.           (midhi (cadr bytes))
  1157.           (midlo (caddr bytes))
  1158.           (lo (cadddr bytes)))
  1159.       (LAP (UWORD () ,(+ lo (* 256
  1160.                    (+ midlo (* 256 (+ midhi (* 256 hi)))))))
  1161.            ,@(walk (cddddr bytes)))))))
  1162.  
  1163. (define (generate/constants-block constants references assignments
  1164.                   uuo-links global-links static-vars)
  1165.   (let ((constant-info
  1166.      ;; Note: generate/remote-links depends on all the linkage sections
  1167.      ;; (references & uuos) being first!
  1168.      (declare-constants 0 (transmogrifly uuo-links)
  1169.        (declare-constants 1 references
  1170.          (declare-constants 2 assignments
  1171.            (declare-constants 3 (transmogrifly global-links)
  1172.          (declare-closure-patterns
  1173.           (declare-constants false (map (lambda (pair)
  1174.                           (cons false (cdr pair)))
  1175.                         static-vars)
  1176.             (declare-constants false constants
  1177.               (cons false (LAP)))))))))))
  1178.     (let ((free-ref-label (car constant-info))
  1179.       (constants-code (cdr constant-info))
  1180.       (debugging-information-label (allocate-constant-label))
  1181.       (environment-label (allocate-constant-label))
  1182.       (n-sections
  1183.        (+ (if (null? uuo-links) 0 1)
  1184.           (if (null? references) 0 1)
  1185.           (if (null? assignments) 0 1)
  1186.           (if (null? global-links) 0 1)
  1187.           (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1))))
  1188.       (values
  1189.        (LAP ,@constants-code
  1190.         ;; Place holder for the debugging info filename
  1191.         (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
  1192.         ;; Place holder for the load time environment if needed
  1193.         (SCHEME-OBJECT ,environment-label
  1194.                ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
  1195.        environment-label
  1196.        free-ref-label
  1197.        n-sections))))
  1198.  
  1199. (define (declare-constants/tagged tag header constants info)
  1200.   (define-integrable (wrap tag label value)
  1201.     (LAP (,tag ,label ,value)))
  1202.  
  1203.   (define (inner constants)
  1204.     (if (null? constants)
  1205.     (cdr info)
  1206.     (let ((entry (car constants)))
  1207.       (LAP ,@(wrap tag (cdr entry) (car entry))
  1208.            ,@(inner (cdr constants))))))
  1209.  
  1210.   (if (and header (not (null? constants)))
  1211.       (let ((label (allocate-constant-label)))
  1212.     (cons label
  1213.           (LAP (SCHEME-OBJECT
  1214.             ,label
  1215.             ,(let ((datum (length constants)))
  1216.                (if (> datum #xffff)
  1217.                (error "datum too large" datum))
  1218.                (+ (* header #x10000) datum)))
  1219.            ,@(inner constants))))
  1220.       (cons (car info) (inner constants))))
  1221.  
  1222. (define (declare-constants header constants info)
  1223.   (declare-constants/tagged 'SCHEME-OBJECT header constants info))
  1224.  
  1225. (define (declare-closure-patterns info)
  1226.   (let ((block (find-extra-code-block 'CLOSURE-PATTERNS)))
  1227.     (if (not block)
  1228.     info
  1229.     (declare-constants/tagged 'SCHEME-EVALUATION
  1230.                   4
  1231.                   (extra-code-block/xtra block)
  1232.                   info))))
  1233.  
  1234. (define (declare-evaluations header evals info)
  1235.   (declare-constants/tagged 'SCHEME-EVALUATION header evals info))
  1236.  
  1237. (define (transmogrifly uuos)
  1238.   (define (inner name assoc)
  1239.     (if (null? assoc)
  1240.     (transmogrifly (cdr uuos))
  1241.     `((,name . ,(cdar assoc))        ; uuo-label    LDIL
  1242.       (0 . ,(allocate-constant-label))    ; spare        BLE
  1243.       (,(caar assoc) .            ; frame-size
  1244.        ,(allocate-constant-label))
  1245.       ,@(inner name (cdr assoc)))))
  1246.   (if (null? uuos)
  1247.       '()
  1248.       (inner (caar uuos) (cdar uuos))))
  1249.  
  1250. ;;; Local Variables: ***
  1251. ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
  1252. ;;; End: ***
  1253.