From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Wed, 5 Feb 1992 14:57:52 +0000 (+0000)
Subject: More changes.
X-Git-Tag: 20090517-FFI~9858
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f91949b1567e77eafae8bfe2f4dc6feb75433c5c;p=mit-scheme.git

More changes.
---

diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm
index 95b9e24b7..fdd58ab2e 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.2 1992/01/30 14:07:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.3 1992/02/05 14:57:12 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
@@ -38,6 +38,149 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 
+;;;; Register-Allocator Interface
+
+(define available-machine-registers
+  ;; esp holds the the stack pointer
+  ;; ebp holds the pointer mask
+  ;; esi holds the register array pointer
+  ;; edi holds the free pointer
+  ;; fr7 is not used so that we can always push on the stack once.
+  (list eax ecx edx ebx fr0 fr1 fr2 fr3 fr4 fr5 fr6))
+
+(define-integrable (sort-machine-registers registers)
+  registers)
+
+(define (register-type register)
+  (cond ((machine-register? register)
+	 (vector-ref
+	  '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+	     FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+	  register))
+	((register-value-class=word? register)
+	 'GENERAL)
+	((register-value-class=float? register)
+	 'FLOAT)
+	(else
+	 (error "unable to determine register type" register))))
+
+(define (register-types-compatible? type1 type2)
+  (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define register-reference
+  (let ((references (make-vector number-of-machine-registers)))
+    (let loop ((i 0))
+      (cond ((>= i number-of-machine-registers)
+	     (lambda (register)
+	       (vector-ref references register)))
+	    ((< i 8)
+	     (vector-set! references i (INST-EA (R ,i)))
+	     (loop (1+ i)))
+	    (else
+	     (vector-set! references i (INST-EA (ST ,(floreg->sti i))))
+	     (loop (1+ i)))))))
+
+(define (register->register-transfer source target)
+  (machine->machine-register source target))
+
+(define (reference->register-transfer source target)
+  (if (equal? (INST-EA ,target) source)
+      (LAP)
+      (memory->machine-register source target)))
+
+(define-integrable (pseudo-register-home register)
+  (offset-reference regnum:regs-pointer
+		    (pseudo-register-offset register)))
+
+(define (home->register-transfer source target)
+  (pseudo->machine-register source target))
+
+(define (register->home-transfer source target)
+  (machine->pseudo-register source target))
+
+;;;; Linearizer interface
+
+(define (lap:make-label-statement label)
+  (INST (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+  (LAP (JMP (@PCR ,label))))
+
+(define (lap:make-entry-point label block-start-label)
+  block-start-label
+  (LAP (ENTRY-POINT ,label)
+       ,@(make-external-label expression-code-word label)))
+
+(define (make-external-label code label)
+  (set! *external-labels* (cons label *external-labels*))
+  (LAP (DC UW ,code)
+       (BLOCK-OFFSET ,label)
+       (LABEL ,label)))
+
+(define-integrable (make-code-word min max)
+  (+ (* #x100 min) max))
+
+(define expression-code-word
+  (make-code-word #xff #xff))
+
+;;;; Utilities for the register allocator interface
+
+(define-integrable (machine->machine-register source target)
+  (if (not (register-types-compatible? source target))
+      (error "Moving between incompatible register types" source target))
+  (if (not (float-register? source))
+      (LAP (MOV W ,(register-reference target) ,(register-reference source)))
+      (let ((ssti (floreg->sti source))
+	    (tsti (floreg->sti target)))
+	(if (zero? ssti)
+	    (LAP (FST D (ST ,tsti)))
+	    (LAP (FLD D (ST ,ssti))
+		 (FSTP D (ST ,(1+ tsti))))))))
+
+(define (machine-register->memory source target)
+  (if (not (float-register? source))
+      (LAP (MOV W ,target ,(register-reference source)))
+      (let ((ssti (floreg->sti source)))
+	(if (zero? ssti)
+	    (LAP (FST D ,target))
+	    (LAP (FLD D (ST ,ssti))
+		 (FSTP D ,target))))))
+
+(define (memory->machine-register source target)
+  (if (not (float-register? target))
+      (LAP (MOV W ,(register-reference target) ,source))
+      (LAP (FLD D ,source)
+	   (FSTP D (ST ,(1+ (floreg->sti target)))))))
+
+(define-integrable (offset-reference register offset)
+  (byte-offset-reference register (* 4 offset)))
+
+(define (byte-offset-reference register offset)
+    (if (zero? offset)
+	(INST-EA (@R ,register))
+	(INST-EA (@RO ,register ,offset))))
+
+(define-integrable (pseudo-register-offset register)
+  (+ (+ (* 16 4) (* 80 4))
+     (* 3 (register-renumber register))))
+
+(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-integrable (floreg->sti reg)
+  (- reg fr0))
+
+(define-integrable (general-register? register)
+  (< register fr0))
+
+(define-integrable (float-register? register)
+  (<= fr0 register fr7))
+
+;;;; Utilities for the rules
+
 (define (require-register! machine-reg)
   (flush-register! machine-reg)
   (need-register! machine-reg))
@@ -80,14 +223,14 @@ MIT in each case. |#
 
 (define (load-immediate target value)
   (if (zero? value)
-      (XOR W ,target ,target)
-      (MOV W ,target (& ,value))))
+      (LAP (XOR W ,target ,target))
+      (LAP (MOV W ,target (& ,value)))))
 
 (define (load-non-pointer target type datum)
   (let ((immediate-value (make-non-pointer-literal type datum)))
     (if (zero? immediate-value)
-	(XOR W ,target ,target)
-	(MOV W ,target (&U ,immediate-value)))))
+	(LAP (XOR W ,target ,target))
+	(LAP (MOV W ,target (&U ,immediate-value))))))
 
 (define (load-constant target obj)
   (if (non-pointer-object? obj)
@@ -102,8 +245,8 @@ MIT in each case. |#
 (define (load-pc-relative-address target label-expr)
   (with-pc
     (lambda (pc-label pc-register)
-      (LAP (LEA ,target (@RO ,pc-register (- ,label-expr ,pc-label)))))))
-
+      (LAP (LEA ,target (@RO ,pc-register (- ,label-expr ,pc-label)))))))  
+
 (define (with-pc recvr)
   (let ((pc-info (pc-registered?)))
     (if pc-info
@@ -117,11 +260,11 @@ MIT in each case. |#
 			  (recvr label reg))))))))
 
 (define (pc->reg reg recvr)
-  (let ((label (generate-label 'get-pc)))
+  (let ((label (GENERATE-LABEL 'GET-PC)))
     (recvr label
 	   (LAP (CALL (@PCR ,label))
 		(LABEL ,label)
-		(POP (R ,reg))))))  
+		(POP (R ,reg))))))
 
 (define (compare/register*register reg1 reg2)
   (cond ((register-alias reg1 'GENERAL)
@@ -135,55 +278,83 @@ MIT in each case. |#
 	(else
 	 (LAP (CMP W ,(source-register-reference reg1)
 		   ,(any-reference reg2))))))
+
+(define (target-register-reference target)
+  (delete-dead-registers!)
+  (register-reference
+   (or (register-alias target 'GENERAL)
+       (allocate-alias-register! target 'GENERAL))))
+
+(define-integrable (temporary-register-reference)
+  (reference-temporary-register! 'GENERAL))
+
+(define (source-register-reference source)
+  (register-reference
+   (or (register-alias source 'GENERAL)
+       (load-alias-register! source 'GENERAL))))
+
+(define-integrable (any-reference rtl-reg)
+  (standard-register-reference rtl-reg 'GENERAL true))
+
+(define (standard-move-to-temporary! source)
+  (register-reference (move-to-temporary-register! source 'GENERAL)))
+
+(define (standard-move-to-target! source target)
+  (register-reference (move-to-alias-register! source 'GENERAL target)))
+
+(define-integrable (source-indirect-reference! rtl-reg offset)
+  (indirect-reference! rtl-reg offset))
+
+(define-integrable (target-indirect-reference! rtl-reg offset)
+  (indirect-reference! rtl-reg offset))
+
+(define (indirect-reference! rtl-reg offset)
+  (offset-reference (allocate-indirection-register! rtl-reg)
+		    offset))
+
+(define-integrable (allocate-indirection-register! register)
+  (load-alias-register! register 'GENERAL))
+
+(define (offset->indirect-reference! rtl-expr)
+  (indirect-reference! (rtl:register-number (rtl:offset-base offset))
+		       (rtl:offset-number offset)))
+
+(define (object->type target)
+  (LAP (SHR W ,target (& ,scheme-datum-width))))
+
+(define (object->datum target)
+  (LAP (AND W ,target (R ,regnum:datum-mask))))
+
+(define (object->address target)
+  (declare (integrate-operator object->datum))
+  (object->datum target))
+
+(define (interpreter-call-argument? expression)
+  (or (rtl:register? 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 (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 (interpreter-call-argument->machine-register! expression register)
+  (let ((target (register-reference register)))
+    (case (car expression)
+      ((REGISTER)
+       (load-machine-register! (rtl:register-number expression) register))
+      ((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 W ,target ,source-reference))))
+      (else
+       (error "Unknown expression type" (car expression))))))
 
 ;;; *** Here ***
 
@@ -208,15 +379,6 @@ MIT in each case. |#
   (offset-reference regnum:regs-pointer
 		    (pseudo-register-offset register)))
 
-(define-integrable (sort-machine-registers registers)
-  registers)
-
-(define available-machine-registers
-  ;; r9 is value register.
-  ;; r10 - r13 are taken up by Scheme.
-  ;; r14 is sp and r15 is pc.
-  (list r0 r1 r2 r3 r4 r5 r6 r7 r8))
-
 (define (register-types-compatible? type1 type2)
   (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
 
diff --git a/v7/src/compiler/machines/i386/machin.scm b/v7/src/compiler/machines/i386/machin.scm
index 95706ae9b..5f027a630 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.4 1992/02/04 04:04:44 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/machin.scm,v 1.5 1992/02/05 14:57:32 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
@@ -142,13 +142,13 @@ MIT in each case. |#
 (define fr4 12)
 (define fr5 13)
 (define fr6 14)
-;; (define fr7 15)
+(define fr7 15)
 
-(define number-of-machine-registers 15)
+(define number-of-machine-registers 16)
 (define number-of-temporary-registers 256)
 
 (define-integrable regnum:stack-pointer esp)
-(define-integrable regnum:pointer-mask ebp)
+(define-integrable regnum:datum-mask ebp)
 (define-integrable regnum:regs-pointer esi)
 (define-integrable regnum:free-pointer edi)
 
@@ -159,7 +159,7 @@ MIT in each case. |#
 (define (machine-register-value-class register)
   (cond ((<= eax register ebx)
 	 value-class=object)
-	((= register regnum:pointer-mask)
+	((= register regnum:datum-mask)
 	 value-class=immediate)
 	((or (= register regnum:stack-pointer)
 	     (= register regnum:free-pointer)
diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm
index 51a481bdc..34b684f58 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.5 1992/01/31 04:35:11 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules3.scm,v 1.6 1992/02/05 14:56:45 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
@@ -41,7 +41,7 @@ MIT in each case. |#
 ;;;; Invocations
 
 (define-integrable (clear-continuation-type-code)
-  (LAP (AND W (@RO ,regnum:stack-pointer) (R ,regnum:pointer-mask))))
+  (LAP (AND W (@RO ,regnum:stack-pointer) (R ,regnum:datum-mask))))
 
 (define-rule statement
   (POP-RETURN)
@@ -287,17 +287,8 @@ MIT in each case. |#
 
 ;;;; External Labels
 
-(define (make-external-label code label)
-  (set! *external-labels* (cons label *external-labels*))
-  (LAP (DC UW ,code)
-       (BLOCK-OFFSET ,label)
-       (LABEL ,label)))
-
 ;;; Entry point types
 
-(define-integrable (make-code-word min max)
-  (+ (* #x100 min) max))
-
 (define (make-procedure-code-word min max)
   ;; The "min" byte must be less than #x80; the "max" byte may not
   ;; equal #x80 but can take on any other value.
@@ -307,9 +298,6 @@ MIT in each case. |#
       (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
   (make-code-word min (if (negative? max) (+ #x100 max) max)))
 
-(define expression-code-word
-  (make-code-word #xff #xff))
-
 (define internal-entry-code-word
   (make-code-word #xff #xfe))
 
@@ -565,7 +553,7 @@ MIT in each case. |#
 	   (lambda (pc-label prefix)
 	     (LAP ,@prefix
 		  (MOV W (R ,edx) (@RO ,eax (- ,code-block-label ,pc-label)))
-		  (AND W (R ,edx) (R ,regnum:pointer-mask))
+		  (AND W (R ,edx) (R ,regnum:datum-mask))
 		  (LEA (R ,ebx) (@RO ,edx ,free-ref-offset))
 		  (MOV W (R ,ecx) ,reg:environment)
 		  (MOV W (@RO ,edx ,environment-offset) (R ,ecx))
diff --git a/v7/src/compiler/machines/i386/rulflo.scm b/v7/src/compiler/machines/i386/rulflo.scm
index 572d71e69..49092e1b0 100644
--- a/v7/src/compiler/machines/i386/rulflo.scm
+++ b/v7/src/compiler/machines/i386/rulflo.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulflo.scm,v 1.7 1992/02/05 05:03:48 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulflo.scm,v 1.8 1992/02/05 14:57:52 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
@@ -44,15 +44,12 @@ MIT in each case. |#
 ;; Also missing with (OBJECT->FLOAT (REGISTER ...)) operands.
 ;; ****
 
-(define-integrable (->sti reg)
-  (- reg fr0))
-
 (define (flonum-source! register)
-  (->sti (load-alias-register! register 'FLOAT)))
+  (floreg->sti (load-alias-register! register 'FLOAT)))
 
 (define (flonum-target! pseudo-register)
   (delete-dead-registers!)
-  (->sti (allocate-alias-register! pseudo-register 'FLOAT)))
+  (floreg->sti (allocate-alias-register! pseudo-register 'FLOAT)))
 
 (define (flonum-temporary!)
   (allocate-temporary-register! 'FLOAT))
@@ -75,10 +72,10 @@ MIT in each case. |#
 		      (MOV W ,temp (@RO ,regnum:regs-pointer ,(+ 4 off)))
 		      (MOV W (@RO ,regnum:free-pointer 4) ,target)
 		      (MOV W (@RO ,regnum:free-pointer 8) ,temp)))
-	       (let ((sti (->sti source)))
+	       (let ((sti (floreg->sti source)))
 		 (if (zero? sti)
 		     (LAP (FST D (@RO ,regnum:free-pointer 4)))
-		     (LAP (FLD D (ST ,(->sti source)))
+		     (LAP (FLD D (ST ,(floreg->sti source)))
 			  (FSTP D (@RO ,regnum:free-pointer 4))))))
 	 (LEA ,target
 	      (@RO ,regnum:free-pointer
@@ -272,7 +269,7 @@ MIT in each case. |#
 	   (reuse-pseudo-register-alias
 	    source1 target-type
 	    (lambda (alias)
-	      (let* ((sti1 (->sti alias))
+	      (let* ((sti1 (floreg->sti alias))
 		     (sti2 (if (= source1 source2)
 			       sti1
 			       (flonum-source! source2))))
@@ -285,7 +282,7 @@ MIT in each case. |#
 	       source2 target-type
 	       (lambda (alias2)
 		 (let ((sti1 (flonum-source! source1))
-		       (sti2 (->sti alias2)))
+		       (sti2 (floreg->sti alias2)))
 		   (delete-register! alias2)
 		   (delete-dead-registers!)
 		   (add-pseudo-register-alias! target alias2)