- Update to match change in RTL introduced to improve array indexing.

- Add floating-vector support.
- Add top-level code compression support.

diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg
index 556119691385c36b5185b2a46a3b58dd338ba3df..77ec5cf8f4b14b4c800a1405c3ecdf29ae6f5b1e 100644 (file)
--- a/v7/src/compiler/machines/bobcat/compiler.pkg
+++ b/v7/src/compiler/machines/bobcat/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compiler.pkg,v 1.43 1993/02/25 02:16:04 gjr Exp $
+$Id: compiler.pkg,v 1.44 1993/07/06 00:56:22 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -511,7 +511,8 @@ MIT in each case. |#
   (files "rtlgen/rgcomb")
   (parent (compiler rtl-generator))
   (export (compiler rtl-generator)
-         generate/combination)
+         generate/combination
+         rtl:bump-closure)
   (export (compiler rtl-generator combination/inline)
          generate/invocation-prefix))
 

diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 5f3a99b9fe7f38c80b8cfbf6854d4e64b3fc2a80..d3d5c21198426138ff5762934c92c3a9546472e9 100644 (file)
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 4.47 1993/01/13 00:18:46 cph Exp $
+$Id: lapgen.scm,v 4.48 1993/07/06 00:56:23 gjr Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -350,9 +350,134 @@ MIT in each case. |#
       (register-alias register 'DATA)
       (load-alias-register! register 'ADDRESS)))
 
-(define (offset->indirect-reference! offset)
-  (indirect-reference! (rtl:register-number (rtl:offset-base offset))
-                      (rtl:offset-number offset)))
+(define (rtl:simple-byte-offset? expression)
+  (and (rtl:byte-offset? expression)
+       (let ((base (rtl:byte-offset-base expression))
+            (offset (rtl:byte-offset-offset expression)))
+        (if (rtl:register? base)
+            (or (rtl:machine-constant? offset)
+                (rtl:register? offset))
+            (and (rtl:byte-offset-address? base)
+                 (rtl:machine-constant? offset)
+                 (rtl:register? (rtl:byte-offset-address-base base))
+                 (rtl:register? (rtl:byte-offset-address-offset base)))))
+       expression))
+
+(define (byte-offset->reference! offset)
+  ;; OFFSET must be a simple byte offset
+  (let ((base (rtl:byte-offset-base offset))
+       (offset (rtl:byte-offset-offset offset)))
+    (cond ((not (rtl:register? base))
+          (indexed-ea (rtl:register-number
+                       (rtl:byte-offset-address-base base))
+                      (rtl:register-number
+                       (rtl:byte-offset-address-offset base))
+                      1
+                      (rtl:machine-constant-value offset)))
+         ((rtl:machine-constant? offset)
+          (indirect-byte-reference! (rtl:register-number base)
+                                    (rtl:machine-constant-value offset)))
+         (else
+          (indexed-ea (rtl:register-number base)
+                      (rtl:register-number offset)
+                      1
+                      0)))))
+\f
+(define (rtl:simple-offset? expression)
+  (and (rtl:offset? expression)
+       (let ((base (rtl:offset-base expression))
+            (offset (rtl:offset-offset expression)))
+        (if (rtl:register? base)
+            (or (rtl:machine-constant? offset)
+                (rtl:register? offset))
+            (and (rtl:offset-address? base)
+                 (rtl:machine-constant? offset)
+                 (rtl:register? (rtl:offset-address-base base))
+                 (rtl:register? (rtl:offset-address-offset base)))))
+       expression))
+
+(define (offset->reference! offset)
+  ;; OFFSET must be a simple offset
+  (let ((base (rtl:offset-base offset))
+       (offset (rtl:offset-offset offset)))
+    (cond ((not (rtl:register? base))
+          (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+                      (rtl:register-number (rtl:offset-address-offset base))
+                      4
+                      (* 4 (rtl:machine-constant-value offset))))
+         ((rtl:machine-constant? offset)
+          (indirect-reference! (rtl:register-number base)
+                               (rtl:machine-constant-value offset)))
+         (else
+          (indexed-ea (rtl:register-number base)
+                      (rtl:register-number offset)
+                      4
+                      0)))))
+
+(define (offset->reference!/char offset)
+  ;; OFFSET must be a simple offset
+  (let ((base (rtl:offset-base offset))
+       (offset (rtl:offset-offset offset)))
+    (cond ((not (rtl:register? base))
+          (indexed-ea (rtl:register-number (rtl:offset-address-base base))
+                      (rtl:register-number (rtl:offset-address-offset base))
+                      4
+                      (+ 3 (* 4 (rtl:machine-constant-value offset)))))
+         ((rtl:machine-constant? offset)
+          (indirect-byte-reference!
+           (rtl:register-number base)
+           (+ 3 (* 4 (rtl:machine-constant-value offset)))))
+         (else
+          (indexed-ea (rtl:register-number base)
+                      (rtl:register-number offset)
+                      4
+                      3)))))
+\f
+(define (rtl:simple-float-offset? expression)
+  (and (rtl:float-offset? expression)
+       (let ((base (rtl:float-offset-base expression))
+            (offset (rtl:float-offset-offset expression)))
+        (and (or (rtl:machine-constant? offset)
+                 (rtl:register? offset))
+             (or (rtl:register? base)
+                 (and (rtl:offset-address? base)
+                      (rtl:register? (rtl:offset-address-base base))
+                      (rtl:machine-constant?
+                       (rtl:offset-address-offset base))))))
+       expression))
+
+(define (float-offset->reference! offset)
+  ;; OFFSET must be a simple float offset
+  (let ((base (rtl:float-offset-base offset))
+       (offset (rtl:float-offset-offset offset)))
+    (cond ((not (rtl:register? base))
+          (let ((base*
+                 (rtl:register-number (rtl:offset-address-base base)))
+                (w-offset
+                 (rtl:machine-constant-value
+                  (rtl:offset-address-offset base))))
+            (if (rtl:machine-constant? offset)
+                (indirect-reference!
+                 base*
+                 (+ (* 2 (rtl:machine-constant-value offset))
+                    w-offset))
+                (indexed-ea base*
+                            (rtl:register-number offset)
+                            8
+                            (* 4 w-offset)))))
+         ((rtl:machine-constant? offset)
+          (indirect-reference! (rtl:register-number base)
+                               (* 2 (rtl:machine-constant-value offset))))
+         (else
+          (indexed-ea (rtl:register-number base)
+                      (rtl:register-number offset)
+                      8
+                      0)))))
+
+(define (indexed-ea base index scale offset)
+  (let ((base (allocate-indirection-register! base))
+       (index (preferred-data-register-reference index)))
+    (INST-EA (@AOXS ,(->areg base) ,offset (,index L ,scale)))))
 
 (define (indirect-reference! register offset)
   (offset-reference (allocate-indirection-register! register) offset))
@@ -362,19 +487,7 @@ MIT in each case. |#
 
 (define-integrable (allocate-indirection-register! register)
   (load-alias-register! register 'ADDRESS))
-
-#|
-
-;; *** This is believed to be a fossil. ***
-;; Left here until the first compilation to make sure that it really is.
-;; Can be removed the next time it is seen.
-
-(define (code-object-label-initialize code-object)
-  code-object
-  false)
-
-|#
-
+\f
 (define (generate-n-times n limit instruction-gen with-counter)
   (if (> n limit)
       (let ((loop (generate-label 'LOOP)))
@@ -390,17 +503,21 @@ MIT in each case. |#
            (LAP ,@(instruction-gen)
                 ,@(loop (-1+ n)))))))
 
+#|
+
+;;; These seem to be fossils --- GJR 7/1/1993
+
 (define (standard-target-expression? target)
-  (or (and (rtl:offset? target)
-          (rtl:register? (rtl:offset-base target)))
+  (or (rtl:simple-offset? target)
       (rtl:free-push? target)
       (rtl:stack-push? target)))
 
 (define (standard-target-expression->ea target)
-  (cond ((rtl:offset? target) (offset->indirect-reference! target))
+  (cond ((rtl:offset? target) (offset->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))))
+|#
 
 (define (rtl:free-push? expression)
   (and (rtl:post-increment? expression)
@@ -451,7 +568,7 @@ MIT in each case. |#
                   (operate-on-machine-target target)
                   (use-temporary target))))))
        ((OFFSET)
-       (use-temporary (offset->indirect-reference! target)))
+       (use-temporary (offset->reference! target)))
        (else
        (error "Illegal machine target" target)))))
 
@@ -466,10 +583,9 @@ MIT in each case. |#
       (operate-on-target (reference-target-alias! target type)))
     operate-on-target))
 
