From: Guillermo J. Rozas Date: Thu, 30 Jan 1992 06:35:03 +0000 (+0000) Subject: More changes. X-Git-Tag: 20090517-FFI~9916 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c3fd834779ee0620d4fbe24141583062e4d3bb20;p=mit-scheme.git More changes. --- diff --git a/v7/src/compiler/machines/i386/machin.scm b/v7/src/compiler/machines/i386/machin.scm index 1efb79b18..e53dbdb07 100644 --- a/v7/src/compiler/machines/i386/machin.scm +++ b/v7/src/compiler/machines/i386/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/machin.scm,v 1.2 1992/01/23 22:47:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/machin.scm,v 1.3 1992/01/30 06:34:44 jinx Exp $ $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/machin.scm,v 4.26 1991/10/25 06:49:34 cph Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -173,8 +173,7 @@ MIT in each case. |# (define-integrable register-block/value-offset 2) (define-integrable register-block/environment-offset 3) (define-integrable register-block/dynamic-link-offset 4) ; compiler temp -;; ^ Could also use the closure registers, not needed for this port. -;; Need to check whether they are spuriously initialized or reset. +(define-integrable register-block/utility-arg4-offset 9) ; closure free ;;;; RTL Generator Interface diff --git a/v7/src/compiler/machines/i386/rules1.scm b/v7/src/compiler/machines/i386/rules1.scm index db2d7134d..fd52b7a5d 100644 --- a/v7/src/compiler/machines/i386/rules1.scm +++ b/v7/src/compiler/machines/i386/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.4 1992/01/28 21:23:13 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.5 1992/01/30 06:33:02 jinx Exp $ $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -109,7 +109,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n))) - (load-immediate n (target-register-reference target))) + (load-immediate (target-register-reference target) n)) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -120,19 +120,19 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label))) (load-pc-relative-address - target + (target-register-reference target) (rtl-procedure/external-label (label->object label)))) (define-rule statement (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label))) - (load-pc-relative-address target label)) + (load-pc-relative-address (target-register-reference target) label)) (define-rule statement ;; This is an intermediate rule -- not intended to produce code. (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:PROCEDURE (? label)))) - (load-pc-relative-address/typed target + (load-pc-relative-address/typed (target-register-reference target) type (rtl-procedure/external-label (label->object label)))) @@ -142,15 +142,18 @@ MIT in each case. |# (ASSIGN (REGISTER (? target)) (CONS-POINTER (MACHINE-CONSTANT (? type)) (ENTRY:CONTINUATION (? label)))) - (load-pc-relative-address/typed target type label)) + (load-pc-relative-address/typed (target-register-reference target) + type label)) (define-rule statement (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) - (load-pc-relative target (free-reference-label name))) + (load-pc-relative (target-register-reference target) + (free-reference-label name))) (define-rule statement (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name))) - (load-pc-relative target (free-assignment-label name))) + (load-pc-relative (target-register-reference target) + (free-assignment-label name))) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant)))) @@ -261,20 +264,7 @@ MIT in each case. |# (let ((target (indirect-byte-reference! address offset))) (LAP (MOV B ,target ,source))))) -;;;; Utilities specific to rules1 (others in lapgen) - -(define (assign-register->register target source) - (move-to-alias-register! source (register-type target) target) - (LAP)) - -(define (convert-object/constant->register target constant conversion) - (delete-dead-registers!) - (let ((target (target-register-reference target))) - (if (non-pointer-object? constant) - ;; Is this correct if conversion is object->address ? - (load-non-pointer target 0 (careful-object-datum constant)) - (LAP ,@(load-constant target constant) - ,@(conversion target))))) +;;;; Utilities specific to rules1 (define (load-displaced-register target source n) (if (zero? n) @@ -290,30 +280,12 @@ MIT in each case. |# n (+ (make-non-pointer-literal type 0) n)))) -(define (load-constant target obj) - (if (non-pointer-object? obj) - (load-non-pointer target (object-type obj) (careful-object-datum obj)) - (load-pc-relative target (free-constant-label obj)))) - -(define (load-pc-relative target label) - (with-pc-relative-address - (lambda (pc-label pc-register) - (let ((target (target-register-reference target))) - (LAP (MOV W ,target (@RO ,pc-register (- ,label ,pc-label)))))))) - -(define (load-pc-relative-address target label) - (with-pc-relative-address - (lambda (pc-label pc-register) - (let ((target (target-register-reference target))) - (LAP (LEA ,target (@RO ,pc-register (- ,label ,pc-label)))))))) - (define (load-pc-relative-address/typed target type label) (with-pc-relative-address (lambda (pc-label pc-register) - (let ((target (target-register-reference target))) - (LAP (LEA ,target (@RO ,pc-register - (+ ,(make-non-pointer-literal type 0) - (- ,label ,pc-label))))))))) + (LAP (LEA ,target (@RO ,pc-register + (+ ,(make-non-pointer-literal type 0) + (- ,label ,pc-label)))))))) (define (load-char-into-register type source target) (let ((target (target-register-reference target))) diff --git a/v7/src/compiler/machines/i386/rules2.scm b/v7/src/compiler/machines/i386/rules2.scm index 9add59217..65fdccba0 100644 --- a/v7/src/compiler/machines/i386/rules2.scm +++ b/v7/src/compiler/machines/i386/rules2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules2.scm,v 1.1 1992/01/28 05:09:19 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules2.scm,v 1.2 1992/01/30 06:32:47 jinx Exp $ $MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -44,19 +44,6 @@ MIT in each case. |# (lambda (label) (LAP (JNE (@PCR ,label)))))) -(define (compare/register*register reg1 reg2) - (cond ((register-alias reg1 'GENERAL) - => - (lambda (alias) - (LAP (CMP W ,(register-reference alias) ,(any-reference reg2))))) - ((register-alias reg2 'GENERAL) - => - (lambda (alias) - (LAP (CMP W ,(any-reference reg1) ,(register-reference alias))))) - (else - (LAP (CMP W ,(source-register-reference reg1) - ,(any-reference reg2)))))) - (define-rule predicate (TYPE-TEST (REGISTER (? register)) (? type)) (set-equal-branches!) diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm index 53ce9ed4c..44259fbc5 100644 --- a/v7/src/compiler/machines/i386/rules3.scm +++ b/v7/src/compiler/machines/i386/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules3.scm,v 1.2 1992/01/29 04:31:09 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules3.scm,v 1.3 1992/01/30 06:32:33 jinx Exp $ $MC68020-Header: /scheme/compiler/bobcat/RCS/rules3.scm,v 4.31 1991/05/28 19:14:55 jinx Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -128,11 +128,7 @@ MIT in each case. |# ,@set-address ,@(clear-map!) (MOV W (R ,ebx) (& ,frame-size)) - ,@(invoke-interface code:compiler-cache-reference-apply)))) - -(define (object->machine-register! object mreg) - (require-register! mreg) - (load-constant (INST-EA (R ,mreg)) object)) + ,@(invoke-interface code:compiler-cache-reference-apply)))) (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) @@ -168,7 +164,7 @@ MIT in each case. |# (JMP ,entry:compiler-primitive-lexpr-apply))) (else ;; Unknown primitive arity. Go through apply. - (LAP ,@(get-code) + (LAP ,@get-code ,@(clear-map!) (MOV W (R ,edx) (& ,frame-size)) ,@(invoke-interface code:compiler-apply))))))) @@ -346,8 +342,6 @@ MIT in each case. |# ;;;; Procedure headers -;; **** Here **** - ;;; The following calls MUST appear as the first thing at the entry ;;; point of a procedure. They assume that the register map is clear ;;; and that no register contains anything of value. @@ -365,10 +359,10 @@ MIT in each case. |# (define-integrable (simple-procedure-header code-word label entry) (let ((gc-label (generate-label))) (LAP (LABEL ,gc-label) - (JSR ,entry) + (CALL ,entry) ,@(make-external-label code-word label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE B (@PCR ,gc-label))))) + (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop) + (JGE (@PCR ,gc-label))))) (define-rule statement (CONTINUATION-ENTRY (? internal-label)) @@ -389,10 +383,10 @@ MIT in each case. |# (LAP (ENTRY-POINT ,external-label) (EQUATE ,external-label ,internal-label) (LABEL ,gc-label) - ,@(invoke-interface-jsr code:compiler-interrupt-ic-procedure) + ,@(invoke-interface/call code:compiler-interrupt-ic-procedure) ,@(make-external-label expression-code-word internal-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE B (@PCR ,gc-label)))))) + (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop) + (JGE (@PCR ,gc-label)))))) (define-rule statement (OPEN-PROCEDURE-HEADER (? internal-label)) @@ -415,40 +409,7 @@ MIT in each case. |# ;;;; 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) +(define (generate/closure-header internal-label nentries entry) nentries ; ignored (let ((rtl-proc (label->object internal-label))) (let ((gc-label (generate-label)) @@ -460,206 +421,83 @@ long-word aligned and there is no need for shuffling. internal-label entry:compiler-interrupt-procedure)) (LAP (LABEL ,gc-label) - ,@(let ((distance (* 10 entry))) - (cond ((zero? distance) - (LAP)) - ((< distance 128) - (LAP (MOVEQ (& ,distance) (D 0)) - (ADD L (D 0) (@A 7)))) - (else - (LAP (ADD L (& ,distance) (@A 7)))))) - (JMP ,entry:compiler-interrupt-closure) - ,@(make-external-label internal-entry-code-word - external-label) - (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 (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) - ,@(load-non-pointer (ucode-type manifest-closure) - (+ 3 size) - (INST-EA (@A+ 5))) - (MOV UL - (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) - (@A+ 5)) - (MOV L (A 5) ,target) - (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) + ,@(if (zero? entry) + (LAP) + (LAP (ADD W (@R ,esp) (& ,(* 10 entry))))) (JMP ,entry:compiler-interrupt-closure) ,@(make-external-label internal-entry-code-word external-label) - (ADD UL (& ,(MC68040/make-magic-closure-constant entry)) (@A 7)) + (ADD W (@R ,esp) + (&U ,(generate/make-magic-closure-constant entry))) (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 (@A+ ,an))) - (MOV UL - (& ,(+ (* (make-procedure-code-word min max) #x10000) 8)) - (@A+ ,an)) - (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 ,@(load-non-pointer (ucode-type manifest-closure) - (+ size 1 - (* nentries MC68040/closure-entry-size)) - (INST-EA (@A+ ,atarget))) - (MOV UL (& ,(* nentries #x10000)) (@A+ ,atarget)) - (MOV L (A ,atarget) (A ,atmp1)) - (ADDQ L (& 4) (A ,atarget)) - ,@(store-entries 12 entries)))))) - -;;;; Utilities for MC68040 closures. + (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop) + (JGE (@PCR ,gc-label))))))) -(define (MC68040/make-magic-closure-constant entry) - entry ; ignored +(define (generate/make-magic-closure-constant entry) (- (make-non-pointer-literal (ucode-type compiled-entry) 0) - 6)) - -;; In what follows, entry:compiler-allocate-closure gets its parameter in d0 -;; and returns its value in a0. - -(define (MC68040/allocate-closure size) - (LAP ,(load-dnl size 0) - (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) - (rtl-target:=machine-register! target a0) - (let ((total-size (+ 1 - (if (= nentries 1) 0 1) - (* MC68040/closure-entry-size nentries) - size)) - (label (generate-label))) - (LAP - ;; Optional code: - (MOV L ,reg:closure-free (A 0)) - ,@(ea+=constant reg:closure-free (* 4 total-size)) - ,@(ea+=constant reg:closure-space (- 0 total-size)) - (B GE B (@PCR ,label)) - ;; End of optional code. - ,@(MC68040/allocate-closure total-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)) + (+ (* entry 10) 5))) + +(define (make-closure-longword code-word pc-offset) + (+ code-word (* #x20000 pc-offset))) + +(define (make-closure-code-longword frame/min frame/max pc-offset) + (make-closure-longword (make-procedure-code-word frame/min frame/max) + pc-offset)) + +(define (generate/cons-closure target procedure-label min max size) + (let* ((target (target-register-reference)) + (temporary (temporary-register-reference))) + (LAP ,@(load-pc-relative-address + temporary + `(- ,(rtl-procedure/external-label (label->object procedure-label)) + 5)) + (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal (ucode-type manifest-closure) + (+ 3 size)))) + (MOV W (@RO ,regnum:free-pointer 4) + (&U ,(make-closure-code-longword min max 8))) + (LEA ,target (@RO ,regnum:fre-pointer 8)) + (MOV B (@RO ,regnum:free-pointer 8) (&U #xe8)) ; (CALL (@PCR )) + (SUB W ,temporary ,target) + (MOV L (@RO ,regnum:free-pointer 9) ,temporary) ; displacement + (ADD W (R ,regnum:free-pointer) (& ,(* 4 (+ 4 size))))))) + +(define (generate/cons-multiclosure target nentries size entries) + (let* ((target (target-register-reference)) + (temp (temporary-register-reference))) + (with-pc-relative-address + (lambda (pc-label pc-reg) + (define (generate-entries entries offset) + (let ((entry (car entries)) + (rest (cdr entries))) + (LAP (MOV W (@RO ,regnum:free-pointer -9) + (&U ,(make-closure-code-longword (cadr entry) + (caddr entry) + offset))) + (MOV B (@RO ,regnum:free-pointer -5) (&U #xe8)) + (LEA ,temp (@RO ,pc-reg (- ,(rtl-procedure/external-label + (label->object (car entry))) + ,pc-label))) + (SUB W ,temp (R ,regnum:free-pointer)) + (MOV W (@RO ,regnum:free-pointer -4) ,temp) + ,@(if (null? rest) + (LAP) + (LAP (ADD W (R ,regnum:free-pointer) 10) + ,@(generate-entries rest (+ 10 offset))))))) + + (LAP (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal + (ucode-type manifest-closure) + (+ size + (quotient (+ 3 (* 5 nentries)) + 2))))) + (MOV W (@RO ,regnum:free-pointer 4) + (&U ,(make-closure-longword nentries 0))) + (LEA ,target (@RO ,regnum:free-pointer 12)) + (ADD W (R ,regnum:free-pointer) (& 17)) + ,@(generate-entries entries 12) + (ADD W (R ,regnum:free-pointer) + (& ,(+ (* 4 size) (if (odd? nentries) 3 1))))))))) ;;;; The rules themselves. @@ -678,12 +516,12 @@ long-word aligned and there is no need for shuffling. (CONS-MULTICLOSURE (? nentries) (? size) (? entries))) (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))))) + (let ((target (target-register-reference))) + (LAP (MOV W ,target (R ,regnum:free-pointer)) + (MOV W (@R ,regnum:free-pointer) + (&U ,(make-non-pointer-literal (ucode-type manifest-vector) + size))) + (ADD W (R ,regnum:free-pointer) (& (* 4 (1+ size))))))) ((1) (let ((entry (vector-ref entries 0))) (generate/cons-closure target @@ -692,28 +530,12 @@ long-word aligned and there is no need for shuffling. (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. +;; **** here **** + (define (generate/quotation-header environment-label free-ref-label n-sections) (LAP (LEA (@PCR ,environment-label) (A 0)) (MOV L ,reg:environment (@A 0)) diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm index 22e07ca11..5222c88ac 100644 --- a/v7/src/compiler/machines/i386/rulfix.scm +++ b/v7/src/compiler/machines/i386/rulfix.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.7 1992/01/28 04:58:53 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.8 1992/01/30 06:34:32 jinx Exp $ $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -206,8 +206,8 @@ MIT in each case. |# (LAP (CMP W ,(source-indirect-reference! address offset) (& ,(fixnum-object->fixnum-word constant))))) -;; This assumes that the last instruction sets the condition code bits -;; correctly. +;; This assumes that the immediately preceding instruction sets the +;; condition code bits correctly. (define-rule predicate (OVERFLOW-TEST) @@ -296,55 +296,6 @@ MIT in each case. |# source1 source2)) -(define (two-arg-register-operation - operate commutative? - target-type source-reference alternate-source-reference - target source1 source2) - (let* ((worst-case - (lambda (target source1 source2) - (LAP ,@(if (eq? target-type 'FLOAT) - (load-float-register source1 target) - (LAP (MOV W ,target ,source1))) - ,@(operate target source2)))) - (new-target-alias! - (lambda () - (let ((source1 (alternate-source-reference source1)) - (source2 (source-reference source2))) - (delete-dead-registers!) - (worst-case (reference-target-alias! target target-type) - source1 - source2))))) - (cond ((pseudo-register? target) - (reuse-pseudo-register-alias - source1 target-type - (lambda (alias) - (let ((source2 (if (= source1 source2) - (register-reference alias) - (source-reference source2)))) - (delete-register! alias) - (delete-dead-registers!) - (add-pseudo-register-alias! target alias) - (operate (register-reference alias) source2))) - (lambda () - (if commutative? - (reuse-pseudo-register-alias - source2 target-type - (lambda (alias2) - (let ((source1 (source-reference source1))) - (delete-register! alias2) - (delete-dead-registers!) - (add-pseudo-register-alias! target alias2) - (operate (register-reference alias2) source1))) - new-target-alias!) - (new-target-alias!))))) - ((not (eq? target-type (register-type target))) - (error "two-arg-register-operation: Wrong type register" - target target-type)) - (else - (worst-case (register-reference target) - (alternate-source-reference source1) - (source-reference source2)))))) - (define (fixnum-2-args/register*constant operator target source constant) (fixnum-1-arg target source @@ -635,11 +586,4 @@ MIT in each case. |# (lambda (label) (LAP (JLE (@PCR ,label)))))) (else - (error "FIXNUM-BRANCH!: Unknown predicate" predicate)))) - -(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))) \ No newline at end of file + (error "FIXNUM-BRANCH!: Unknown predicate" predicate)))) \ No newline at end of file diff --git a/v7/src/microcode/cmpintmd/i386.h b/v7/src/microcode/cmpintmd/i386.h index e7ebc0705..931ce72ee 100644 --- a/v7/src/microcode/cmpintmd/i386.h +++ b/v7/src/microcode/cmpintmd/i386.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/i386.h,v 1.2 1992/01/22 04:19:13 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/i386.h,v 1.3 1992/01/30 06:35:03 jinx Exp $ Copyright (c) 1992 Massachusetts Institute of Technology @@ -183,18 +183,18 @@ entry 0 CMP EDI,(ESI) 0x39 0x3e - GC & interrupt check at closure entry: -gc_lab -7-?? JMP n(ESI) 0xFF 0x66 n-byte - -4-?? ADD (ESP),&offset +gc_lab -11 ADD (ESP),&offset 0x83 0x04 0x24 offset-byte + -7 JMP n(ESI) 0xFF 0x66 n-byte -4 -2 entry 0 ADD (ESP),&magic 0x81 0x04 0x24 magic-longword 7 CMP EDI,(ESI) 0x39 0x3e - 9 JAE gc_lab 0x73 ?? + 9 JAE gc_lab 0x73 0xea (= -22) 11 The magic value depends on the closure because of canonicalization. -The ADD instruction at offset -4-?? is not present for the 0th closure +The ADD instruction at offset -11 is not present for the 0th closure entry, since it is the canonical entry point. Its format depends on the value of offset, since the sign-extending forms often suffice.