Generalize rule for `cons-closure' so that it handles more types of

target expressions.

diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index c7e3b004e2e4dd81799dc64a7b9cc6210e9733c9..6e2494002fa85bd68a1cfd70ff175bdf4ac64f3d 100644 (file)
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.17 1988/11/04 10:58:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.18 1988/11/08 12:36:18 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -211,24 +211,6 @@ MIT in each case. |#
 (define-integrable (cc-commutative? cc)
   (memq cc '(T F NE EQ)))
 
-(define (expression->machine-register! expression register)
-  (let ((target (register-reference register)))
-    (let ((result
-          (case (car expression)
-            ((REGISTER)
-             (load-machine-register! (rtl:register-number expression)
-                                     register))
-            ((OFFSET)
-             (LAP (MOV L ,(offset->indirect-reference! expression) ,target)))
-            ((CONSTANT)
-             (LAP ,(load-constant (rtl:constant-value expression) target)))
-            ((UNASSIGNED)
-             (LAP ,(load-non-pointer type-code:unassigned 0 target)))
-            (else
-             (error "Unknown expression type" (car expression))))))
-      (delete-machine-register! register)
-      result)))
-
 (define-integrable (effective-address/data&alterable? ea)
   (memq (lap:ea-keyword ea) '(D @D @A @A+ @-A @AO @DO @AOX W L)))
 
@@ -300,6 +282,26 @@ MIT in each case. |#
            (LAP)
            (LAP ,(instruction-gen)
                 ,@(loop (-1+ n)))))))
+\f
+;;;; Expression-Generic Operations
+
+(define (expression->machine-register! expression register)
+  (let ((target (register-reference register)))
+    (let ((result
+          (case (car expression)
+            ((REGISTER)
+             (load-machine-register! (rtl:register-number expression)
+                                     register))
+            ((OFFSET)
+             (LAP (MOV L ,(offset->indirect-reference! expression) ,target)))
+            ((CONSTANT)
+             (LAP ,(load-constant (rtl:constant-value expression) target)))
+            ((UNASSIGNED)
+             (LAP ,(load-non-pointer type-code:unassigned 0 target)))
+            (else
+             (error "Unknown expression type" (car expression))))))
+      (delete-machine-register! register)
+      result)))
 
 (define (put-type-in-ea type-code ea)
   (cond ((effective-address/data-register? ea)
@@ -309,6 +311,27 @@ MIT in each case. |#
         (LAP (MOV B (& ,type-code) ,ea)))
        (else
         (error "PUT-TYPE-IN-EA: Illegal effective-address" ea))))
+
+(define (standard-target-expression? target)
+  (or (rtl:offset? target)
+      (rtl:free-push? target)
+      (rtl:stack-push? target)))
+
+(define (rtl:free-push? expression)
+  (and (rtl:post-increment? expression)
+       (interpreter-free-pointer? (rtl:post-increment-register expression))
+       (= 1 (rtl:post-increment-number expression))))
+
+(define (rtl:stack-push? expression)
+  (and (rtl:pre-increment? expression)
+       (interpreter-stack-pointer? (rtl:pre-increment-register expression))
+       (= -1 (rtl:pre-increment-number expression))))
+
+(define (standard-target-expression->ea target)
+  (cond ((rtl:offset? target) (offset->indirect-reference! target))
+       ((rtl:free-push? target) (INST-EA (@A+ 5)))
+       ((rtl:stack-push? target) (INST-EA (@-A 7)))
+       (else (error "STANDARD-TARGET->EA: Not a standard target" target))))
 \f
 ;;;; Fixnum Operators
 

diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 4fb64e1ed6b83a365151d016e03fcbaa51644ead..3ac298dc9eaf422900e4e8d8ab96673220c718d9 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.13 1988/11/08 11:11:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.14 1988/11/08 12:36:58 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -396,13 +396,26 @@ MIT in each case. |#
 (define-rule statement
   (ASSIGN (REGISTER (? target))
          (CONS-POINTER (CONSTANT (? type))
-                       (CONS-CLOSURE (ENTRY:PROCEDURE (? internal-label))
+                       (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
                                      (? min) (? max) (? size))))
   (QUALIFIER (pseudo-register? target))
-  (let ((temporary (reference-temporary-register! 'ADDRESS))
-       (target (reference-target-alias! target 'DATA)))
+  (generate/cons-closure (reference-target-alias! target 'DATA)
+                        type procedure-label min max size))
+
+(define-rule statement
+  (ASSIGN (? target)
+         (CONS-POINTER (CONSTANT (? type))
+                       (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+                                     (? min) (? max) (? size))))
+  (QUALIFIER (standard-target-expression? target))
+  (let ((temporary (reference-temporary-register! 'DATA)))
+    (LAP ,@(generate/cons-closure temporary type procedure-label min max size)
+        (MOV L ,temporary ,(standard-target-expression->ea target)))))
+
+(define (generate/cons-closure target type procedure-label min max size)
+  (let ((temporary (reference-temporary-register! 'ADDRESS)))
     (LAP (LEA (@PCR ,(rtl-procedure/external-label
-                     (label->object internal-label)))
+                     (label->object procedure-label)))
              ,temporary)
         ,(load-non-pointer (ucode-type manifest-closure)
                            (+ 3 size)