From 4db2b403ad5148ad78416a8a667bc1f788e1b3fb Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sun, 24 Mar 1991 23:53:41 +0000 Subject: [PATCH] Conditionalization and changes for 68040 format closures. --- v7/src/compiler/machines/bobcat/lapgen.scm | 41 ++- v7/src/compiler/machines/bobcat/machin.scm | 142 ++++++-- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/machines/bobcat/rules3.scm | 333 ++++++++++++++---- 4 files changed, 398 insertions(+), 122 deletions(-) diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 1effc6b55..4a20032b2 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.39 1991/01/30 22:48:01 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.40 1991/03/24 23:53:14 jinx Exp $ -Copyright (c) 1988, 1989, 1990, 1991 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -176,19 +176,24 @@ MIT in each case. |# (INST (TST W (D ,d))) (INST (CMPI W (& ,n) (D ,d))))) +(define (ea+=constant ea c) + (cond ((zero? c) + (LAP)) + ((<= 1 c 8) + (LAP (ADDQ L (& ,c) ,ea))) + ((>= -1 c -8) + (LAP (SUBQ L (& (- 0 ,c)) ,ea))) + ((eq? (lap:ea-keyword ea) 'A) + (LAP (LEA (@AO ,(lap:ea-operand-1 ea) ,c) ,ea))) + ((<= -128 c 127) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOVEQ (& ,c) ,temp) + (ADD L ,temp ,ea)))) + (else + (LAP (ADD L (& ,c) ,ea))))) + (define (increment-machine-register register n) - (let ((target (register-reference register))) - (cond ((zero? n) (LAP)) - ((<= 1 n 8) (LAP (ADDQ L (& ,n) ,target))) - ((>= -1 n -8) (LAP (SUBQ L (& ,n) ,target))) - ((not (< register 8)) - (LAP (LEA (@AO ,(- register 8) ,n) ,target))) - ((<= -128 n 127) - (let ((temp (reference-temporary-register! 'DATA))) - (LAP (MOVEQ (& ,n) ,temp) - (ADD L ,temp ,target)))) - (else - (LAP (ADD L (& ,n) ,target)))))) + (ea+=constant (register-reference register) n)) (define (load-constant constant target) (if (non-pointer-object? constant) @@ -257,7 +262,7 @@ MIT in each case. |# (zero? datum) (effective-address/data&alterable? effective-address)) (INST (TST L ,effective-address)) - (INST (CMPI L + (INST (CMPI UL (& ,(make-non-pointer-literal type datum)) ,effective-address)))) @@ -1070,8 +1075,9 @@ MIT in each case. |# (define-integrable reg:compiled-memtop (INST-EA (@A 6))) (define-integrable reg:environment (INST-EA (@AO 6 #x000C))) -(define-integrable reg:temp (INST-EA (@AO 6 #x0010))) (define-integrable reg:lexpr-primitive-arity (INST-EA (@AO 6 #x001C))) +(define-integrable reg:closure-free (INST-EA (@AO 6 #x0024))) +(define-integrable reg:closure-space (INST-EA (@AO 6 #X0028))) (let-syntax ((define-codes (macro (start . names) @@ -1142,6 +1148,9 @@ MIT in each case. |# zero? positive? negative? + primitive-error + allocate-closure ; This doesn't have a code: counterpart. + closure-hook ; This doesn't have a code: counterpart. )) (define-integrable (invoke-interface code) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 0c311c004..d548ec2a7 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.23 1991/02/05 03:50:50 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.24 1991/03/24 23:53:28 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,7 +32,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Machine Model for 68020 +;;;; Machine Model for the Motorola MC68K family ;;; package: (compiler) (declare (usual-integrations)) @@ -84,45 +84,135 @@ MIT in each case. |# (define-integrable (stack->memory-offset offset) offset) (define-integrable ic-block-first-parameter-offset 2) - -;; This must return a word based offset. -;; On the 68k, to save space, entries can be at 2 mod 4 addresses, -;; which makes this impossible if the closure object used for -;; referencing points to arbitrary entries. Instead, all closure -;; entry points bump to the canonical entry point, which is always -;; longword aligned. -;; On other machines (word aligned), it may be easier to bump back -;; to each entry point, and the entry number `entry' would be part -;; of the computation. - -(define (closure-first-offset nentries entry) + +;;;; Closure format + +;; There are two versions of the closure format. +;; The MC68040 format can be used by all processors in the family, +;; irrelevant of cache operation, but is slower. +;; The MC68020 format can be used by all processors except the MC68040 +;; unless its data cache is operating in write-through mode (instead +;; of store-in or copyback). +;; MC68020-format closure entry points are not long-word aligned, thus +;; they are canonicalized to the first entry point at call time. +;; MC68040-format closure entry points are long-word aligned, and +;; there is no canonicalization. + +;; When using the MC68020 format, to save space, entries can be at 2 +;; mod 4 addresses, thus if we used the entry points for environments, +;; the requirement that all environment pointers be long-word aligned +;; would be violated. Instead, all closure entry points are bumped to +;; the canonical entry point, which is always long-word aligned. + +#| + An MC68020-format closure entry: + DC.W , + JSR #target + + Entries are not padded to long-word length. The JSR-absolute + instruction is 6 bytes long, so the total size per entry is + 10 bytes. +|# + +(define (MC68020/closure-first-offset nentries entry) entry ; ignored (if (zero? nentries) 1 (quotient (+ (+ 3 1) (* 5 (- nentries 1))) 2))) -;; This is from the start of the complete closure object, -;; viewed as a vector, and including the header word. - -(define (closure-object-first-offset nentries) +(define (MC68020/closure-object-first-offset nentries) (case nentries ((0) 1) ((1) 4) (else (quotient (+ 5 (* 5 nentries)) 2)))) -;; Bump from one entry point to another. - -(define (closure-entry-distance nentries entry entry*) +(define (MC68020/closure-entry-distance nentries entry entry*) nentries ; ignored (* 10 (- entry* entry))) -;; Bump to the canonical entry point. +;; When using the MC68020 format, bump to the canonical entry point. + +(define (MC68020/closure-environment-adjustment nentries entry) + (declare (integrate-operator MC68020/closure-entry-distance)) + (MC68020/closure-entry-distance nentries entry 0)) + +(define-integrable MC68040/closure-entry-size + #| + Long-words in a single closure entry: + DC.W , + JSR closure_hook(a6) + DC.L target + |# + 3) + +(define (MC68040/closure-first-offset nentries entry) + entry ; ignored + (if (zero? nentries) + 1 + (- (* MC68040/closure-entry-size (- nentries entry)) 1))) -(define (closure-environment-adjustment nentries entry) - (declare (integrate-operator closure-entry-distance)) - (closure-entry-distance nentries entry 0)) +(define (MC68040/closure-object-first-offset nentries) + (case nentries + ((0) + ;; Vector header only + 1) + ((1) + ;; Manifest closure header followed by single entry point. + (1+ MC68040/closure-entry-size)) + (else + ;; Manifest closure header, number of entries, then entries. + (+ 1 1 (* MC68040/closure-entry-size nentries))))) +(define (MC68040/closure-entry-distance nentries entry entry*) + nentries ; ignored + (* (* MC68040/closure-entry-size 4) (- entry* entry))) + +;; With the 68040 layout, this is the entry point itself, no bumping. + +(define (MC68040/closure-environment-adjustment nentries entry) + nentries entry ; ignored + 0) + +;;;; Closure choices + +(define-integrable MC68K/closure-format 'MC68020) ; or MC68040 + +(let-syntax ((define/format-dependent + (macro (name) + `(define ,name + (case MC68K/closure-format + ((MC68020) + ,(intern + (string-append "MC68020/" (symbol->string name)))) + ((MC68040) + ,(intern + (string-append "MC68040/" (symbol->string name)))) + (else + (error "Unknown closure format" closure-format))))))) + +;; Given: the number of entry points in a closure, and a particular +;; entry point number, compute the distance from that entry point to +;; the first variable slot in the closure object (in long words). + +(define/format-dependent closure-first-offset) + +;; Like the above, but from the start of the complete closure object, +;; viewed as a vector, and including the header word. + +(define/format-dependent closure-object-first-offset) + +;; Bump distance in bytes from one entry point to another. +;; Used for invocation purposes. + +(define/format-dependent closure-entry-distance) + +;; Bump distance in bytes from one entry point to the entry point used +;; for variable-reference purposes. + +(define/format-dependent closure-environment-adjustment) +) + (define-integrable d0 0) (define-integrable d1 1) (define-integrable d2 2) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index e2e54a92b..91f2efdc2 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.80 1991/03/06 00:58:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.81 1991/03/24 23:52:47 jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (Motorola MC68020)" 4 80 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 81 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 0f25d875c..a2d28ae78 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.28 1991/02/12 04:48:14 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.29 1991/03/24 23:53:41 jinx Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -416,17 +416,42 @@ MIT in each case. |# internal-label entry:compiler-interrupt-procedure))) -;;;; Closures. These two statements are intertwined: -;;; Note: If the closure is a multiclosure, the closure object on the -;;; stack corresponds to the first (official) entry point. -;;; Thus on entry and interrupt it must be bumped around. - -(define (make-magic-closure-constant entry) - (- (make-non-pointer-literal (ucode-type compiled-entry) 0) - (+ (* entry 10) 6))) - -(define-rule statement - (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) +;;;; Closures: + +#| + +The closure headers and closure consing code are heavily interdependent. + +There are two different versions of the rules, depending on the closure format: + +The 68020 format can be used when there is no problem with +inconsistency between the processor's I-cache and the D-cache. In +this format, closures contain an absolute JSR instruction, stored by +the closure consing code. The absolute address is the address of the +labelled word in the closure header. Closures are allocated directly +from the Scheme heap, and the instructions are stored by the +cons-closure code. Multiple entry-point closures have their entry +points tightly packed, and since the JSR instruction is 6 bytes long, +entries are not, in general at longword boundaries. Because the rest +of the compiler requires the closure object on the stack to be +longword aligned, these objects always correspond to the first +(canonical) entry point of a closure with multiple entry points. Thus +there is a little shuffling around to maintain this, and the identity +of the object. + +The 68040 format should be used when the D-cache is in copyback mode +(ie. storing to an address may not be seen by the I-cache even if +there was no previous association). In this format, closures contain +a JSR instruction to a fixed piece of code, and the actual entry point +is stored folling this fixed instruction. The garbage collector can +change this to an absolute JSR instruction. Closures are allocated +from a pool, renewed by out of line code that also pre-stores the +instructions and synchronizes the caches. Entry points are always +long-word aligned and there is no need for shuffling. + +|# + +(define (MC68020/closure-header internal-label nentries entry) nentries ; ignored (let ((rtl-proc (label->object internal-label))) (let ((gc-label (generate-label)) @@ -449,20 +474,14 @@ MIT in each case. |# (JMP ,entry:compiler-interrupt-closure) ,@(make-external-label internal-entry-code-word external-label) - (ADD UL (& ,(make-magic-closure-constant entry)) (@A 7)) + (ADD UL (& ,(MC68020/make-magic-closure-constant entry)) (@A 7)) (LABEL ,internal-label) (CMP L ,reg:compiled-memtop (A 5)) (B GE B (@PCR ,gc-label))))))) - -(define-rule statement - (ASSIGN (REGISTER (? target)) - (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) - (? min) (? max) (? size))) - (generate/cons-closure (reference-target-alias! target 'ADDRESS) - false procedure-label min max size)) - -(define (generate/cons-closure target type procedure-label min max size) - (let ((temporary (reference-temporary-register! 'ADDRESS))) + +(define (MC68020/cons-closure target procedure-label min max size) + (let* ((target (reference-target-alias! target 'ADDRESS)) + (temporary (reference-temporary-register! 'ADDRESS))) (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object procedure-label))) ,temporary) @@ -473,72 +492,230 @@ MIT in each case. |# (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) (@A+ 5)) (MOV L (A 5) ,target) - ,@(if type - (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)) - (LAP)) (MOV UW (& #x4eb9) (@A+ 5)) ; (JSR (L )) (MOV L ,temporary (@A+ 5)) (CLR W (@A+ 5)) ,@(increment-machine-register 13 (* 4 size))))) + +(define (MC68020/cons-multiclosure target nentries size entries) + (let ((target (reference-target-alias! target 'ADDRESS))) + (let ((total-size (+ size + (quotient (+ 3 (* 5 nentries)) + 2))) + (temp1 (reference-temporary-register! 'ADDRESS)) + (temp2 (reference-temporary-register! 'DATA))) + + (define (generate-entries entries offset first?) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry) + (caddr entry)) + #x10000) + offset)) + (@A+ 5)) + ,@(if first? + (LAP (MOV L (A 5) ,target)) + (LAP)) + (LEA (@PCR ,(rtl-procedure/external-label + (label->object (car entry)))) + ,temp1) + (MOV W ,temp2 (@A+ 5)) ; (JSR (L )) + (MOV L ,temp1 (@A+ 5)) + ,@(generate-entries (cdr entries) + (+ 10 offset) + false))))) + + (LAP ,@(load-non-pointer (ucode-type manifest-closure) + total-size + (INST-EA (@A+ 5))) + (MOV UL (& ,(* nentries #x10000)) (@A+ 5)) + (MOV UW (& #x4eb9) ,temp2) + ,@(generate-entries entries 12 true) + ,@(if (odd? nentries) + (LAP (CLR W (@A+ 5))) + (LAP)) + ,@(increment-machine-register 13 (* 4 size)))))) + +(define (MC68020/make-magic-closure-constant entry) + (- (make-non-pointer-literal (ucode-type compiled-entry) 0) + (+ (* entry 10) 6))) +(define (MC68040/closure-header internal-label nentries entry) + nentries entry ; ignored + (let ((rtl-proc (label->object internal-label))) + (let ((gc-label (generate-label)) + (external-label (rtl-procedure/external-label rtl-proc))) + (if (zero? nentries) + (LAP (EQUATE ,external-label ,internal-label) + ,@(simple-procedure-header + (internal-procedure-code-word rtl-proc) + internal-label + entry:compiler-interrupt-procedure)) + (LAP (LABEL ,gc-label) + (JMP ,entry:compiler-interrupt-closure) + ,@(make-external-label internal-entry-code-word + external-label) + (ADD UL (& ,(MC68040/make-magic-closure-constant entry)) (@A 7)) + (LABEL ,internal-label) + (CMP L ,reg:compiled-memtop (A 5)) + (B GE B (@PCR ,gc-label))))))) + +(define (MC68040/cons-closure target procedure-label min max size) + (MC68040/with-allocated-closure target 1 size + (lambda (an) + (let ((temp (reference-temporary-register! 'ADDRESS))) + (LAP ,@(load-non-pointer (ucode-type manifest-closure) + (+ size MC68040/closure-entry-size) + (INST-EA (@AO ,an -8))) + (MOV UL + (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) + (@AO ,an -4)) + (LEA (@PCR ,(rtl-procedure/external-label + (label->object procedure-label))) + ,temp) + (MOV L ,temp (@AO ,an 4))))))) + +(define (MC68040/cons-multiclosure target nentries size entries) + (MC68040/with-allocated-closure target nentries size + (lambda (atarget) + (let* ((atmp1 (areg->an (allocate-temporary-register! 'ADDRESS))) + (atmp2 (areg->an (allocate-temporary-register! 'ADDRESS)))) + (define (store-entries offset entries) + (if (null? entries) + (LAP) + (let ((entry (car entries))) + (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry) + (caddr entry)) + #x10000) + offset)) + (@A+ ,atmp1)) + (ADDQ L (& 4) (A ,atmp1)) ; bump over JSR instr. + (LEA (@PCR ,(rtl-procedure/external-label + (label->object (car entry)))) + (A ,atmp2)) + (MOV L (A ,atmp2) (@A+ ,atmp1)) + ,@(store-entries (+ 12 offset) (cdr entries)))))) + + (LAP (LEA (@AO ,atarget -12) (A ,atmp1)) + ,@(load-non-pointer (ucode-type manifest-closure) + (+ size 1 + (* nentries MC68040/closure-entry-size)) + (INST-EA (@A+ ,atmp1))) + (MOV UL (& ,(* nentries #x10000)) (@A+ ,atmp1)) + ,@(store-entries 12 entries)))))) + +;;;; Utilities for MC68040 closures. + +(define (MC68040/make-magic-closure-constant entry) + entry ; ignored + (- (make-non-pointer-literal (ucode-type compiled-entry) 0) + 6)) + +;; In what follows, entry:compiler-allocate-closure gets its parameters in d0 +;; and d1, and returns its value in a0. + +(define (MC68040/allocate-closure nentries size) + (LAP ,(load-dnl nentries 0) + ,(load-dnl size 1) + (JSR ,entry:compiler-allocate-closure))) + +;; If this issues too much code, the optional code can be eliminated at +;; some performace penalty in speed. + +(define (MC68040/with-allocated-closure target nentries size recvr) + (require-register! d0) + (require-register! d1) + (rtl-target:=machine-register! target a0) + (let ((compare (+ size (-1+ (* MC68040/closure-entry-size nentries)))) + (delta (* MC68040/closure-entry-size + (+ (1+ nentries) + (quotient (+ size 1) + MC68040/closure-entry-size)))) + (label (generate-label))) + (LAP + ;; Optional code: + (MOV L ,reg:closure-free (A 0)) + ,@(ea+=constant reg:closure-free (* 4 delta)) + ,@(ea+=constant reg:closure-space (- 0 delta)) + (CMPI L (& ,(- compare delta)) ,reg:closure-space) + (B GE B (@PCR ,label)) + ;; End of optional code. + ,@(MC68040/allocate-closure nentries size) + (LABEL ,label) + ,@(recvr 0)))) + +(define (rtl-target:=machine-register! rtl-reg machine-reg) + (if (machine-register? rtl-reg) + (begin + (require-register! machine-reg) + (if (not (= rtl-reg machine-reg)) + (suffix-instructions! + (register->register-transfer machine-reg rtl-reg)))) + (begin + (delete-register! rtl-reg) + (flush-register! machine-reg) + (add-pseudo-register-alias! rtl-reg machine-reg)))) + +(define (require-register! machine-reg) + (flush-register! machine-reg) + (need-register! machine-reg)) + +(define-integrable (flush-register! machine-reg) + (prefix-instructions! (clear-registers! machine-reg))) + +(define-integrable (areg->an areg) + (- areg 8)) + +;;;; The rules themselves. + +(define-rule statement + (CLOSURE-HEADER (? internal-label) (? nentries) (? entry)) + (generate/closure-header internal-label nentries entry)) + +(define-rule statement + (ASSIGN (REGISTER (? target)) + (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label)) + (? min) (? max) (? size))) + (generate/cons-closure target procedure-label min max size)) + (define-rule statement (ASSIGN (REGISTER (? target)) (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) - (let ((target (reference-target-alias! target 'ADDRESS))) - (case nentries - ((0) + (case nentries + ((0) + (let ((target (reference-target-alias! target 'ADDRESS))) (LAP (MOV L (A 5) ,target) ,@(load-non-pointer (ucode-type manifest-vector) size (INST-EA (@A+ 5))) - ,@(increment-machine-register 13 (* 4 size)))) - ((1) - (let ((entry (vector-ref entries 0))) - (generate/cons-closure target false - (car entry) (cadr entry) (caddr entry) - size))) - (else - (generate/cons-multiclosure target nentries size - (vector->list entries)))))) - -(define (generate/cons-multiclosure target nentries size entries) - (let ((total-size (+ size - (quotient (+ 3 (* 5 nentries)) - 2))) - (temp1 (reference-temporary-register! 'ADDRESS)) - (temp2 (reference-temporary-register! 'DATA))) - - (define (generate-entries entries offset first?) - (if (null? entries) - (LAP) - (let ((entry (car entries))) - (LAP (MOV UL (& ,(+ (* (make-procedure-code-word (cadr entry) - (caddr entry)) - #x10000) - offset)) - (@A+ 5)) - ,@(if first? - (LAP (MOV L (A 5) ,target)) - (LAP)) - (LEA (@PCR ,(rtl-procedure/external-label - (label->object (car entry)))) - ,temp1) - (MOV W ,temp2 (@A+ 5)) ; (JSR (L )) - (MOV L ,temp1 (@A+ 5)) - ,@(generate-entries (cdr entries) - (+ 10 offset) - false))))) - - (LAP ,@(load-non-pointer (ucode-type manifest-closure) - total-size - (INST-EA (@A+ 5))) - (MOV UL (& ,(* nentries #x10000)) (@A+ 5)) - (MOV UW (& #x4eb9) ,temp2) - ,@(generate-entries entries 12 true) - ,@(if (odd? nentries) - (LAP (CLR W (@A+ 5))) - (LAP)) - ,@(increment-machine-register 13 (* 4 size))))) + ,@(increment-machine-register 13 (* 4 size))))) + ((1) + (let ((entry (vector-ref entries 0))) + (generate/cons-closure target + (car entry) (cadr entry) (caddr entry) + size))) + (else + (generate/cons-multiclosure target nentries size + (vector->list entries))))) + +(let-syntax ((define/format-dependent + (macro (name1 name2) + `(define ,name1 + (case MC68K/closure-format + ((MC68020) + ,(intern + (string-append "MC68020/" (symbol->string name2)))) + ((MC68040) + ,(intern + (string-append "MC68040/" (symbol->string name2)))) + (else + (error "Unknown closure format" closure-format))))))) + +(define/format-dependent generate/closure-header closure-header) +(define/format-dependent generate/cons-closure cons-closure) +(define/format-dependent generate/cons-multiclosure cons-multiclosure) +) ;;;; Entry Header ;;; This is invoked by the top level of the LAP generator. -- 2.25.1