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 / vax / rules3.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  23.5 KB  |  689 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules3.scm,v 4.12 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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-integrable (clear-continuation-type-code)
  30.   (LAP (BIC L ,mask-reference (@R 14))))
  31.  
  32. (define-rule statement
  33.   (POP-RETURN)
  34.   (LAP ,@(clear-map!)
  35.        ,@(clear-continuation-type-code)
  36.        (RSB)))
  37.  
  38. (define-rule statement
  39.   (INVOCATION:APPLY (? frame-size) (? continuation))
  40.   continuation                ; ignored
  41.   (LAP ,@(clear-map!)
  42.        ,@(load-rn frame-size 2)
  43.        #|
  44.        (JMP ,entry:compiler-shortcircuit-apply)
  45.        |#
  46.        (MOV L (@R+ 14) (R 1))
  47.        ,@(invoke-interface code:compiler-apply)
  48.        ;; 'Til here
  49.        ))
  50.  
  51. (define-rule statement
  52.   (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
  53.   frame-size continuation        ; ignored
  54.   (LAP ,@(clear-map!)
  55.        (BR (@PCR ,label))))
  56.  
  57. (define-rule statement
  58.   (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
  59.   frame-size continuation        ; ignored
  60.   ;; It expects the procedure at the top of the stack
  61.   (LAP ,@(clear-map!)
  62.        ,@(clear-continuation-type-code)
  63.        (RSB)))
  64.  
  65. (define-rule statement
  66.   (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
  67.   continuation                ; ignored
  68.   (LAP ,@(clear-map!)
  69.        ,@(load-rn number-pushed 2)
  70.        (MOVA B (@PCR ,label) (R 1))
  71.        ,@(invoke-interface code:compiler-lexpr-apply)))
  72.  
  73. (define-rule statement
  74.   (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
  75.   continuation                ; ignored
  76.   ;; It expects the procedure at the top of the stack
  77.   (LAP ,@(clear-map!)
  78.        ,@(load-rn number-pushed 2)
  79.        (BIC L ,mask-reference (@R+ 14) (R 1))
  80.        ,@(invoke-interface code:compiler-lexpr-apply)))
  81.  
  82. (define-rule statement
  83.   (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
  84.   continuation                ; ignored
  85.   (LAP ,@(clear-map!)
  86.        ;; The following assumes that at label there is
  87.        ;;    (JMP (L <entry>))
  88.        ;; The other possibility would be
  89.        ;;       (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
  90.        ;; and to have <entry> at label, but it is longer and slower.
  91.        ;; The 2 below accomodates the arrangement between the arity
  92.        ;; and the instructions in an execute cache.
  93.        (BR (@PCRO ,(free-uuo-link-label name frame-size) 2))))
  94.  
  95. (define-rule statement
  96.   (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
  97.   continuation                ; ignored
  98.   (LAP ,@(clear-map!)
  99.        (BR (@PCRO ,(global-uuo-link-label name frame-size) 2))))
  100.  
  101. ;;; The following two rules are obsolete.  They haven't been used in a while.
  102. ;;; They are provided in case the relevant switches are turned off, but there
  103. ;;; is no reason to do this.  Perhaps the switches should be removed.
  104.  
  105. (define-rule statement
  106.   (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
  107.   continuation                ; ignored
  108.   (let* ((set-extension 
  109.       (interpreter-call-argument->machine-register! extension r1))
  110.      (clear-map (clear-map!)))
  111.     (LAP ,@set-extension
  112.      ,@clear-map
  113.      ,@(load-rn frame-size 3)
  114.      (MOVA B (@PCR ,*block-label*) (R 2))
  115.      ,@(invoke-interface code:compiler-cache-reference-apply))))
  116.  
  117. (define-rule statement
  118.   (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name))
  119.   continuation                ; ignored
  120.   (let* ((set-environment
  121.       (interpreter-call-argument->machine-register! environment r1))
  122.      (clear-map (clear-map!)))
  123.     (LAP ,@set-environment
  124.      ,@clear-map
  125.      ,@(load-constant name (INST-EA (R 2)))
  126.      ,@(load-rn frame-size 3)
  127.      ,@(invoke-interface code:compiler-lookup-apply))))
  128.  
  129. (define-rule statement
  130.   (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
  131.   continuation                ; ignored
  132.   (LAP ,@(clear-map!)
  133.        ,@(if (eq? primitive compiled-error-procedure)
  134.          (LAP ,@(load-rn frame-size 1)
  135.           #|
  136.           (JMP ,entry:compiler-error)
  137.           |#
  138.           ,@(invoke-interface code:compiler-error))
  139.          (let ((arity (primitive-procedure-arity primitive)))
  140.            (cond ((not (negative? arity))
  141.               (LAP (MOV L (@PCR ,(constant->label primitive)) (R 1))
  142.                #|
  143.                (JMP ,entry:compiler-primitive-apply)
  144.                |#
  145.                ,@(invoke-interface code:compiler-primitive-apply)))
  146.              ((= arity -1)
  147.               (LAP (MOV L ,(make-immediate (-1+ frame-size))
  148.                 ,reg:lexpr-primitive-arity)
  149.                (MOV L (@PCR ,(constant->label primitive)) (R 1))
  150.                #|
  151.                (JMP ,entry:compiler-primitive-lexpr-apply)
  152.                |#
  153.                ,@(invoke-interface
  154.                   code:compiler-primitive-lexpr-apply)))
  155.              (else
  156.               ;; Unknown primitive arity.  Go through apply.
  157.               (LAP ,@(load-rn frame-size 2)
  158.                (MOV L (constant->ea primitive) (R 1))
  159.                #|
  160.                (JMP ,entry:compiler-apply)
  161.                |#
  162.                ,@(invoke-interface code:compiler-apply))))))))
  163.  
  164. (let-syntax
  165.     ((define-special-primitive-invocation
  166.        (macro (name)
  167.      `(define-rule statement
  168.         (INVOCATION:SPECIAL-PRIMITIVE
  169.          (? frame-size)
  170.          (? continuation)
  171.          ,(make-primitive-procedure name true))
  172.         frame-size continuation    ; ignored
  173.         ,(list 'LAP
  174.            (list 'UNQUOTE-SPLICING '(clear-map!))
  175.            #|
  176.            (list 'JMP
  177.              (list 'UNQUOTE
  178.                    (symbol-append 'ENTRY:COMPILER- name)))
  179.            |#
  180.            (list 'UNQUOTE-SPLICING
  181.              `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER-
  182.                                 name))))))))
  183.   (define-special-primitive-invocation &+)
  184.   (define-special-primitive-invocation &-)
  185.   (define-special-primitive-invocation &*)
  186.   (define-special-primitive-invocation &/)
  187.   (define-special-primitive-invocation &=)
  188.   (define-special-primitive-invocation &<)
  189.   (define-special-primitive-invocation &>)
  190.   (define-special-primitive-invocation 1+)
  191.   (define-special-primitive-invocation -1+)
  192.   (define-special-primitive-invocation zero?)
  193.   (define-special-primitive-invocation positive?)
  194.   (define-special-primitive-invocation negative?))
  195.  
  196. ;;;; Invocation Prefixes
  197.  
  198. (define-rule statement
  199.   (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 14))
  200.   (LAP))
  201.  
  202. (define-rule statement
  203.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER 13))
  204.   (generate/move-frame-up frame-size (offset-reference 13 0)))
  205.  
  206. (define-rule statement
  207.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
  208.                    (OFFSET-ADDRESS (REGISTER 14) (? offset)))
  209.   (let ((how-far (- offset frame-size)))
  210.     (cond ((zero? how-far)
  211.        (LAP))
  212.       ((zero? frame-size)
  213.        (increment-rn 14 (* 4 how-far)))
  214.       ((= frame-size 1)
  215.        (LAP (MOV L (@R+ 14) ,(offset-reference r14 (-1+ how-far)))
  216.         ,@(increment-rn 14 (* 4 (-1+ how-far)))))
  217.       ((= frame-size 2)
  218.        (if (= how-far 1)
  219.            (LAP (MOV L (@RO B 14 4) (@RO B 14 8))
  220.             (MOV L (@R+ 14) (@R 14)))
  221.            (let ((i (lambda ()
  222.               (LAP (MOV L (@R+ 14)
  223.                     ,(offset-reference r14 (-1+ how-far)))))))
  224.          (LAP ,@(i)
  225.               ,@(i)
  226.               ,@(increment-rn 14 (* 4 (- how-far 2)))))))
  227.       (else
  228.        (generate/move-frame-up frame-size
  229.                    (offset-reference r14 offset))))))
  230.  
  231. (define-rule statement
  232.   (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
  233.                    (OFFSET-ADDRESS (REGISTER (? base))
  234.                            (? offset)))
  235.   (QUALIFIER (pseudo-register? base))
  236.   (generate/move-frame-up frame-size (indirect-reference! base offset)))
  237.  
  238. (define-rule statement
  239.   (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 14) (REGISTER 13))
  240.   (LAP))
  241.  
  242. (define-rule statement
  243.   (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
  244.                   (OFFSET-ADDRESS (REGISTER (? base))
  245.                           (? offset))
  246.                   (REGISTER 13))
  247.   (let ((label (generate-label))
  248.     (temp (allocate-temporary-register! 'GENERAL)))
  249.     (let ((temp-ref (register-reference temp)))
  250.       (LAP (MOVA L ,(indirect-reference! base offset) ,temp-ref)
  251.        (CMP L ,temp-ref (R 13))
  252.        (B B LEQU (@PCR ,label))
  253.        (MOV L (R 13) ,temp-ref)
  254.        (LABEL ,label)
  255.        ,@(generate/move-frame-up* frame-size temp)))))
  256.  
  257. (define-rule statement
  258.   (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
  259.                   (OBJECT->ADDRESS (REGISTER (? source)))
  260.                   (REGISTER 13))
  261.   (QUALIFIER (pseudo-register? source))
  262.   (let ((do-it
  263.      (lambda (reg-ref)
  264.        (let ((label (generate-label)))
  265.          (LAP (CMP L ,reg-ref (R 13))
  266.           (B B LEQU (@PCR ,label))
  267.           (MOV L (R 13) ,reg-ref)
  268.           (LABEL ,label)
  269.           ,@(generate/move-frame-up* frame-size
  270.                          (lap:ea-R-register reg-ref)))))))
  271.     (with-temporary-register-copy! source 'GENERAL
  272.       (lambda (temp)
  273.     (LAP (BIC L ,mask-reference ,temp)
  274.          ,@(do-it temp)))
  275.       (lambda (source temp)
  276.     (LAP (BIC L ,mask-reference ,source ,temp)
  277.          ,@(do-it temp))))))
  278.  
  279. (define-rule statement
  280.   (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
  281.                   (REGISTER (? source))
  282.                   (REGISTER 13))
  283.   (QUALIFIER (pseudo-register? source))
  284.   (let ((reg-ref (move-to-temporary-register! source 'GENERAL))
  285.     (label (generate-label)))
  286.     (LAP (CMP L ,reg-ref (R 13))
  287.      (B B LEQU (@PCR ,label))
  288.      (MOV L (R 13) ,reg-ref)
  289.      (LABEL ,label)
  290.      ,@(generate/move-frame-up* frame-size
  291.                     (lap:ea-R-register reg-ref)))))
  292.  
  293. (define (generate/move-frame-up frame-size destination)
  294.   (let ((temp (allocate-temporary-register! 'GENERAL)))
  295.     (LAP (MOVA L ,destination ,(register-reference temp))
  296.      ,@(generate/move-frame-up* frame-size temp))))
  297.  
  298. (define (generate/move-frame-up* frame-size destination)
  299.   (let ((temp (allocate-temporary-register! 'GENERAL)))
  300.     (LAP (MOVA L ,(offset-reference r14 frame-size) ,(register-reference temp))
  301.      ,@(generate-n-times
  302.         frame-size 5
  303.         (lambda ()
  304.           (LAP (MOV L (@-R ,temp) (@-R ,destination))))
  305.         (lambda (generator)
  306.           (generator (allocate-temporary-register! 'GENERAL))))
  307.      (MOV L ,(register-reference destination) (R 14)))))
  308.  
  309. ;;;; External Labels
  310.  
  311. (define (make-external-label code label)
  312.   (set! *external-labels* (cons label *external-labels*))
  313.   (LAP (WORD U ,code)
  314.        (BLOCK-OFFSET ,label)
  315.        (LABEL ,label)))
  316.  
  317. ;;; Entry point types
  318.  
  319. (define-integrable (make-format-longword format-word gc-offset)
  320.   (+ (* #x20000 gc-offset) format-word))
  321.  
  322. (define-integrable (make-code-word min max)
  323.   (+ (* #x100 min) max))
  324.  
  325. (define (make-procedure-code-word min max)
  326.   ;; The "min" byte must be less than #x80; the "max" byte may not
  327.   ;; equal #x80 but can take on any other value.
  328.   (if (or (negative? min) (>= min #x80))
  329.       (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
  330.   (if (>= (abs max) #x80)
  331.       (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
  332.   (make-code-word min (if (negative? max) (+ #x100 max) max)))
  333.  
  334. (define expression-code-word
  335.   (make-code-word #xff #xff))
  336.  
  337. (define internal-entry-code-word
  338.   (make-code-word #xff #xfe))
  339.  
  340. (define internal-continuation-code-word
  341.   (make-code-word #xff #xfc))
  342.  
  343. (define (frame-size->code-word offset default)
  344.   (cond ((not offset)
  345.      default)
  346.     ((< offset #x2000)
  347.      ;; This uses up through (#xff #xdf).
  348.      (let ((qr (integer-divide offset #x80)))
  349.        (make-code-word (+ #x80 (integer-divide-remainder qr))
  350.                (+ #x80 (integer-divide-quotient qr)))))
  351.     (else
  352.      (error "Unable to encode continuation offset" offset))))
  353.  
  354. (define (continuation-code-word label)
  355.   (frame-size->code-word
  356.    (if label
  357.        (rtl-continuation/next-continuation-offset (label->object label))
  358.        0)
  359.    internal-continuation-code-word))
  360.  
  361. (define (internal-procedure-code-word rtl-proc)
  362.   (frame-size->code-word
  363.    (rtl-procedure/next-continuation-offset rtl-proc)
  364.    internal-entry-code-word))
  365.  
  366. ;;;; Procedure headers
  367.  
  368. ;;; The following calls MUST appear as the first thing at the entry
  369. ;;; point of a procedure.  They assume that the register map is clear
  370. ;;; and that no register contains anything of value.
  371. ;;;
  372. ;;; The only reason that this is true is that no register is live
  373. ;;; across calls.  If that were not true, then we would have to save
  374. ;;; any such registers on the stack so that they would be GC'ed
  375. ;;; appropriately.
  376. ;;;
  377. ;;; The only exception is the dynamic link register, handled
  378. ;;; specially.  Procedures that require a dynamic link use a different
  379. ;;; interrupt handler that saves and restores the dynamic link
  380. ;;; register.
  381.  
  382. (define (interrupt-check procedure-label interrupt-label)
  383.   ;; This always does interrupt/stack checks in line.
  384.   (LAP (CMP L (R ,regnum:free-pointer) ,reg:compiled-memtop)
  385.        (B B GEQ (@PCR ,interrupt-label))
  386.        ,@(if (let ((object (label->object procedure-label)))
  387.            (and (rtl-procedure? object)
  388.             (not (rtl-procedure/stack-leaf? object))
  389.             compiler:generate-stack-checks?))
  390.          (LAP (CMP L (R ,regnum:stack-pointer) ,reg:stack-guard)
  391.           (B B LSS (@PCR ,interrupt-label)))
  392.          (LAP))))
  393.  
  394. (define (simple-procedure-header code-word label
  395.                  ;; entry:compiler-interrupt
  396.                  code:compiler-interrupt)
  397.   (let ((gc-label (generate-label)))
  398.     (LAP (LABEL ,gc-label)
  399.      #|
  400.      (JSB ,entry:compiler-interrupt)
  401.      |#
  402.      ,@(invoke-interface-jsb code:compiler-interrupt)
  403.      ,@(make-external-label code-word label)
  404.      ,@(interrupt-check label gc-label))))
  405.  
  406. (define (dlink-procedure-header code-word label)
  407.   (let ((gc-label (generate-label)))    
  408.     (LAP (LABEL ,gc-label)
  409.      #|
  410.      (JSB ,entry:compiler-interrupt-dlink)
  411.      |#
  412.      (MOV L (R 13) (R 2))        ; move dlink to arg register.
  413.      ,@(invoke-interface-jsb code:compiler-interrupt-dlink)
  414.      ;; 'Til here
  415.      ,@(make-external-label code-word label)
  416.      ,@(interrupt-check label gc-label))))
  417.  
  418. (define-rule statement
  419.   (CONTINUATION-ENTRY (? internal-label))
  420.   (make-external-label (continuation-code-word internal-label)
  421.                internal-label))
  422.  
  423. (define-rule statement
  424.   (CONTINUATION-HEADER (? internal-label))
  425.   (simple-procedure-header (continuation-code-word internal-label)
  426.                internal-label
  427.                ;; entry:compiler-interrupt-continuation
  428.                code:compiler-interrupt-continuation))
  429.  
  430. (define-rule statement
  431.   (IC-PROCEDURE-HEADER (? internal-label))
  432.   (let* ((procedure (label->object internal-label))
  433.      (external-label (rtl-procedure/external-label procedure)))
  434.     (LAP (ENTRY-POINT ,external-label)
  435.      (EQUATE ,external-label ,internal-label)
  436.      ,@(simple-procedure-header expression-code-word
  437.                     internal-label
  438.                     ;; entry:compiler-interrupt-ic-procedure
  439.                     code:compiler-interrupt-ic-procedure))))
  440.  
  441. (define-rule statement
  442.   (OPEN-PROCEDURE-HEADER (? internal-label))
  443.   (let ((rtl-proc (label->object internal-label)))
  444.     (LAP
  445.      (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
  446.      ,@((if (rtl-procedure/dynamic-link? rtl-proc)
  447.         dlink-procedure-header 
  448.         (lambda (code-word label)
  449.           (simple-procedure-header code-word label
  450.                        ;; entry:compiler-interrupt-procedure
  451.                        code:compiler-interrupt-procedure)))
  452.     (internal-procedure-code-word rtl-proc)
  453.     internal-label))))
  454.  
  455. (define-rule statement
  456.   (PROCEDURE-HEADER (? internal-label) (? min) (? max))
  457.   (LAP (EQUATE ,(rtl-procedure/external-label
  458.          (label->object internal-label))
  459.            ,internal-label)
  460.        ,@(simple-procedure-header (make-procedure-code-word min max)
  461.                   internal-label
  462.                   ;; entry:compiler-interrupt-procedure
  463.                   code:compiler-interrupt-procedure)))
  464.  
  465. ;;;; Closures.  These two statements are intertwined:
  466. ;;; Note: If the closure is a multiclosure, the closure object on the
  467. ;;; stack corresponds to the first (official) entry point.
  468. ;;; Thus on entry and interrupt it must be bumped around.
  469.  
  470. (define (make-magic-closure-constant entry)
  471.   (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
  472.      (+ (* entry 10) 6)))
  473.  
  474. (define-rule statement
  475.   (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
  476.   nentries                ; ignored
  477.   (let ((rtl-proc (label->object internal-label)))
  478.     (let ((gc-label (generate-label))
  479.       (external-label (rtl-procedure/external-label rtl-proc)))
  480.       (if (zero? nentries)
  481.       (LAP (EQUATE ,external-label ,internal-label)
  482.            ,@(simple-procedure-header
  483.           (internal-procedure-code-word rtl-proc)
  484.           internal-label
  485.           ;; entry:compiler-interrupt-procedure
  486.           code:compiler-interrupt-procedure))
  487.       (LAP (LABEL ,gc-label)
  488.            ,@(increment/ea (INST-EA (@R 14)) (* 10 entry))
  489.            #|
  490.            (JMP ,entry:compiler-interrupt-closure)
  491.            |#
  492.            ,@(invoke-interface code:compiler-interrupt-closure)
  493.            ,@(make-external-label internal-entry-code-word
  494.                       external-label)
  495.            (ADD L (&U ,(make-magic-closure-constant entry)) (@R 14))
  496.            (LABEL ,internal-label)
  497.            ,@(interrupt-check internal-label gc-label))))))
  498.  
  499. (define-rule statement
  500.   (ASSIGN (REGISTER (? target))
  501.       (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
  502.             (? min) (? max) (? size)))
  503.   (let ((target (standard-target-reference target)))
  504.     (generate/cons-closure target
  505.                false procedure-label min max size)))
  506.  
  507. (define (generate/cons-closure target type procedure-label min max size)
  508.   (LAP ,@(load-non-pointer (ucode-type manifest-closure)
  509.                (+ 3 size)
  510.                (INST-EA (@R+ 12)))
  511.        (MOV L (&U ,(make-format-longword (make-procedure-code-word min max) 8))
  512.         (@R+ 12))
  513.        ,@(if type
  514.          (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) (R 12)
  515.                ,target))
  516.          (LAP (MOV L (R 12) ,target)))
  517.        (MOV W (&U #x9f16) (@R+ 12))    ; (JSB (@& <entry>))
  518.        (MOVA B (@PCR ,(rtl-procedure/external-label
  519.                (label->object procedure-label)))
  520.          (@R+ 12))
  521.        (CLR W (@R+ 12))
  522.        ,@(increment-rn 12 (* 4 size))))
  523.  
  524. (define-rule statement
  525.   (ASSIGN (REGISTER (? target))
  526.       (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
  527.   (let ((target (standard-target-reference target)))
  528.     (case nentries
  529.       ((0)
  530.        (LAP (MOV L (R 12) ,target)
  531.         ,@(load-non-pointer (ucode-type manifest-vector)
  532.                 size
  533.                 (INST-EA (@R+ 12)))
  534.         ,@(increment-rn 12 (* 4 size))))
  535.       ((1)
  536.        (let ((entry (vector-ref entries 0)))
  537.      (generate/cons-closure target false
  538.                 (car entry) (cadr entry) (caddr entry)
  539.                 size)))
  540.       (else
  541.        (generate/cons-multiclosure target nentries size
  542.                    (vector->list entries))))))
  543.  
  544. (define (generate/cons-multiclosure target nentries size entries)
  545.   (let ((total-size (+ size
  546.                (quotient (+ 3 (* 5 nentries))
  547.                  2)))
  548.     (temp (standard-temporary-reference)))
  549.  
  550.     (define (generate-entries entries offset first?)
  551.       (if (null? entries)
  552.       (LAP)
  553.       (let ((entry (car entries)))
  554.         (LAP (MOV L (&U ,(make-format-longword
  555.                   (make-procedure-code-word (cadr entry)
  556.                             (caddr entry))
  557.                   offset))
  558.               (@R+ 12))
  559.          ,@(if first?
  560.                (LAP (MOV L (R 12) ,target))
  561.                (LAP))
  562.          (MOV W ,temp (@R+ 12))    ; (JSB (@& <entry>))
  563.          (MOVA B (@PCR ,(rtl-procedure/external-label
  564.                  (label->object (car entry))))
  565.                (@R+ 12))
  566.          ,@(generate-entries (cdr entries)
  567.                      (+ 10 offset)
  568.                      false)))))
  569.  
  570.     (LAP ,@(load-non-pointer (ucode-type manifest-closure)
  571.                  total-size
  572.                  (INST-EA (@R+ 12)))
  573.      (MOV L (&U ,(make-format-longword nentries 0)) (@R+ 12))
  574.      (MOV W (&U #x9f16) ,temp)
  575.      ,@(generate-entries entries 12 true)
  576.      ,@(if (odd? nentries)
  577.            (LAP (CLR W (@R+ 12)))
  578.            (LAP))
  579.      ,@(increment-rn 12 (* 4 size)))))
  580.  
  581. ;;;; Entry Header
  582. ;;; This is invoked by the top level of the LAP GENERATOR.
  583.  
  584. (define (generate/quotation-header environment-label free-ref-label n-sections)
  585.   (LAP (MOV L ,reg:environment (@PCR ,environment-label))
  586.        (MOVA B (@PCR ,*block-label*) (R 2))
  587.        (MOVA B (@PCR ,free-ref-label) (R 3))
  588.        ,@(load-rn n-sections 4)
  589.        #|
  590.        (JSB ,entry:compiler-link)
  591.        |#
  592.        ,@(invoke-interface-jsb code:compiler-link)
  593.        ,@(make-external-label (continuation-code-word false)
  594.                   (generate-label))))
  595.  
  596. (define (generate/remote-link code-block-label
  597.                   environment-offset
  598.                   free-ref-offset
  599.                   n-sections)
  600.   (LAP (BIC L ,mask-reference (@PCR ,code-block-label) (R 2))
  601.        (MOV L ,reg:environment
  602.         (@RO ,(datum-size environment-offset) 2 ,environment-offset))
  603.        ,@(add-constant/ea (INST-EA (R 2)) free-ref-offset (INST-EA (R 3)))
  604.        ,@(load-rn n-sections 4)
  605.        #|
  606.        (JSB ,entry:compiler-link)
  607.        |#
  608.        ,@(invoke-interface-jsb code:compiler-link)
  609.        ,@(make-external-label (continuation-code-word false)
  610.                   (generate-label))))
  611.  
  612. (define (generate/constants-block constants references assignments
  613.                   uuo-links global-links static-vars)
  614.   (let ((constant-info
  615.      (declare-constants 0 (transmogrifly uuo-links)
  616.        (declare-constants 1 references
  617.          (declare-constants 2 assignments
  618.            (declare-constants 3 (transmogrifly global-links)
  619.          (declare-constants false
  620.              (map (lambda (pair)
  621.                 (cons false (cdr pair)))
  622.               static-vars)
  623.            (declare-constants false constants
  624.              (cons false (LAP))))))))))
  625.     (let ((free-ref-label (car constant-info))
  626.       (constants-code (cdr constant-info))
  627.       (debugging-information-label (allocate-constant-label))
  628.       (environment-label (allocate-constant-label))
  629.       (n-sections
  630.        (+ (if (null? uuo-links) 0 1)
  631.           (if (null? references) 0 1)
  632.           (if (null? assignments) 0 1)
  633.           (if (null? global-links) 0 1))))
  634.       (values
  635.        (LAP ,@constants-code
  636.         ;; Place holder for the debugging info filename
  637.         (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
  638.         ;; Place holder for the load time environment if needed
  639.         (SCHEME-OBJECT ,environment-label
  640.                ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
  641.        environment-label
  642.        free-ref-label
  643.        n-sections))))
  644.  
  645. (define (declare-constants tag constants info)
  646.   (define (inner constants)
  647.     (if (null? constants)
  648.     (cdr info)
  649.     (let ((entry (car constants)))
  650.       (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
  651.            ,@(inner (cdr constants))))))
  652.   (if (and tag (not (null? constants)))
  653.       (let ((label (allocate-constant-label)))
  654.     (cons label
  655.           (inner
  656.            `((,(let ((datum (length constants)))
  657.              (if (> datum #xffff)
  658.              (error "datum too large" datum))
  659.              (+ (* tag #x10000) datum))
  660.           . ,label)
  661.          ,@constants))))
  662.       (cons (car info) (inner constants))))
  663.  
  664. ;; IMPORTANT:
  665. ;; frame-size and uuo-label are switched (with respect to the 68k
  666. ;; version) in order to preserve the arity in a constant position (the
  667. ;; Vax is little-endian).  The invocation rule for uuo-links has been
  668. ;; changed to take the extra 2 bytes into account.
  669. ;; Alternatively we could
  670. ;; make execute caches 3 words long, with the third containing the
  671. ;; frame size and the middle the second part of the instruction.
  672.  
  673. (define (transmogrifly uuos)
  674.   (define (inner name assoc)
  675.     (if (null? assoc)
  676.     (transmogrifly (cdr uuos))
  677.     (cons (cons (caar assoc)            ; frame-size
  678.             (cdar assoc))            ; uuo-label
  679.           (cons (cons name                ; variable name
  680.               (allocate-constant-label))    ; dummy label
  681.             (inner name (cdr assoc))))))
  682.   (if (null? uuos)
  683.       '()
  684.       (inner (caar uuos) (cdar uuos))))
  685.  
  686. ;;; Local Variables: ***
  687. ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
  688. ;;; End: ***
  689.