From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 15 Dec 1986 05:48:57 +0000 (+0000)
Subject: *** empty log message ***
X-Git-Tag: 20090517-FFI~13818
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=18d4fa553c5d100974a9a566e0c2add61e45e58d;p=mit-scheme.git

*** empty log message ***
---

diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 474bf281a..44970dd94 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -37,6 +37,8 @@
 
 ;;;; RTL Rules for 68020
 
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.139 1986/12/15 05:48:37 cph Exp $
+
 (declare (usual-integrations))
 (using-syntax (access lap-generator-syntax-table compiler-package)
 
@@ -114,10 +116,10 @@
 	(else
 	 `(MOVE L (& ,datum) ,target))))
 
-(define (test-type type expression)
-  (if (and (zero? type) (TSTable-expression? expression))
+(define (test-byte n expression)
+  (if (and (zero? n) (TSTable-expression? expression))
       `(TST B ,expression)
-      `(CMP B (& ,type) ,expression)))
+      `(CMP B (& ,n) ,expression)))
 
 (define (test-non-pointer type datum expression)
   (if (and (zero? type) (zero? datum) (TSTable-expression? expression))
@@ -170,26 +172,14 @@
   (memq (car expression) '(A D)))
 
 (define (indirect-reference! register offset)
-  (offset-reference (coerce->indirect-register! register) offset))
-
-(define (coerce->indirect-register! register)
-  (cond ((memv register '(13 14 15)) register)
-	((and (pseudo-register? register)
-	      (dead-register? register)
-	      (let ((alias (register-alias register 'DATA)))
-		(and alias
-		     (begin (prefix-instructions!
-			     `((AND L ,mask-reference
-				    ,(register-reference alias))))
-			    alias)))))
-	(else
-	 (with-temporary-register! 'DATA
-	   (lambda (temp)
-	     (prefix-instructions!
-	      (let ((temp-ref (register-reference temp)))
-		`((MOVE L ,(coerce->any register) ,temp-ref)
-		  (AND L ,mask-reference ,temp-ref))))
-	     temp)))))
+  (offset-reference
+   (if (machine-register? register)
+       register
+       (or (register-alias register false)
+	   ;; This means that someone has written an address out
+	   ;; to memory, something that should never happen.
+	   (error "Needed to load indirect register!" register)))
+   offset))
 
 (define (coerce->any register)
   (if (machine-register? register)
@@ -216,6 +206,13 @@
 	     (LABEL ,loop)
 	     ,instruction
 	     (DB F (D ,counter) (@PCR ,loop))))))))
+
+(define-integrable (data-register? register)
+  (< register 8))
+
+(define (address-register? register)
+  (and (< register 16)
+       (>= register 8)))
 
 ;;;; Registers/Entries
 
@@ -256,26 +253,32 @@
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
   (QUALIFIER (pseudo-register? target))
-  (let ((source (coerce->any source)))
-    (delete-dead-registers!)
-    (allocate-register-for-assignment! target false
-      (lambda (target)
-	`((MOVE L ,source ,(register-reference target)))))))
+  (move-to-alias-register! source 'DATA target)
+  '())
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+  (QUALIFIER (pseudo-register? target))
+  (let ((target (move-to-alias-register! source 'DATA target)))
+    `((AND L ,mask-reference ,target))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+  (QUALIFIER (pseudo-register? target))
+  (let ((target (move-to-alias-register! source 'DATA target)))
+    `((LS R (& 24) ,target))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
   (QUALIFIER (pseudo-register? target))
-  (let ((address (coerce->indirect-register! address)))
+  (let ((source (indirect-reference! address offset)))
     (delete-dead-registers!)
     ;; The fact that the target register here is a data register is a
     ;; heuristic that works reasonably well since if the value is a
     ;; pointer, we will probably want to dereference it, which
     ;; requires that we first mask it.
-    (allocate-register-for-assignment! target 'DATA
-      (lambda (target)
-	`((MOVE L
-		,(offset-reference address offset)
-		,(register-reference target)))))))
+    `((MOVE L ,source
+	    ,(register-reference (allocate-alias-register! target 'DATA))))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
@@ -293,13 +296,6 @@
 
 ;;;; Transfers to Memory
 
-(define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
-	  (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
-  (let ((target (indirect-reference! a n)))
-    `((MOVE L ,(coerce->any r) ,target)
-      (MOVE B (& ,type) ,target))))
-
 (define-rule statement
   (ASSIGN (OFFSET (REGISTER (? a)) (? n))
 	  (CONSTANT (? object)))
@@ -310,13 +306,18 @@
 	  (REGISTER (? r)))
   `((MOVE L ,(coerce->any r) ,(indirect-reference! a n))))
 
+(define-rule statement
+  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+	  (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+  (let ((target (indirect-reference! a n)))
+    `((MOVE L ,(coerce->any r) ,target)
+      (MOVE B (& ,type) ,target))))
+
 (define-rule statement
   (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
 	  (OFFSET (REGISTER (? a1)) (? n1)))
-  (let ((a1 (coerce->indirect-register! a1)))
-    `((MOVE L
-	    ,(offset-reference a1 n1)
-	    ,(offset-reference (coerce->indirect-register! a0) n0)))))
+  (let ((source (indirect-reference! a1 n1)))
+    `((MOVE L ,source ,(indirect-reference! a0 n0)))))
 
 ;;;; Consing
 
@@ -334,12 +335,11 @@
 
 (define-rule statement
   (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure)))
-  (with-temporary-register! 'ADDRESS
-    (lambda (a)
-      (let ((a (register-reference a)))
-	`((LEA (@PCR ,(procedure-external-label procedure)) ,a)
-	  (MOVE L ,a (@A+ 5))
-	  (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))))
+  (let ((temporary
+	 (register-reference (allocate-temporary-register! 'ADDRESS))))
+    `((LEA (@PCR ,(procedure-external-label procedure)) ,temporary)
+      (MOVE L ,temporary (@A+ 5))
+      (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))
 
 ;;;; Pushes
 
@@ -355,6 +355,12 @@
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
   `((MOVE L ,(coerce->any r) (@-A 7))))
 
+(define-rule statement
+  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+	  (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+  `((MOVE L ,(coerce->any r) (@-A 7))
+    (MOVE B (& ,type) (@A 7))))
+
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
   `((MOVE L ,(indirect-reference! r n) (@-A 7))))
@@ -370,12 +376,6 @@
 	  (ENTRY:CONTINUATION (? continuation)))
   `((PEA (@PCR ,(continuation-label continuation)))
     (MOVE B (& ,type-code:return-address) (@A 7))))
-
-(define-rule statement
-  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
-	  (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
-  `((MOVE L ,(coerce->any r) (@-A 7))
-    (MOVE B (& ,type) (@A 7))))
 
 ;;;; Predicates
 
@@ -391,26 +391,27 @@
 		       (indirect-reference! register offset))))
 
 (define-rule predicate
-  (TRUE-TEST (TYPE-TEST (REGISTER (? register)) (? type)))
+  (TYPE-TEST (REGISTER (? register)) (? type))
+  (QUALIFIER (pseudo-register? register))
   (set-standard-branches! 'EQ)
-  (let ((register (coerce->any register)))
-    (if (memq (car register) '(A D))
-	`((MOVE L ,register ,reg:temp)
-	  ,(test-type type reg:temp))
-	`(,(test-type type register)))))
+  `(,(test-byte type
+		(register-reference (load-alias-register! register 'DATA)))))
 
 (define-rule predicate
-  (TRUE-TEST (TYPE-TEST (OFFSET (REGISTER (? register)) (? offset)) (? type)))
+  (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
+  (QUALIFIER (pseudo-register? register))
   (set-standard-branches! 'EQ)
-  `(,(test-type type (indirect-reference! register offset))))
+  (let ((reference (move-to-temporary-register! register 'DATA)))
+    `((LS R (& 24) ,reference)
+      ,(test-byte type reference))))
 
 (define-rule predicate
-  (TRUE-TEST (UNASSIGNED-TEST (REGISTER (? register))))
+  (UNASSIGNED-TEST (REGISTER (? register)))
   (set-standard-branches! 'EQ)
   `(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register))))
 
 (define-rule predicate
-  (TRUE-TEST (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))))
+  (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
   (set-standard-branches! 'EQ)
   `(,(test-non-pointer (ucode-type unassigned) 0
 		       (indirect-reference! register offset))))
@@ -503,24 +504,19 @@
 	     (let ((i `(MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))
 	       `(,i ,i ,@(increment-anl 7 (- how-far 2))))))
 	(else
-	 (with-temporary-register! 'ADDRESS
-	   (lambda (a0)
-	     ;; If we can guarantee that interrupts will not use the user
-	     ;; stack, we can use A7 here rather than allocating this
-	     ;; second temporary register.
-	     (with-temporary-register! 'ADDRESS
-	       (lambda (a1)
-		 `((LEA ,(offset-reference a7 frame-size)
-			,(register-reference a0))
-		   (LEA ,(offset-reference a7 (+ frame-size how-far))
-			,(register-reference a1))
-		   ,@(generate-n-times frame-size 5
-				       `(MOVE L
-					      (@-A ,(- a0 8))
-					      (@-A ,(- a1 8)))
-		       (lambda (generator)
-			 (with-temporary-register! 'DATA generator)))
-		   (MOVE L ,(register-reference a1) (A 7))))))))))
+	 (let ((temp-0 (allocate-temporary-register! 'ADDRESS))
+	       (temp-1 (allocate-temporary-register! 'ADDRESS)))
+	   `((LEA ,(offset-reference a7 frame-size)
+		  ,(register-reference temp-0))
+	     (LEA ,(offset-reference a7 (+ frame-size how-far))
+		  ,(register-reference temp-1))
+	     ,@(generate-n-times frame-size 5
+				 `(MOVE L
+					(@-A ,(- temp-0 8))
+					(@-A ,(- temp-1 8)))
+		 (lambda (generator)
+		   (generator (allocate-temporary-register! 'DATA))))
+	     (MOVE L ,(register-reference temp-1) (A 7)))))))
 
 (define (generate-invocation-prefix:apply-closure frame-size receiver-offset)
   (let ((label (generate-label)))
diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index dd80bfc66..599a57b6c 100644
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -37,6 +37,8 @@
 
 ;;;; Machine Model for 68020
 
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.41 1986/12/15 05:48:50 cph Exp $
+
 (declare (usual-integrations))
 (using-syntax (access compiler-syntax-table compiler-package)
 (define (rtl:message-receiver-size:closure) 2)
@@ -68,18 +70,21 @@
      (+ 30
 	(rtl:expression-cost (rtl:cons-pointer-type expression))
 	(rtl:expression-cost (rtl:cons-pointer-datum expression))))
-    ;; move.l d(reg),reg = 16
-    ;; and.l d7,reg = 6
-    ((OBJECT->ADDRESS) 22)
+    ((OBJECT->ADDRESS OBJECT->DATUM) 6)	;and.l d7,reg
+    ;; move.l reg,d(reg) = 16
+    ;; move.b d(reg),reg = 12
+    ((OBJECT->TYPE) 28)
     ((OFFSET) 16)			;move.l d(reg),reg
     ((OFFSET-ADDRESS) 8)		;lea d(an),reg
     ((POST-INCREMENT) 12)		;move.l (reg)+,reg
     ((PRE-INCREMENT) 14)		;move.l -(reg),reg
     ((REGISTER) 4)			;move.l reg,reg
-    ((ENTRY:CONTINUATION ENTRY:PROCEDURE UNASSIGNED) 16) ;move.l d(pc),reg
-    ;; **** Random.  Fix this later.
-    ((TYPE-TEST UNASSIGNED-TEST)
-     (+ 40 (rtl:expression-cost (rtl:test-expression expression))))
+    ((UNASSIGNED) 12)			;move.l #data,reg
+    ;; lea d(pc),reg       =  8
+    ;; move.l reg,d(reg)   = 16
+    ;; move.b #type,d(reg) = 16
+    ;; move.l d(reg),reg   = 16
+    ((ENTRY:CONTINUATION ENTRY:PROCEDURE) 56)
     (else (error "Unknown expression type" expression))))
 
 (define (rtl:machine-register? rtl-register)
diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index 41b3e00b5..1e216fe6e 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -43,21 +43,6 @@
 (load "rcs" system-global-environment)
 (load "load" system-global-environment)
 
-(in-package compiler-package
-
-  (define compiler-system
-    (make-environment
-      (define :name "Liar (Bobcat 68020)")
-      (define :version)
-      (define :modification)
-
-      (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.8 1986/12/13 18:10:01 cph Exp $"
-	(lambda (filename version date time author state)
-	  (set! :version (car version))
-	  (set! :modification (cadr version))))))
-
-  (add-system! compiler-system))
-
 (load-system system-global-environment
 	     'COMPILER-PACKAGE
 	     '(SYSTEM-GLOBAL-ENVIRONMENT)
@@ -132,6 +117,21 @@
 
 	       ))
 
+(in-package compiler-package
+
+  (define compiler-system
+    (make-environment
+      (define :name "Liar (Bobcat 68020)")
+      (define :version)
+      (define :modification)
+
+      (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.9 1986/12/15 05:48:57 cph Exp $"
+	(lambda (filename version date time author state)
+	  (set! :version (car version))
+	  (set! :modification (cadr version))))))
+
+  (add-system! compiler-system))
+
 (%ge compiler-package)
 (%gst (access compiler-syntax-table compiler-package))
 (%gst (access compiler-syntax-table compiler-package))
\ No newline at end of file