From 52a915c96fdcc9724e9b947e961e12cfa26c925d Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Thu, 6 Feb 1992 05:09:03 +0000
Subject: [PATCH] More changes.

---
 v7/src/compiler/machines/i386/lapgen.scm | 601 +----------------------
 1 file changed, 21 insertions(+), 580 deletions(-)

diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm
index d46df9db3..e86d994e0 100644
--- a/v7/src/compiler/machines/i386/lapgen.scm
+++ b/v7/src/compiler/machines/i386/lapgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.4 1992/02/05 17:21:48 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.5 1992/02/06 05:09:03 jinx Exp $
 $MC68020-Header: /scheme/compiler/bobcat/RCS/lapgen.scm,v 4.42 1991/05/28 19:14:26 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -248,23 +248,25 @@ MIT in each case. |#
       (LAP (LEA ,target (@RO ,pc-register (- ,label-expr ,pc-label)))))))  
 
 (define (with-pc recvr)
-  (let ((pc-info (pc-registered?)))
-    (if pc-info
-	(recvr (pc-info/label pc-info)
-	       (pc-info/reg pc-info))
-	(let ((reg (allocate-temporary-register! 'GENERAL)))
-	  (pc->reg reg
-		   (lambda (label code)
-		     (pc-register! (make-pc-info label reg))
-		     (LAP ,@code
-			  (recvr label reg))))))))
-
-(define (pc->reg reg recvr)
-  (let ((label (GENERATE-LABEL 'GET-PC)))
-    (recvr label
-	   (LAP (CALL (@PCR ,label))
-		(LABEL ,label)
-		(POP (R ,reg))))))
+  (with-values (lambda () (get-cached-label))
+    (lambda (label reg)
+      (if label
+	  (recvr label reg)
+	  (let ((temporary (allocate-temporary-register! 'GENERAL))
+		(label (generate-label 'GET-PC)))
+	    (cache-label! label temporary)
+	    (LAP (CALL (@PCR ,label))
+		 (LABEL ,label)
+		 (POP (R ,(register-reference temporary)))
+		 ,@(recvr label temporary)))))))
+
+(define-integrable (get-cached-label)
+  (register-map-label *register-map* 'GENERAL))
+
+(define-integrable (cache-label! label temporary)
+  (set! *register-map*
+	(set-machine-register-label *register-map* alias label))
+  unspecific)
 
 (define (compare/register*register reg1 reg2)
   (cond ((register-alias reg1 'GENERAL)
@@ -465,565 +467,4 @@ MIT in each case. |#
     error
     primitive-error
     |#
-    ))
-
-;;; *** Here ***
-
-;;;; Register-Allocator Interface
-
-(define (reference->register-transfer source target)
-  (if (and (effective-address/register? source)
-	   (= (lap:ea-R-register source) target))
-      (LAP)
-      (LAP (MOV L ,source ,(register-reference target)))))
-
-(define (register->register-transfer source target)
-  (LAP ,@(machine->machine-register source target)))
-
-(define (home->register-transfer source target)
-  (LAP ,@(pseudo->machine-register source target)))
-
-(define (register->home-transfer source target)
-  (LAP ,@(machine->pseudo-register source target)))
-
-(define-integrable (pseudo-register-home register)
-  (offset-reference regnum:regs-pointer
-		    (pseudo-register-offset register)))
-
-(define (register-types-compatible? type1 type2)
-  (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
-
-(define (register-type register)
-  ;; This will have to be changed when floating point support is added.
-  (if (or (machine-register? register)
-	  (register-value-class=word? register))
-      'GENERAL
-      (error "unable to determine register type" register)))
-
-(define register-reference
-  (let ((references (make-vector number-of-machine-registers)))
-    (let loop ((i 0))
-      (if (< i number-of-machine-registers)
-	  (begin
-	    (vector-set! references i (INST-EA (R ,i)))
-	    (loop (1+ i)))))
-    (lambda (register)
-      (vector-ref references register))))
-
-(define mask-reference
-  (register-reference regnum:pointer-mask))
-
-(define (lap:make-label-statement label)
-  ;; This should use LAP rather than INST, but
-  ;; that requires changing back/linear.scm
-  (INST (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
-  (LAP (BR (@PCR ,label))))		; Unsized
-
-(define (lap:make-entry-point label block-start-label)
-  block-start-label
-  (LAP (ENTRY-POINT ,label)
-       ,@(make-external-label expression-code-word label)))
-
-;;;; Basic Machine Instructions
-
-(define-integrable (pseudo->machine-register source target)
-  (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
-  (machine-register->memory source (pseudo-register-home target)))
-
-(define (pseudo-float? register)
-  (and (pseudo-register? register)
-       (value-class=float? (pseudo-register-value-class register))))
-
-(define (pseudo-word? register)
-  (and (pseudo-register? register)
-       (value-class=word? (pseudo-register-value-class register))))
-
-(define-integrable (machine->machine-register source target)
-  (LAP (MOV L
-	    ,(register-reference source)
-	    ,(register-reference target))))
-
-(define-integrable (machine-register->memory source target)
-  (LAP (MOV L
-	    ,(register-reference source)
-	    ,target)))
-
-(define-integrable (memory->machine-register source target)
-  (LAP (MOV L
-	    ,source
-	    ,(register-reference target))))
-
-(define (byte-offset-reference register offset)
-  (if (zero? offset)
-      (INST-EA (@R ,register))
-      (INST-EA (@RO ,(datum-size offset) ,register ,offset))))
-
-(define-integrable (offset-reference register offset)
-  (byte-offset-reference register (* 4 offset)))
-
-(define-integrable (pseudo-register-offset register)
-  ;; Offset into register block for temporary registers
-  (+ (+ (* 16 4) (* 40 8))
-     (* 2 (register-renumber register))))
-
-(define (datum-size datum)
-  (cond ((<= -128 datum 127) 'B)
-	((<= -32768 datum 32767) 'W)
-	(else 'L)))
-
-;;;; Utilities needed by the rules files.
-
-(define-integrable (standard-target-reference target)
-  (delete-dead-registers!)
-  (reference-target-alias! target 'GENERAL))
-
-(define-integrable (any-register-reference register)
-  (standard-register-reference register false true))
-
-(define-integrable (standard-temporary-reference)
-  (reference-temporary-register! 'GENERAL))
-
-;;; Assignments
-
-(define-integrable (convert-object/constant->register target constant
-						      rtconversion
-						      ctconversion)
-  (let ((target (standard-target-reference target)))
-    (if (non-pointer-object? constant)
-	(ctconversion constant target)
-	(rtconversion (constant->ea constant) target))))
-
-(define-integrable (convert-object/register->register target source conversion)
-  ;; `conversion' often expands into multiple references to `target'.
-  (with-register-copy-alias! source 'GENERAL target
-    (lambda (target)
-      (conversion target target))
-    conversion))
-
-(define-integrable (convert-object/offset->register target address
-						    offset conversion)
-  (let ((source (indirect-reference! address offset)))
-    (conversion source 
-		(standard-target-reference target))))
-
-;;; Predicates
-
-(define (predicate/memory-operand? expression)
-  (or (rtl:offset? expression)
-      (and (rtl:post-increment? expression)
-	   (interpreter-stack-pointer?
-	    (rtl:post-increment-register expression)))))
-
-(define (predicate/memory-operand-reference expression)
-  (case (rtl:expression-type expression)
-    ((OFFSET) (offset->indirect-reference! expression))
-    ((POST-INCREMENT) (INST-EA (@R+ 14)))
-    (else (error "Illegal memory operand" expression))))
-
-(define (compare/register*register register-1 register-2 cc)
-  (set-standard-branches! cc)
-  (LAP (CMP L ,(any-register-reference register-1)
-	    ,(any-register-reference register-2))))
-
-(define (compare/register*memory register memory cc)
-  (set-standard-branches! cc)
-  (LAP (CMP L ,(any-register-reference register) ,memory)))
-
-(define (compare/memory*memory memory-1 memory-2 cc)
-  (set-standard-branches! cc)
-  (LAP (CMP L ,memory-1 ,memory-2)))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Interpreter and interface calls
-
-(define (interpreter-call-argument? expression)
-  (or (rtl:register? expression)
-      (rtl:constant? expression)
-      (and (rtl:cons-pointer? expression)
-	   (rtl:machine-constant? (rtl:cons-pointer-type expression))
-	   (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
-      (and (rtl:offset? expression)
-	   (rtl:register? (rtl:offset-base expression)))))
-
-(define (interpreter-call-argument->machine-register! expression register)
-  (let ((target (register-reference register)))
-    (case (car expression)
-      ((REGISTER)
-       (load-machine-register! (rtl:register-number expression) register))
-      ((CONSTANT)
-       (LAP ,@(clear-registers! register)
-	    ,@(load-constant (rtl:constant-value expression) target)))
-      ((CONS-POINTER)
-       (LAP ,@(clear-registers! register)
-	    ,@(load-non-pointer (rtl:machine-constant-value
-				 (rtl:cons-pointer-type expression))
-				(rtl:machine-constant-value
-				 (rtl:cons-pointer-datum expression))
-				target)))
-      ((OFFSET)
-       (let ((source-reference (offset->indirect-reference! expression)))
-	 (LAP ,@(clear-registers! register)
-	      (MOV L ,source-reference ,target))))
-      (else
-       (error "Unknown expression type" (car expression))))))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Object structure.
-
-(define (cons-pointer/ea type-ea datum target)
-  (LAP (ROTL (S ,scheme-datum-width) ,type-ea ,target)
-       (BIS L ,datum ,target)))
-
-(define (cons-pointer/constant type datum target)
-  (if (ea/same? datum target)
-      (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) ,target))
-      (cons-pointer/ea (INST-EA (S ,type)) datum target)))
-
-(define (set-type/ea type-ea target)
-  (LAP (INSV ,type-ea (S ,scheme-datum-width) (S ,scheme-type-width)
-	     ,target)))
-
-(define-integrable (set-type/constant type target)
-  (set-type/ea (INST-EA (S ,type)) target))
-
-(define-integrable (extract-type source target)
-  (LAP (EXTV Z (S ,scheme-datum-width) (S ,scheme-type-width)
-	     ,source ,target)))
-
-(define (object->type source target)
-  (extract-type source target))
-
-(define-integrable (ct/object->type object target)
-  (load-immediate (object-type object) target))
-
-(define (object->datum source target)
-  (if (eq? source target)
-      (LAP (BIC L ,mask-reference ,target))
-      (LAP (BIC L ,mask-reference ,source ,target))))
-
-(define-integrable (ct/object->datum object target)
-  (load-immediate (object-datum object) target))
-
-(define (object->address source target)
-  (declare (integrate-operator object->datum))
-  (object->datum source target))
-
-(define-integrable (ct/object->address object target)
-  (declare (integrate-operator ct/object->datum))
-  (ct/object->datum object target))
-
-(define (compare-type type ea)
-  (set-standard-branches! 'EQL)
-  (LAP (CMPV Z (S ,scheme-datum-width) (S ,scheme-type-width)
-	     ,ea ,(make-immediate type))))
-
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (ea/same? ea1 ea2)
-  (equal? ea1 ea2))
-
-(define (ea/copy source target)
-  (if (ea/same? source target)
-      (LAP)
-      (LAP (MOV L ,source ,target))))
-
-(define (increment/ea ea offset)
-  (cond ((zero? offset)
-	 (LAP))
-	((= offset 1)
-	 (LAP (INC L ,ea)))
-	((= offset -1)
-	 (LAP (DEC L ,ea)))
-	((<= 0 offset 63)
-	 (LAP (ADD L (S ,offset) ,ea)))
-	((<= -63 offset 0)
-	 (LAP (SUB L (S ,(- 0 offset)) ,ea)))
-	((effective-address/register? ea)
-	 (let ((size (datum-size offset)))
-	   (if (not (eq? size 'L))
-	       (LAP (MOVA L (@RO ,size ,(lap:ea-R-register ea) ,offset)
-			  ,ea))
-	       (LAP (ADD L (& ,offset) ,ea)))))
-	(else
-	 (LAP (ADD L (& ,offset) ,ea)))))
-
-(define (add-constant/ea source offset target)
-  (if (ea/same? source target)
-      (increment/ea target offset)
-      (cond ((zero? offset)
-	     (LAP (MOV L ,source ,target)))
-	    ((<= 0 offset 63)
-	     (LAP (ADD L (S ,offset) ,source ,target)))
-	    ((<= -63 offset 0)
-	     (LAP (SUB L (S ,(- 0 offset)) ,source ,target)))
-	    ((effective-address/register? source)
-	     (let ((size (datum-size offset)))
-	       (if (not (eq? size 'L))
-		   (LAP (MOVA L (@RO ,size ,(lap:ea-R-register source) ,offset)
-			      ,target))
-		   (LAP (ADD L (& ,offset) ,source ,target)))))
-	    (else
-	     (LAP (ADD L (& ,offset) ,source ,target))))))
-
-(define-integrable (increment-rn rn value)
-  (increment/ea (INST-EA (R ,rn)) value))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Constants
-
-(define (make-immediate value)
-  (if (<= 0 value 63)
-      (INST-EA (S ,value))
-      (INST-EA (& ,value))))
-
-(define (constant->ea constant)
-  (if (non-pointer-object? constant)
-      (non-pointer->ea (object-type constant)
-		       (careful-object-datum constant))
-      (INST-EA (@PCR ,(constant->label constant)))))
-
-(define (non-pointer->ea type datum)
-  (if (and (zero? type)
-	   (<= 0 datum 63))
-      (INST-EA (S ,datum))
-      (INST-EA (&U ,(make-non-pointer-literal type datum)))))
-
-(define (load-constant constant target)
-  (if (non-pointer-object? constant)
-      (load-non-pointer (object-type constant)
-			(object-datum constant)
-			target)
-      (LAP (MOV L (@PCR ,(constant->label constant)) ,target))))
-
-(define (load-non-pointer type datum target)
-  (if (not (zero? type))
-      (LAP (MOV L (&U ,(make-non-pointer-literal type datum)) ,target))
-      (load-immediate datum target)))
-
-(define (load-immediate value target)
-  (cond ((zero? value)
-	 (LAP (CLR L ,target)))
-	((<= 0 value 63)
-	 (LAP (MOV L (S ,value) ,target)))
-	(else
-	 (let ((size (datum-size value)))
-	   (if (not (eq? size 'L))
-	       (LAP (CVT ,size L (& ,value) ,target))
-	       (LAP (MOV L (& ,value) ,target)))))))
-
-(define-integrable (load-rn value rn)
-  (load-immediate value (INST-EA (R ,rn))))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Predicate utilities
-
-(define (set-standard-branches! condition-code)
-  (set-current-branches!
-   (lambda (label)
-     (LAP (B ,condition-code (@PCR ,label))))
-   (lambda (label)
-     (LAP (B ,(invert-cc condition-code) (@PCR ,label))))))
-
-(define (test-byte n effective-address)
-  (cond ((zero? n)
-	 (LAP (TST B ,effective-address)))
-	((<= 0 n 63)
-	 (LAP (CMP B ,effective-address (S ,n))))
-	(else
-	 (LAP (CMP B ,effective-address (& ,n))))))
-
-(define (test-non-pointer type datum effective-address)
-  (cond ((not (zero? type))
-	 (LAP (CMP L
-		   ,effective-address
-		   (&U ,(make-non-pointer-literal type datum)))))
-	((zero? datum)
-	 (LAP (TST L ,effective-address)))
-	((<= 0 datum 63)
-	 (LAP (CMP L ,effective-address (S ,datum))))
-	(else
-	 (LAP (CMP L
-		   ,effective-address
-		   (&U ,(make-non-pointer-literal type datum)))))))
-
-(define (invert-cc condition-code)
-  (cdr (or (assq condition-code
-		 '((NEQU . EQLU) (EQLU . NEQU)
-		   (NEQ . EQL) (EQL . NEQ)
-		   (GTR . LEQ) (LEQ . GTR)
-		   (GEQ . LSS) (LSS . GEQ)
-		   (VC . VS) (VS . VC)
-		   (CC . CS) (CS . CC)
-		   (GTRU . LEQU) (LEQU . GTRU)
-		   (GEQU . LSSU) (LSSU . GEQU)))
-	   (error "INVERT-CC: Not a known CC" condition-code))))
-
-(define (invert-cc-noncommutative condition-code)
-  ;; Despite the fact that the name of this procedure is similar to
-  ;; that of `invert-cc', it is quite different.  `invert-cc' is used
-  ;; when the branches of a conditional are being exchanged, while
-  ;; this is used when the arguments are being exchanged.
-  (cdr (or (assq condition-code
-		 '((NEQU . NEQU) (EQLU . EQLU)
-     		   (NEQ . NEQ) (EQL . EQL)
-		   (GTR . LSS) (LSS . GTR)
-		   (GEQ . LEQ) (LEQ . GEQ)
-		   ;; *** Are these two really correct? ***
-		   (VC . VC) (VS . VS)
-		   (CC . CC) (CS . CS)
-		   (GTRU . LSSU) (LSSU . GTRU)
-		   (GEQU . LEQU) (LEQU . GEQU)))
-	   (error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" condition-code))))
-
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (effective-address/register? ea)
-  (eq? (lap:ea-keyword ea) 'R))
-
-(define-integrable (effective-address/register-indirect? ea)
-  (eq? (lap:ea-keyword ea) '@R))
-
-(define-integrable (effective-address/register-offset? ea)
-  (eq? (lap:ea-keyword ea) '@RO))
-
-(define (offset->indirect-reference! offset)
-  (indirect-reference! (rtl:register-number (rtl:offset-base offset))
-		       (rtl:offset-number offset)))
-
-(define-integrable (indirect-reference! register offset)
-  (offset-reference (allocate-indirection-register! register) offset))
-
-(define-integrable (indirect-byte-reference! register offset)
-  (byte-offset-reference (allocate-indirection-register! register) offset))
-
-(define (allocate-indirection-register! register)
-  (load-alias-register! register 'GENERAL))
-
-(define (generate-n-times n limit instruction-gen with-counter)
-  (if (> n limit)
-      (let ((loop (generate-label 'LOOP)))
-	(with-counter
-	  (lambda (counter)
-	    (LAP ,@(load-rn (-1+ n) counter)
-		 (LABEL ,loop)
-		 ,@(instruction-gen)
-		 (SOB GEQ (R ,counter) (@PCR ,loop))))))
-      (let loop ((n n))
-	(if (zero? n)
-	    (LAP)
-	    (LAP ,@(instruction-gen)
-		 ,@(loop (-1+ n)))))))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; CHAR->ASCII utilities
-
-(define (coerce->any/byte-reference register)
-  (if (machine-register? register)
-      (register-reference register)
-      (let ((alias (register-alias register false)))
-	(if alias
-	    (register-reference alias)
-	    (indirect-char/ascii-reference!
-	     regnum:regs-pointer
-	     (pseudo-register-offset register))))))
-
-(define-integrable (indirect-char/ascii-reference! register offset)
-  (indirect-byte-reference! register (* offset 4)))
-
-(define (char->signed-8-bit-immediate character)
-  (let ((ascii (char->ascii character)))
-    (if (< ascii 128)
-	ascii
-	(- ascii 256))))
-
-(define-integrable (lap:ea-keyword expression)
-  (car expression))
-
-(define-integrable (lap:ea-R-register expression)
-  (cadr expression))
-
-(define-integrable (lap:ea-@R-register expression)
-  (cadr expression))
-
-(define-integrable (lap:ea-@RO-register expression)
-  (caddr expression))
-
-(define-integrable (lap:ea-@RO-offset expression)
-  (cadddr expression))
-
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Layout of the Scheme register array.
-
-(define-integrable reg:compiled-memtop (INST-EA (@R 10)))
-(define-integrable reg:environment (INST-EA (@RO B 10 #x000C)))
-(define-integrable reg:temp (INST-EA (@RO B 10 #x0010)))
-(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 10 #x001C)))
-
-(let-syntax ((define-codes
-	       (macro (start . names)
-		 (define (loop names index)
-		   (if (null? names)
-		       '()
-		       (cons `(DEFINE-INTEGRABLE
-				,(symbol-append 'CODE:COMPILER-
-						(car names))
-				,index)
-			     (loop (cdr names) (1+ index)))))
-		 `(BEGIN ,@(loop names start)))))
-  (define-codes #x012
-    primitive-apply primitive-lexpr-apply
-    apply error lexpr-apply link
-    interrupt-closure interrupt-dlink interrupt-procedure 
-    interrupt-continuation interrupt-ic-procedure
-    assignment-trap cache-reference-apply
-    reference-trap safe-reference-trap unassigned?-trap
-    -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
-    access lookup safe-lookup unassigned? unbound?
-    set! define lookup-apply))
-
-(let-syntax ((define-entries
-	       (macro (start . names)
-		 (define (loop names index)
-		   (if (null? names)
-		       '()
-		       (cons `(DEFINE-INTEGRABLE
-				,(symbol-append 'ENTRY:COMPILER-
-						(car names))
-				(INST-EA (@RO B 10 ,index)))
-			     (loop (cdr names) (+ index 8)))))
-		 `(BEGIN ,@(loop names start)))))
-  (define-entries #x40
-    scheme-to-interface			; Main entry point (only one necessary)
-    scheme-to-interface-jsb		; Used by rules3&4, for convenience.
-    trampoline-to-interface		; Used by trampolines, for convenience.
-    ;; If more are added, the size of the addressing mode must be changed.
-    ))
-
-(define-integrable (invoke-interface code)
-  (LAP ,@(load-rn code 0)
-       (JMP ,entry:compiler-scheme-to-interface)))
-
-#|
-;; If the entry point scheme-to-interface-jsb were not available,
-;; this code should replace the definition below.
-;; The others can be handled similarly.
-
-(define-integrable (invoke-interface-jsb code)
-  (LAP ,@(load-rn code 0)
-       (MOVA B (@PCO B 10) (R 1))
-       (JMP ,entry:compiler-scheme-to-interface)))
-|#
-
-(define-integrable (invoke-interface-jsb code)
-  (LAP ,@(load-rn code 0)
-       (JSB ,entry:compiler-scheme-to-interface-jsb)))
+    ))
\ No newline at end of file
-- 
2.25.1