-(define (machine-operation-target? target)
-  (or (rtl:register? target)
-      (and (rtl:offset? target)
-          (rtl:register? (rtl:offset-base target)))))
+(define (machine-operation-target? expression)
+  (or (rtl:register? expression)
+      (rtl:simple-offset? expression)))
 \f
 (define (two-arg-register-operation
         operate commutative?

diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm
index 64095888e51a0348e69c5781f2e000ed358fc170..b2af96768a9b01de41de11554eaf22aea6c918c8 100644 (file)
--- a/v7/src/compiler/machines/bobcat/machin.scm
+++ b/v7/src/compiler/machines/bobcat/machin.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: machin.scm,v 4.30 1993/06/29 22:23:16 gjr Exp $
+$Id: machin.scm,v 4.31 1993/07/06 00:56:25 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -288,12 +288,15 @@ MIT in each case. |#
        (= (rtl:register-number expression) regnum:return-value)))
 
 (define (interpreter-environment-register)
-  (rtl:make-offset (interpreter-regs-pointer) 3))
+  (rtl:make-offset (interpreter-regs-pointer)
+                  (rtl:make-machine-constant 3)))
 
 (define (interpreter-environment-register? expression)
   (and (rtl:offset? expression)
        (interpreter-regs-pointer? (rtl:offset-base expression))
-       (= 3 (rtl:offset-number expression))))
+       (let ((offset (rtl:offset-offset expression)))
+        (and (rtl:machine-constant? offset)
+             (= 3 (rtl:machine-constant-value offset))))))
 
 (define (interpreter-free-pointer)
   (rtl:make-machine-register regnum:free-pointer))
@@ -381,7 +384,8 @@ MIT in each case. |#
          ASSIGNMENT-CACHE
          VARIABLE-CACHE
          OFFSET-ADDRESS
