Added rules to support open coding of fixnum arithmetic.

diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm
index d41e4b83c2172ac9e72233529ff9509565acc09e..dc7cddbb3a9388d016a794b6e1022fb6b7895272 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules1.scm
+++ b/v7/src/compiler/machines/bobcat/rules1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.5 1988/03/25 21:20:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.6 1988/04/22 16:20:11 markf Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -104,8 +104,11 @@ MIT in each case. |#
       (add-pseudo-register-alias! target reusable-alias false)
       (increment-machine-register reusable-alias n))
     (lambda ()
-      (LAP (LEA ,(indirect-reference! source n)
-               ,(reference-assignment-alias! target 'ADDRESS))))))
+      (let ((source (indirect-reference! source n)))
+       (delete-dead-registers!)
+       (LAP (LEA ,source
+                 ,(register-reference
+                   (allocate-alias-register! target 'ADDRESS))))))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
@@ -115,16 +118,20 @@ MIT in each case. |#
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
   (QUALIFIER (pseudo-register? target))
+  (delete-dead-registers!)
   (LAP (MOV L
            (@PCR ,(free-reference-label name))
-           ,(reference-assignment-alias! target 'ADDRESS))))
+           ,(register-reference
+             (allocate-alias-register! target 'ADDRESS)))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
   (QUALIFIER (pseudo-register? target))
+  (delete-dead-registers!)
   (LAP (MOV L
            (@PCR ,(free-assignment-label name))
-           ,(reference-assignment-alias! target 'ADDRESS))))
+           ,(register-reference
+             (allocate-alias-register! target 'ADDRESS)))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
@@ -199,6 +206,52 @@ MIT in each case. |#
               (MOV L ,temp ,target*)
               (MOV B (& ,type) ,target*))))))
 \f
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? datum))))
+  (QUALIFIER (pseudo-register? target))
+  (delete-dead-registers!)
+  (let ((target-ref (register-reference (allocate-alias-register! target 'DATA))))
+    (load-fixnum-constant datum target-ref)))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+  (QUALIFIER (pseudo-register? target))
+  (let ((target-ref (move-to-alias-register! source 'DATA target)))
+    (LAP ,(remove-type-from-fixnum target-ref))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (OFFSET (REGISTER (? address)) (? offset))))
+  (QUALIFIER (pseudo-register? target))
+  (let ((source (indirect-reference! address offset)))
+    (delete-dead-registers!)
+    (let ((target-ref (register-reference (allocate-alias-register! target 'DATA))))
+      (LAP (MOV L ,source ,target-ref)
+          ,(remove-type-from-fixnum target-ref)))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (FIXNUM-2-ARGS (? operator) (? operand1) (? operand2)))
+  (QUALIFIER (pseudo-register? target))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (let ((operation
+          (LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg)
+               ,@(put-type-in-ea (ucode-type fixnum) (register-reference temp-reg)))))
+      (delete-dead-registers!)
+      (add-pseudo-register-alias! target temp-reg false)
+      operation)))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+         (FIXNUM-1-ARG (? operator) (? operand)))
+  (QUALIFIER (pseudo-register? target))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (let ((operation
+          (LAP ,@(fixnum-do-1-arg! operator operand temp-reg)
+               ,@(put-type-in-ea (ucode-type fixnum) (register-reference temp-reg)))))
+      (delete-dead-registers!)
+      (add-pseudo-register-alias! target temp-reg false)
+      operation)))
+\f
 ;;;; Transfers to Memory
 
 (define-rule statement
@@ -249,6 +302,25 @@ MIT in each case. |#
     (LAP (MOV L
              ,source
              ,(indirect-reference! a0 n0)))))
+
+(define-rule statement
+  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+         (FIXNUM-2-ARGS (? operator) (? operand1) (? operand2)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA))
+       (target-ref (indirect-reference! a n)))
+    (LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg)
+        (MOV L ,(register-reference temp-reg) ,target-ref)
+        ,@(put-type-in-ea (ucode-type fixnum) target-ref))))
+
+
+(define-rule statement
+  (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+         (FIXNUM-1-ARG (? operator) (? operand)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA))
+       (target-ref (indirect-reference! a n)))
+    (LAP ,@(fixnum-do-1-arg! operator operand temp-reg)
+        (MOV L ,(register-reference temp-reg) ,target-ref)
+        ,@(put-type-in-ea (ucode-type fixnum) target-ref))))
 \f
 ;;;; Consing
 
@@ -273,6 +345,22 @@ MIT in each case. |#
   (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
   (LAP (MOV L ,(indirect-reference! r n) (@A+ 5))))
 
+(define-rule statement
+  (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
+         (FIXNUM-2-ARGS (? operator) (? operand1) (? operand2)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg)
+        (MOV L ,(register-reference temp-reg) (@A+ 5))
+        ,@(put-type-in-ea (ucode-type fixnum) (INST-EA (@A 5))))))
+
+(define-rule statement
+  (ASSIGN (POST-INCREMENT (REGISTER 13) 1)
+         (FIXNUM-1-ARG (? operator) (? operand)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (LAP ,@(fixnum-do-1-arg! operator operand temp-reg)
+        (MOV L ,(register-reference temp-reg) (@A+ 5))
+        ,@(put-type-in-ea (ucode-type fixnum) (INST-EA (@A 5))))))
+
 ;; This pops the top of stack into the heap
 
 (define-rule statement
@@ -312,4 +400,20 @@ MIT in each case. |#
 (define-rule statement
   (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (ENTRY:CONTINUATION (? label)))
   (LAP (PEA (@PCR ,label))
-       (MOV B (& ,(ucode-type compiled-entry)) (@A 7))))
\ No newline at end of file
+       (MOV B (& ,(ucode-type compiled-entry)) (@A 7))))
+
+(define-rule statement
+  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) 
+         (FIXNUM-2-ARGS (? operator) (? operand1) (? operand2)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (LAP ,@(fixnum-do-2-args! operator operand1 operand2 temp-reg)
+        (MOV L ,(register-reference temp-reg) (@-A 7))
+        ,@(put-type-in-ea (ucode-type fixnum) (INST-EA (@A 7))))))
+
+(define-rule statement
+  (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) 
+         (FIXNUM-1-ARG (? operator) (? operand)))
+  (let ((temp-reg (allocate-temporary-register! 'DATA)))
+    (LAP ,@(fixnum-do-1-arg! operator operand temp-reg)
+        (MOV L ,(register-reference temp-reg) (@-A 7))
+        ,@(put-type-in-ea (ucode-type fixnum) (INST-EA (@A 7))))))

diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm
index ddf95d6d01311e9fedbf785c5d1eaffe30ac35ef..777943931bccc190f794872ebc4a7cadb1492a1c 100644 (file)
--- a/v7/src/compiler/machines/bobcat/rules2.scm
+++ b/v7/src/compiler/machines/bobcat/rules2.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.2 1987/12/31 10:26:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.3 1988/04/22 16:21:29 markf Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -187,4 +187,159 @@ MIT in each case. |#
 (define-rule predicate
   (EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1))
           (OFFSET (REGISTER (? register-2)) (? offset-2)))
-  (eq-test/memory*memory register-1 offset-1 register-2 offset-2))
\ No newline at end of file
+  (eq-test/memory*memory register-1 offset-1 register-2 offset-2))
+
+\f
+;;; fixnum predicates
+
+(define (fixnum-pred/register*register register-1 register-2 cc)
+  (let ((finish
+        (lambda (register-1 register-2 maybe-invert)
+          (set-standard-branches! (maybe-invert cc))
+          (LAP (CMP L ,(coerce->any register-1)
+                    ,(coerce->machine-register register-2))))))
+    (if (or (and (not (register-has-alias? register-1 'DATA))
+                (register-has-alias? register-2 'DATA))
+           (and (not (register-has-alias? register-1 'ADDRESS))
+                (register-has-alias? register-2 'ADDRESS)))
+       (finish register-2 register-1 invert-cc)
+       (finish register-1 register-2 (lambda (x) x)))))
+
+(define (fixnum-pred/constant*register constant register cc)
+  (set-standard-branches! cc)
+  (if (non-pointer-object? constant)
+      (LAP (CMPI L (& ,(primitive-datum constant)) ,(coerce->any register)))
+      (LAP (CMP L (@PCR ,(constant->label constant))
+               ,(coerce->machine-register register)))))
+
+(define (fixnum-pred/constant*memory constant memory-reference cc)
+  (set-standard-branches! cc)
+  (if (non-pointer-object? constant)
+      (LAP (CMPI L (& ,(primitive-datum constant)) ,memory-reference))
+      (let ((temp (reference-temporary-register! false)))
+       (LAP (MOV L ,memory-reference ,temp)
+            (CMP L (@PCR ,(constant->label constant))
+                 ,temp)))))
+
+(define (fixnum-pred/register*memory register memory-reference cc)
+  (set-standard-branches! cc)
+  (LAP (CMP L ,memory-reference
+           ,(coerce->machine-register register))))
+
+(define (fixnum-pred/memory*memory register-1 offset-1 register-2 offset-2 cc)
+  (let ((temp (reference-temporary-register! false)))
+    (let ((finish
+          (lambda (register-1 offset-1 register-2 offset-2 maybe-invert)
+            (set-standard-branches! (maybe-invert cc))
+            (LAP (MOV L ,(indirect-reference! register-1 offset-1)
+                      ,temp)
+                 (CMP L ,(indirect-reference! register-2 offset-2)
+                      ,temp)))))
+      (if (or (and (not (register-has-alias? register-1 'ADDRESS))
+                  (register-has-alias? register-2 'ADDRESS))
+             (and (not (register-has-alias? register-1 'DATA))
+                  (register-has-alias? register-2 'DATA)))
+         (finish register-2 offset-2 register-1 offset-1 invert-cc)
+         (finish register-1 offset-1 register-2 offset-2 (lambda (x) x))))))
+
+\f
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (REGISTER (? register-1)) (REGISTER (? register-2)))
+  (fixnum-pred/register*register register-2 register-1
+                                (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (REGISTER (? register)) (CONSTANT (? constant)))
+  (fixnum-pred/constant*register constant register
+                                (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (CONSTANT (? constant)) (REGISTER (? register)))
+  (fixnum-pred/constant*register constant register
+                                (invert-cc (fixnum-pred->cc predicate))))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (OFFSET (REGISTER (? register)) (? offset)) (CONSTANT (? constant)))
+  (fixnum-pred/constant*memory constant (indirect-reference! register offset)
+                              (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (CONSTANT (? constant)) (OFFSET (REGISTER (? register)) (? offset)))
+  (fixnum-pred/constant*memory constant (indirect-reference! register offset)
+                              (invert-cc (fixnum-pred->cc predicate))))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 15) 1))
+  (fixnum-pred/constant*memory constant (INST-EA (@A+ 7))
+                              (invert-cc (fixnum-pred->cc predicate))))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (POST-INCREMENT (REGISTER 15) 1) (CONSTANT (? constant)))
+  (fixnum-pred/constant*memory constant (INST-EA (@A+ 7))
+                              (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (OFFSET (REGISTER (? register-1)) (? offset-1))
+                     (REGISTER (? register-2)))
+  (fixnum-pred/register*memory register-2
+                              (indirect-reference! register-1 offset-1)
+                              (invert-cc (fixnum-pred->cc predicate))))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (REGISTER (? register-1))
+                     (OFFSET (REGISTER (? register-2)) (? offset-2)))
+  (fixnum-pred/register*memory register-1
+                          (indirect-reference! register-2 offset-2)
+                          (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (POST-INCREMENT (REGISTER 15) 1) (REGISTER (? register)))
+  (fixnum-pred/register*memory register (INST-EA (@A+ 7))
+                              (invert-cc (fixnum-pred->cc predicate))))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (REGISTER (? register)) (POST-INCREMENT (REGISTER 15) 1))
+  (fixnum-pred/register*memory register (INST-EA (@A+ 7))
+                              (fixnum-pred->cc predicate)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                     (OFFSET (REGISTER (? register-1)) (? offset-1))
+                     (OFFSET (REGISTER (? register-2)) (? offset-2)))
+  (fixnum-pred/memory*memory register-1 offset-1 register-2 offset-2
+                            (fixnum-pred->cc predicate)))
+
+\f
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+  (set-standard-branches! (fixnum-pred->cc predicate))
+  (test-fixnum (coerce->any register)))
+
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG (? predicate) (CONSTANT (? constant)))
+  (set-standard-branches! (fixnum-pred->cc predicate))
+    (if (non-pointer-object? constant)
+      (test-fixnum (INST-EA (& ,(primitive-datum constant))))
+      (test-fixnum (INST-EA (@PCR ,(constant->label constant))))))
+
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG (? predicate) (POST-INCREMENT (REGISTER 15) 1))
+  (set-standard-branches! (fixnum-pred->cc predicate))
+  (test-fixnum (INST-EA (@A+ 7))))
+
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG (? predicate) (OFFSET (REGISTER (? register)) (? offset)))
+  (set-standard-branches! (fixnum-pred->cc predicate))
+  (test-fixnum (indirect-reference! offset register)))