-         BYTE-OFFSET-ADDRESS)
+         BYTE-OFFSET-ADDRESS
+         FLOAT-OFFSET-ADDRESS)
         3)
        ((CONS-POINTER)
         (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
@@ -398,4 +402,4 @@ MIT in each case. |#
 (define compiler:primitives-with-no-open-coding
   '(DIVIDE-FIXNUM GCD-FIXNUM &/
     VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS
-    FLOATING-VECTOR-REF FLOATING-VECTOR-SET!))
\ No newline at end of file
+    FLONUM-CEILING FLONUM-FLOOR FLONUM-ATAN2))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index f3c360b35fd998fd8775714a5e502d0894148c39..8dff8745cebd939c4e6707926aa1e07ccfc2a6c9 100644 (file)
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.88 1991/10/25 06:49:46 cph Exp $
+$Id: make.scm-68040,v 4.89 1993/07/06 00:56:26 gjr Exp $
 
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,6 +37,8 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 ((load "base/make") "Motorola MC68040")
+(set! (access compiler:compress-top-level? (->environment '(compiler)))
+      true)
 ((environment-lookup (->environment '(COMPILER LAP-SYNTAXER))
                     'MC68K/TOGGLE-CLOSURE-FORMAT)
  'MC68040)
\ No newline at end of file

diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm
index 50d53de0f2a5a0bfd8cc55dcc5fd1af25c1d764a..8f139c620384c5ea01d41d7efa276bfdee9be3f9 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules1.scm
+++ b/v7/src/compiler/machines/bobcat/rules1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.37 1992/07/05 14:20:36 jinx Exp $
+$Id: rules1.scm,v 4.38 1993/07/06 00:56:27 gjr Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -50,32 +50,94 @@ MIT in each case. |#
   (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
   (assign-register->register target source))
 
+(define (assign-register->register target source)
+  (standard-move-to-target! source (register-type target) target)
+  (LAP))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (OFFSET-ADDRESS (REGISTER (? base))
+                         (REGISTER (? index))))
+  (load-indexed-address target base index 4 0))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+                              (REGISTER (? index))))
+  (load-indexed-address target base index 1 0))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+                               (REGISTER (? index))))
+  (load-indexed-address target base index 8 0))
+
+(define-integrable (->areg reg)
+  (- reg 8))
+
+(define (load-indexed-address target base index scale offset)
+  (let ((load-address
+        (lambda (get-target-reference)
+          (let ((ea (indexed-ea base index scale offset)))
+            (LAP (LEA ,ea ,(get-target-reference)))))))
+    (cond ((or (not (machine-register? target))
+              (eq? (register-type target) 'ADDRESS))
+          (load-address
+           (lambda ()
+             (target-register-reference target 'ADDRESS))))
+         ((eq? (register-type target) 'DATA)
+          (let ((temp
+                 (register-reference
+                  (allocate-temporary-register! 'ADDRESS))))
+            (LAP ,@(load-address (lambda () temp))
+                 (MOV L ,temp ,(register-reference target)))))
+         (else
+          (error "load-indexed-address: Unknown register type"
+                 target)))))
+
+(define (target-register-reference target type)
+  (delete-dead-registers!)
+  (register-reference
+   (or (register-alias target type)
+       (allocate-alias-register! target type))))
+\f
 (define-rule statement
-  (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER (? source)) (? n)))
+  (ASSIGN (REGISTER (? target))
+         (OFFSET-ADDRESS (REGISTER (? source))
+                         (MACHINE-CONSTANT (? n))))
   (load-static-link target source (* 4 n) false))
 
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+                              (MACHINE-CONSTANT (? n))))
+  (load-static-link target source n false))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (FLOAT-OFFSET-ADDRESS (REGISTER (? source))
+                               (MACHINE-CONSTANT (? n))))
+  (load-static-link target source (* 8 n) false))
+
 (define-rule statement
   ;; This is an intermediate rule -- not intended to produce code.
   (ASSIGN (REGISTER (? target))
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+                       (OFFSET-ADDRESS (REGISTER (? source))
+                                       (MACHINE-CONSTANT (? n)))))
   (load-static-link target source (* 4 n)
     (lambda (target)
       (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
 
-(define-rule statement
-  (ASSIGN (REGISTER (? target))
-         (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n)))
-  (load-static-link target source n false))
-
 (define-rule statement
   (ASSIGN (REGISTER (? target))
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+                       (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+                                            (MACHINE-CONSTANT (? n)))))
   (load-static-link target source n
     (lambda (target)
       (LAP (OR UL (& ,(make-non-pointer-literal type 0)) ,target)))))
-\f
+
 (define (load-static-link target source n suffix)
   (cond ((and (not suffix) (zero? n))
         (assign-register->register target source))
@@ -103,6 +165,7 @@ MIT in each case. |#
             (else
              (error "load-static-link: Unknown register type"
                     (register-type target))))))
+\f
        (else
         (let ((non-reusable
                (cond ((not suffix)
@@ -148,11 +211,7 @@ MIT in each case. |#
                             (suffix (register-reference reusable-alias))
                             (LAP))))
                non-reusable))))))
-
-(define (assign-register->register target source)
-  (standard-move-to-target! source (register-type target) target)
-  (LAP))
-
+\f
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
   ;; See if we can reuse a source alias, because `object->type' can
@@ -172,7 +231,7 @@ MIT in each case. |#
            (let ((source (register-reference source)))
              (object->type source source)))
          no-reuse))))
-\f
+
 (define-rule statement
   (ASSIGN (REGISTER (? target))
          (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
@@ -313,96 +372,101 @@ MIT in each case. |#
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset))))
-  (let ((source (indirect-reference! address offset)))
+         (? expression rtl:simple-offset?))
+  (let ((source (offset->reference! expression)))
+    (LAP (MOV L ,source ,(standard-target-reference target)))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
+  (LAP (MOV L (@A+ 7) ,(standard-target-reference target))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (OBJECT->TYPE (? expression rtl:simple-offset?)))
+  (let ((source (offset->reference! expression)))
     (delete-dead-registers!)
     (object->type source (reference-target-alias! target 'DATA))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (OBJECT->DATUM (OFFSET (REGISTER (? address)) (? offset))))
-  (convert-object/offset->register target address offset object->datum))
+         (OBJECT->DATUM (? expression rtl:simple-offset?)))
+  (convert-object/offset->register target expression object->datum))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset))))
-  (convert-object/offset->register target address offset object->address))
+         (OBJECT->ADDRESS (? expression rtl:simple-offset?)))
+  (convert-object/offset->register target expression object->address))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
          (ADDRESS->FIXNUM
-          (OBJECT->ADDRESS (OFFSET (REGISTER (? address)) (? offset)))))
-  (convert-object/offset->register target address offset address->fixnum))
+          (OBJECT->ADDRESS (? expression rtl:simple-offset?))))
+  (convert-object/offset->register target expression address->fixnum))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
-  (convert-object/offset->register target address offset object->fixnum))
+         (OBJECT->FIXNUM (? expression rtl:simple-offset?)))
+  (convert-object/offset->register target expression object->fixnum))
 
-(define (convert-object/offset->register target address offset conversion)
-  (let ((source (indirect-reference! address offset)))
+(define (convert-object/offset->register target expression conversion)
+  (let ((source (offset->reference! expression)))
     (delete-dead-registers!)
     (let ((target (reference-target-alias! target 'DATA)))
       (LAP (MOV L ,source ,target)
           ,@(conversion target)))))
+\f
+;;;; Transfers to Memory
 
 (define-rule statement
-  (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
-  (let ((source (indirect-reference! address offset)))
-    (LAP (MOV L ,source ,(standard-target-reference target)))))
+  (ASSIGN (? expression rtl:simple-offset?)
+         (REGISTER (? r)))
+  (QUALIFIER (register-value-class=word? r))
+  (LAP (MOV L
+           ,(standard-register-reference r false true)
+           ,(offset->reference! expression))))
 
 (define-rule statement
-  (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
-  (LAP (MOV L (@A+ 7) ,(standard-target-reference target))))
-\f
-;;;; Transfers to Memory
+  (ASSIGN (? expression rtl:simple-offset?)
+         (POST-INCREMENT (REGISTER 15) 1))
+  (LAP (MOV L (@A+ 7) ,(offset->reference! expression))))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+  (ASSIGN (? expression rtl:simple-offset?)
          (CONSTANT (? object)))
-  (load-constant object (indirect-reference! a n)))
+  (load-constant object (offset->reference! expression)))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+  (ASSIGN (? expression rtl:simple-offset?)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
                        (MACHINE-CONSTANT (? datum))))
-  (load-non-pointer type datum (indirect-reference! a n)))
-
-(define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r)))
-  (QUALIFIER (register-value-class=word? r))
-  (LAP (MOV L
-           ,(standard-register-reference r false true)
-           ,(indirect-reference! a n))))
-
-(define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
-         (POST-INCREMENT (REGISTER 15) 1))
-  (LAP (MOV L (@A+ 7) ,(indirect-reference! a n))))
+  (load-non-pointer type datum (offset->reference! expression)))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
-         (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
-  (let ((target (indirect-reference! address offset)))
+  (ASSIGN (? expression rtl:simple-offset?)
+         (CONS-POINTER (MACHINE-CONSTANT (? type))
+                       (REGISTER (? datum))))
+  (let ((target (offset->reference! expression)))
     (LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target)
         ,@(memory-set-type type target))))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+  (ASSIGN (? expression rtl:simple-offset?)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+                       (OFFSET-ADDRESS (REGISTER (? source))
+                                       (MACHINE-CONSTANT (? n)))))
   (let ((temp (reference-temporary-register! 'ADDRESS))
-       (target (indirect-reference! address offset)))
+       (target (offset->reference! expression)))
     (LAP (LEA ,(indirect-reference! source n) ,temp)
         (MOV L ,temp ,target)
         ,@(memory-set-type type target))))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+  (ASSIGN (? expression rtl:simple-offset?)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (BYTE-OFFSET-ADDRESS (REGISTER (? source)) (? n))))
+                       (BYTE-OFFSET-ADDRESS (REGISTER (? source))
+                                            (MACHINE-CONSTANT (? n)))))
   (let ((temp (reference-temporary-register! 'ADDRESS))
-       (target (indirect-reference! address offset)))
+       (target (offset->reference! expression)))
     (LAP (LEA ,(indirect-byte-reference! source n) ,temp)
         (MOV L ,temp ,target)
         ,@(memory-set-type type target))))
@@ -410,12 +474,13 @@ MIT in each case. |#
 ;; Common case that can be done cheaply:
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
-         (BYTE-OFFSET-ADDRESS (OFFSET (REGISTER (? address)) (? offset))
-                              (? n)))
+  (ASSIGN (? expression0 rtl:simple-offset?)
+         (BYTE-OFFSET-ADDRESS (? expression rtl:simple-offset?)
+                              (MACHINE-CONSTANT (? n))))
+  (QUALIFIER (equal? expression0 expression))
   (if (zero? n)
       (LAP)
-      (let ((target (indirect-reference! address offset)))
+      (let ((target (offset->reference! expression)))
        (cond ((<= 1 n 8)
               (LAP (ADDQ L (& ,n) ,target)))
              ((<= -8 n -1)
@@ -428,31 +493,36 @@ MIT in each case. |#
               (LAP (ADD L (& ,n) ,target)))))))
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? address)) (? offset))
+  (ASSIGN (? expression rtl:simple-offset?)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
                        (ENTRY:PROCEDURE (? label))))
   (let ((temp (reference-temporary-register! 'ADDRESS))
-       (target (indirect-reference! address offset)))
+       (target (offset->reference! expression)))
     (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
              ,temp)
         (MOV L ,temp ,target)
         ,@(memory-set-type type target))))
 
-(define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
-         (OFFSET (REGISTER (? a1)) (? n1)))
-  (if (and (= a0 a1) (= n0 n1))
-      (LAP)
-      (let ((source (indirect-reference! a1 n1)))
-       (LAP (MOV L ,source ,(indirect-reference! a0 n0))))))
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
 
 (define-rule statement
-  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+  (ASSIGN (? expression rtl:simple-offset?)
          (FIXNUM->OBJECT (REGISTER (? source))))
-  (let ((target (indirect-reference! a n)))
+  (let ((target (offset->reference! expression)))
     (let ((temporary (standard-move-to-temporary! source 'DATA)))
       (LAP ,@(fixnum->object temporary)
           (MOV L ,temporary ,target)))))
+|#
+
+(define-rule statement
+  (ASSIGN (? expression0 rtl:simple-offset?)
+         (? expression1 rtl:simple-offset?))
+  (if (equal? expression0 expression1)
+      (LAP)
+      (LAP (MOV L ,(offset->reference! expression1)
+               ,(offset->reference! expression0)))))
 \f
 ;;;; Consing
 
@@ -472,8 +542,13 @@ MIT in each case. |#
   (LAP (MOV L ,(standard-register-reference r false true) (@A+ 5))))
 
 (define-rule statement
-  (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
-  (LAP (MOV L ,(indirect-reference! r n) (@A+ 5))))
+  (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
+         (? expression rtl:simple-offset?))
+  (LAP (MOV L ,(offset->reference! expression) (@A+ 5))))
+
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
 
 (define-rule statement
   (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
@@ -481,6 +556,7 @@ MIT in each case. |#
   (let ((temporary (standard-move-to-temporary! r 'DATA)))
     (LAP ,@(fixnum->object temporary)
         (MOV L ,temporary (@A+ 5)))))
+|#
 
 (define-rule statement
   ;; This pops the top of stack into the heap
@@ -527,20 +603,27 @@ MIT in each case. |#
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+                       (OFFSET-ADDRESS (REGISTER (? r))
+                                       (MACHINE-CONSTANT (? n)))))
   (LAP (PEA ,(indirect-reference! r n))
        ,@(memory-set-type type (INST-EA (@A 7)))))
 
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
+                       (BYTE-OFFSET-ADDRESS (REGISTER (? r))
+                                            (MACHINE-CONSTANT (? n)))))
   (LAP (PEA ,(indirect-byte-reference! r n))
        ,@(memory-set-type type (INST-EA (@A 7)))))
 
 (define-rule statement
-  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
-  (LAP (MOV L ,(indirect-reference! r n) (@-A 7))))
+  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+         (? expression rtl:simple-offset?))
+  (LAP (MOV L ,(offset->reference! expression) (@-A 7))))
+
+#|
+;; This is no better than assigning to a register and then assigning
+;; from the register
 
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
@@ -548,6 +631,7 @@ MIT in each case. |#
   (let ((temporary (standard-move-to-temporary! r 'DATA)))
     (LAP ,@(fixnum->object temporary)
         (MOV L ,temporary (@-A 7)))))
+|#
 \f
 ;;;; Fixnum Operations
 
@@ -653,21 +737,21 @@ MIT in each case. |#
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
                         (OBJECT->FIXNUM (CONSTANT 4))
-                        (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+                        (OBJECT->FIXNUM (? expression rtl:simple-offset?))
                         (? overflow?)))
   (QUALIFIER (machine-operation-target? target))
   overflow?                            ; ignored
-  (convert-index->fixnum/offset target r n))
+  (convert-index->fixnum/offset target expression))
 
 (define-rule statement
   (ASSIGN (? target)
          (FIXNUM-2-ARGS MULTIPLY-FIXNUM
-                        (OBJECT->FIXNUM (OFFSET (REGISTER (? r)) (? n)))
+                        (OBJECT->FIXNUM (? expression rtl:simple-offset?))
                         (OBJECT->FIXNUM (CONSTANT 4))
                         (? overflow?)))
   (QUALIFIER (machine-operation-target? target))
   overflow?                            ; ignored
-  (convert-index->fixnum/offset target r n))
+  (convert-index->fixnum/offset target expression))
 
 ;;; end (IF (<= SCHEME-TYPE-WIDTH 6) ...)
 ))
@@ -680,8 +764,8 @@ MIT in each case. |#
     (lambda (target)
       (LAP (AS L L (& ,(+ scheme-type-width 2)) ,target)))))
 
-(define (convert-index->fixnum/offset target address offset)
-  (let ((source (indirect-reference! address offset)))
+(define (convert-index->fixnum/offset target expression)
+  (let ((source (offset->reference! expression)))
     (reuse-and-operate-on-machine-target! 'DATA target
       (lambda (target)
        (LAP (MOV L ,source ,target)
@@ -698,7 +782,7 @@ MIT in each case. |#
       (LAP (MOV L (A 5) ,target)
           (OR L (& ,(make-non-pointer-literal (ucode-type flonum) 0)) ,target)
           ,@(load-non-pointer (ucode-type manifest-nm-vector)
-                              flonum-size
+                              2
                               (INST-EA (@A+ 5)))
           (FMOVE D ,source (@A+ 5))))))
 
@@ -706,12 +790,11 @@ MIT in each case. |#
   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
   (let ((source (standard-move-to-temporary! source 'DATA))
        (temp (allocate-temporary-register! 'ADDRESS)))
-    (delete-dead-registers!)
     (LAP ,@(object->address source)
         (MOV L ,source ,(register-reference temp))
         (FMOVE D
                ,(offset-reference temp 1)
-               ,(reference-target-alias! target 'FLOAT)))))
+               ,(target-float-reference target)))))  
 
 (define-rule statement
   (ASSIGN (? target)
@@ -757,56 +840,80 @@ MIT in each case. |#
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (CHAR->ASCII (OFFSET (REGISTER (? address)) (? offset))))
+         (CHAR->ASCII (REGISTER (? source))))
   (load-char-into-register 0
-                          (indirect-char/ascii-reference! address offset)
+                          (reference-alias-register! source 'DATA)
                           target))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (CHAR->ASCII (REGISTER (? source))))
+         (CHAR->ASCII (? expression rtl:simple-offset?)))
   (load-char-into-register 0
-                          (reference-alias-register! source 'DATA)
+                          (offset->reference!/char expression)
                           target))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
-         (BYTE-OFFSET (REGISTER (? address)) (? offset)))
+         (? expression rtl:simple-byte-offset?))
   (load-char-into-register 0
-                          (indirect-byte-reference! address offset)
+                          (byte-offset->reference! expression)
                           target))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
          (CONS-POINTER (MACHINE-CONSTANT (? type))
-                       (BYTE-OFFSET (REGISTER (? address)) (? offset))))
+                       (? expression rtl:simple-byte-offset?)))
   (load-char-into-register type
-                          (indirect-byte-reference! address offset)
+                          (byte-offset->reference! expression)
                           target))
 
 (define-rule statement
-  (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
-         (CHAR->ASCII (CONSTANT (? character))))
-  (LAP (MOV B
-           (& ,(char->signed-8-bit-immediate character))
-           ,(indirect-byte-reference! address offset))))
+  (ASSIGN (? expression rtl:simple-byte-offset?)
+         (REGISTER (? source)))
+  (LAP (MOV B ,(coerce->any/byte-reference source)
+           ,(byte-offset->reference! expression))))
 
 (define-rule statement
-  (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
-         (REGISTER (? source)))
-  (let ((source (coerce->any/byte-reference source)))
-    (let ((target (indirect-byte-reference! address offset)))
-      (LAP (MOV B ,source ,target)))))
+  (ASSIGN (? expression rtl:simple-byte-offset?)
+         (CHAR->ASCII (CONSTANT (? character))))
+  (LAP (MOV B (& ,(char->signed-8-bit-immediate character))
+           ,(byte-offset->reference! expression))))
 
 (define-rule statement
-  (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
+  (ASSIGN (? expression rtl:simple-byte-offset?)
          (CHAR->ASCII (REGISTER (? source))))
-  (let ((source (coerce->any/byte-reference source)))
-    (let ((target (indirect-byte-reference! address offset)))
-      (LAP (MOV B ,source ,target)))))
+  (LAP (MOV B ,(coerce->any/byte-reference source)
+           ,(byte-offset->reference! expression))))
 
 (define-rule statement
-  (ASSIGN (BYTE-OFFSET (REGISTER (? target)) (? target-offset))
-         (CHAR->ASCII (OFFSET (REGISTER (? source)) (? source-offset))))
-  (let ((source (indirect-char/ascii-reference! source source-offset)))
-    (LAP (MOV B ,source ,(indirect-byte-reference! target target-offset)))))
\ No newline at end of file
+  (ASSIGN (? expression0 rtl:simple-byte-offset?)
+         (CHAR->ASCII (? expression1 rtl:simple-offset?)))
+  (LAP (MOV B ,(offset->reference!/char expression1)
+           ,(byte-offset->reference! expression0))))
+
+(define-rule statement
+  (ASSIGN (? expression0 rtl:simple-byte-offset?)
+         (? expression1 rtl:simple-byte-offset?))
+  (LAP (MOV B ,(byte-offset->reference! expression1)
+           ,(byte-offset->reference! expression0))))
+\f
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (? expression rtl:simple-float-offset?))
+  (let ((ea (float-offset->reference! expression)))
+    (LAP (FMOVE D ,ea ,(target-float-reference target)))))
+
+(define-rule statement
+  (ASSIGN (? expression rtl:simple-float-offset?)
+         (REGISTER (? source)))
+  (LAP (FMOVE D ,(source-float-reference source)
+             ,(float-offset->reference! expression))))
+
+(define (target-float-reference target)
+  (delete-dead-registers!)
+  (reference-target-alias! target 'FLOAT))
+
+(define (source-float-reference source)
+  (register-reference
+   (or (register-alias source 'FLOAT)
+       (allocate-alias-register! source 'FLOAT))))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm
index 1a88e9578b9512d9728f9ce4fe77bdd2286f1488..6de191290cf37dc4fe36978fc536ef8c15bf1a3a 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules2.scm
+++ b/v7/src/compiler/machines/bobcat/rules2.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.13 1992/07/05 14:20:58 jinx Exp $
+$Id: rules2.scm,v 4.14 1993/07/06 00:56:28 gjr Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,17 +38,18 @@ MIT in each case. |#
 (declare (usual-integrations))
 \f
 (define (predicate/memory-operand? expression)
-  (or (and (rtl:offset? expression)
-          (rtl:register? (rtl:offset-base expression)))
+  (or (rtl:simple-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))
+    ((OFFSET)
+     (offset->reference! expression))
     ((POST-INCREMENT) (INST-EA (@A+ 7)))
-    (else (error "Illegal memory operand" expression))))
+    (else
+     (error "Illegal memory operand" expression))))
 
 (define (compare/register*register register-1 register-2 cc)
   (let ((finish
@@ -125,10 +126,10 @@ MIT in each case. |#
                              type))))))
 
 (define-rule predicate
-  (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
+  (TYPE-TEST (OBJECT->TYPE (? expression rtl:simple-offset?))
             (? type))
   (set-standard-branches! 'EQ)
-  (let ((source (indirect-reference! address offset)))
+  (let ((source (offset->reference! expression)))
     (cond ((= scheme-type-width 8)
           (test-byte type source))
          ((and (zero? type) use-68020-instructions?)

diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 0e205db94e468cc59edda7a333c7ed01518ba526..155190c66cc85f0c26193531c1ae4c280f8985a2 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 4.38 1993/02/19 17:48:51 cph Exp $
+$Id: rules3.scm,v 4.39 1993/07/06 00:56:29 gjr Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -233,8 +233,10 @@ MIT in each case. |#
         ,@(generate/move-frame-up* frame-size temp))))
 
 (define-rule statement
-  (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
-                                  (OFFSET-ADDRESS (REGISTER 15) (? offset)))
+  (INVOCATION-PREFIX:MOVE-FRAME-UP
+   (? frame-size)
+   (OFFSET-ADDRESS (REGISTER 15)
+                  (MACHINE-CONSTANT (? offset))))
   (let ((how-far (- offset frame-size)))
     (cond ((zero? how-far)
           (LAP))
@@ -257,9 +259,10 @@ MIT in each case. |#
           (generate/move-frame-up frame-size (offset-reference a7 offset))))))
 
 (define-rule statement
-  (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size)
-                                  (OFFSET-ADDRESS (REGISTER (? base))
-                                                  (? offset)))
+  (INVOCATION-PREFIX:MOVE-FRAME-UP
+   (? frame-size)
+   (OFFSET-ADDRESS (REGISTER (? base))
+                  (MACHINE-CONSTANT (? offset))))
   (generate/move-frame-up frame-size (indirect-reference! base offset)))
 \f
 (define-rule statement
@@ -267,10 +270,11 @@ MIT in each case. |#
   (LAP))
 
 (define-rule statement
-  (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
-                                 (OFFSET-ADDRESS (REGISTER (? base))
-                                                 (? offset))
-                                 (REGISTER 12))
+  (INVOCATION-PREFIX:DYNAMIC-LINK
+   (? frame-size)
+   (OFFSET-ADDRESS (REGISTER (? base))
+                  (MACHINE-CONSTANT (? offset)))
+   (REGISTER 12))
   (let ((label (generate-label))
        (temp (allocate-temporary-register! 'ADDRESS)))
     (let ((temp-ref (register-reference temp)))
@@ -816,6 +820,67 @@ long-word aligned and there is no need for shuffling.
         ,@(make-external-label (continuation-code-word false)
                                (generate-label)))))
 \f
+(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
+  (if (= n-code-blocks 0)
+      (LAP)
+      (let ((loop (generate-label))
+           (bytes (generate-label)))
+       (LAP (CLR L (D 0))
+            ;; Set up counter
+            (MOV L (D 0) (@-A 7))
+            (BRA (@PCR ,loop))
+            (LABEL ,bytes)
+            ,@(sections->bytes n-code-blocks n-sections)
+            (LABEL ,loop)
+            ;; Increment counter for next iteration
+            (ADDQ L (& 1) (@A 7))
+            ;; Get subblock
+            (MOV L (@PCR ,code-blocks-label) (D 2))
+            (AND L (D 7) (D 2))
+            (MOV L (D 2) (A 0))
+            (MOV L (@AOXS 0 4 ((D 0) L 4)) (D 2))
+            ;; Get number of linkage sections
+            (CLR L (D 4))
+            (MOV B (@PCRXS ,bytes ((D 0) L 1)) (D 4))
+            ;; block -> address
+            (AND L (D 7) (D 2))
+            (MOV L (D 2) (A 0))
+            ;; Get length and non-marked length
+            (MOV L (@A 0) (D 3))
+            (MOV L (@AO 0 4) (D 5))
+            ;; Strip type tags
+            (AND L (D 7) (D 3))
+            (AND L (D 7) (D 5))
+            ;; Store environment
+            (MOV L ,reg:environment (@AOXS 0 0 ((D 3) L 4)))
+            ;; Address of first constant (linkage area)
+            (LEA (@AOXS 0 8 ((D 5) L 4)) (A 1))
+            (MOV L (A 1) (D 3))
+            (JSR ,entry:compiler-link)
+            ,@(make-external-label (continuation-code-word false)
+                                   (generate-label))
+            ;; Counter value
+            (MOV L (@A 7) (D 0))
+            ;; Exit loop if we've done all
+            (CMP L (& ,n-code-blocks) (D 0))
+            (B NE (@PCR ,loop))
+            ;; Pop counter off the stack
+            (ADDQ L (& 4) (A 7))))))
+
+(define (sections->bytes n-code-blocks n-sections)
+  (let walk ((bytes
+             (append (vector->list n-sections)
+                     (let ((left (remainder n-code-blocks 2)))
+                       (if (zero? left)
+                           '()
+                           (make-list (- 2 left) 0))))))
+    (if (null? bytes)
+       (LAP)
+       (let ((hi (car bytes))
+             (lo (cadr bytes)))
+         (LAP (DC UW ,(+ lo (* 256 hi)))
+              ,@(walk (cddr bytes)))))))
+\f
 (define (generate/constants-block constants references assignments
                                  uuo-links global-links static-vars)
   (let ((constant-info

diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm
index 79f3d85143a8d2256c3c239e643dccc7926b4f6e..78f2e3cf9c4bdf3423e435eec26509472c6f4816 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules4.scm
+++ b/v7/src/compiler/machines/bobcat/rules4.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules4.scm,v 4.13 1992/11/09 18:46:07 jinx Exp $
+$Id: rules4.scm,v 4.14 1993/07/06 00:56:31 gjr Exp $
 
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -89,8 +89,7 @@ MIT in each case. |#
       (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)))))
+      (rtl:simple-offset? expression)))
 
 (define (interpreter-call-argument->machine-register! expression register)
   (let ((target (register-reference register)))
@@ -108,7 +107,7 @@ MIT in each case. |#
                                 (rtl:cons-pointer-datum expression))
                                target)))
       ((OFFSET)
-       (let ((source-reference (offset->indirect-reference! expression)))
+       (let ((source-reference (offset->reference! expression)))
         (LAP ,@(clear-registers! register)
              (MOV L ,source-reference ,target))))
       (else

diff --git a/v7/src/compiler/machines/bobcat/rulrew.scm b/v7/src/compiler/machines/bobcat/rulrew.scm
index 995917318a116d0ead0b5a07afaca11d2474e9c2..c42f88fa74f77bee6684ec28738b16a38a4cadf2 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rulrew.scm
+++ b/v7/src/compiler/machines/bobcat/rulrew.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.5 1992/03/31 19:50:01 jinx Exp $
+$Id: rulrew.scm,v 1.6 1993/07/06 00:56:32 gjr Exp $
 
-Copyright (c) 1990-91 Massachusetts Institute of Technology
+Copyright (c) 1990-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -193,7 +193,11 @@ MIT in each case. |#
                 (? operand-1)
                 (REGISTER (? operand-2 register-known-value))
                 (? overflow?))
-  (QUALIFIER (rtl:constant-fixnum-test operand-2 (lambda (n) true)))
+  (QUALIFIER
+   (rtl:constant-fixnum-test operand-2
+                            (lambda (n)
+                              n        ; ignored
+                              true)))
   (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 overflow?))
 
 (define (rtl:constant-fixnum? expression)
@@ -206,4 +210,55 @@ MIT in each case. |#
         (and (rtl:constant? expression)
              (let ((n (rtl:constant-value expression)))
                (and (fix:fixnum? n)
-                    (predicate n)))))))
\ No newline at end of file
+                    (predicate n)))))))
+\f
+;;;; Indexed addressing modes
+
+(define-rule rewriting
+  (OFFSET (REGISTER (? base register-known-value))
+         (MACHINE-CONSTANT (? value)))
+  (QUALIFIER (and (rtl:offset-address? base)
+                 (rtl:simple-subexpressions? base)))
+  (rtl:make-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+  (BYTE-OFFSET (REGISTER (? base register-known-value))
+              (MACHINE-CONSTANT (? value)))
+  (QUALIFIER (and (rtl:byte-offset-address? base)
+                 (rtl:simple-subexpressions? base)))
+  (rtl:make-byte-offset base (rtl:make-machine-constant value)))
+
+(define-rule rewriting
+  (FLOAT-OFFSET (REGISTER (? base register-known-value))
+               (MACHINE-CONSTANT (? value)))
+  (QUALIFIER (and (rtl:float-offset-address? base)
+                 (rtl:simple-subexpressions? base)))
+  (if (zero? value)
+      (rtl:make-float-offset
+       (rtl:float-offset-address-base base)
+       (rtl:float-offset-address-offset base))
+      (rtl:make-float-offset base (rtl:make-machine-constant value))))
+
+(define-rule rewriting
+  (FLOAT-OFFSET (REGISTER (? base register-known-value))
+               (MACHINE-CONSTANT (? value)))
+  (QUALIFIER
+   (and (rtl:offset-address? base)
+       (rtl:simple-subexpressions? base)
+       (rtl:machine-constant? (rtl:offset-address-offset base))))   
+  (rtl:make-float-offset base (rtl:make-machine-constant value)))
+
+;; This is here to avoid generating things like
+;;
+;; (offset (offset-address (object->address (constant #(foo bar baz gack)))
+;;                         (register 29))
+;;         (machine-constant 1))
+;;
+;; since the offset-address subexpression is constant, and therefore
+;; known!
+
+(define (rtl:simple-subexpressions? expr)
+  (for-all? (cdr expr)
+    (lambda (sub)
+      (or (rtl:machine-constant? sub)
+         (rtl:register? sub)))))
\ No newline at end of file