Teach the compiler how to use LEA to tag objects and do a three

operand ADD.

diff --git a/v7/src/compiler/machines/i386/rules1.scm b/v7/src/compiler/machines/i386/rules1.scm
index 578e12a0c4618ce3ed137c7e779c6c047546b982..e990f04710751b7acac0ab1bcb4c101a71ba32ed 100644 (file)
--- a/v7/src/compiler/machines/i386/rules1.scm
+++ b/v7/src/compiler/machines/i386/rules1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.10 1992/02/13 19:54:50 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.11 1992/02/15 16:12:51 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
@@ -89,9 +89,25 @@ MIT in each case. |#
          (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
   (if (zero? type)
       (assign-register->register target datum)
-      (LAP (OR W
-              ,(standard-move-to-target! datum target)
-              (&U ,(make-non-pointer-literal type 0))))))
+      (let ((literal (make-non-pointer-literal type 0)))
+       (define (three-arg source)
+         (let ((target (target-register-reference target)))
+           (LAP (LEA ,target (@RO UW ,source ,literal)))))
+
+       (define (two-arg target)
+         (LAP (OR W ,target (&U ,literal)))
+
+       (cond ((register-alias datum 'GENERAL)
+              =>
+              (lambda (alias)
+                (if (pseudo-register? target)
+                    (reuse-pseudo-register-alias! datum 'GENERAL
+                                                  two-arg
+                                                  (lambda ()
+                                                    (three-arg alias)))
+                    (three-arg alias))))
+             (else
+              (two-arg (standard-move-to-target! datum target))))))))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
@@ -277,23 +293,34 @@ MIT in each case. |#
 \f
 ;;;; Utilities specific to rules1
 
-(define (load-displaced-register target source n)
+(define (load-displaced-register/internal target source n signed?)
   (cond ((zero? n)
         (assign-register->register target source))
        ((and (= target source)
              (= target esp))
-        (LAP (ADD W (R ,esp) (& ,n))))
-       (else
+        (if signed?
+            (LAP (ADD W (R ,esp) (& ,n)))
+            (LAP (ADD W (R ,esp) (&U ,n)))))
+       (signed?
         (let* ((source (indirect-byte-reference! source n))
                (target (target-register-reference target)))
+          (LAP (LEA ,target ,source))))
+       (else
+        (let* ((source (indirect-unsigned-byte-reference! source n))
+               (target (target-register-reference target)))
           (LAP (LEA ,target ,source))))))
 
-(define (load-displaced-register/typed target source type n)
-  (load-displaced-register target
-                          source
-                          (if (zero? type)
-                              n
-                              (+ (make-non-pointer-literal type 0) n))))
+(define-integrable (load-displaced-register target source n)
+  (load-displaced-register/internal target source n true))
+
+(define-integrable (load-displaced-register/typed target source type n)
+  (load-displaced-register/internal target
+                                   source
+                                   (if (zero? type)
+                                       n
+                                       (+ (make-non-pointer-literal type 0)
+                                          n))
+                                   false))
 
 (define (load-pc-relative-address/typed target type label)
   (with-pc
@@ -320,4 +347,8 @@ MIT in each case. |#
   (indirect-byte-reference! register (* offset 4)))
 
 (define (indirect-byte-reference! register offset)
-  (byte-offset-reference (allocate-indirection-register! register) offset))
\ No newline at end of file
+  (byte-offset-reference (allocate-indirection-register! register) offset))
+
+(define (indirect-unsigned-byte-reference! register offset)
+  (byte-unsigned-offset-reference (allocate-indirection-register! register)
+                                 offset))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm
index 5d8986d9adc689ba3b25e7f45d6f60ce4903fbf9..d6be23f27e25a162c25359eb09cc189ab4a68e9a 100644 (file)
--- a/v7/src/compiler/machines/i386/rulfix.scm
+++ b/v7/src/compiler/machines/i386/rulfix.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.16 1992/02/13 07:47:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.17 1992/02/15 16:13:00 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
@@ -84,8 +84,7 @@ MIT in each case. |#
                         (REGISTER (? source1))
                         (REGISTER (? source2))
                         (? overflow?)))
-  overflow?                            ; ignored
-  ((fixnum-2-args/operate operator) target source1 source2))
+  ((fixnum-2-args/operate operator) target source1 source2 overflow?))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target))
@@ -318,7 +317,9 @@ MIT in each case. |#
                   FIXNUM-OR
                   FIXNUM-XOR)))
 \f           
-(define ((fixnum-2-args/standard commutative? operate) target source1 source2)
+(define ((fixnum-2-args/standard commutative? operate) target source1
+                                                      source2 overflow?)
+  overflow?                            ; ignored
   (two-arg-register-operation operate
                              commutative?
                              target
@@ -339,36 +340,27 @@ MIT in each case. |#
              (worst-case (target-register-reference target)
                          source1
                          source2)))))
-    (cond ((pseudo-register? target)
-          (reuse-pseudo-register-alias
-           source1 'GENERAL
-           (lambda (alias)
-             (let ((source2 (if (= source1 source2)
-                                (register-reference alias)
-                                (any-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 'GENERAL
-                  (lambda (alias2)
-                    (let ((source1 (any-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? (register-type target) 'GENERAL))
-          (error "two-arg-register-operation: Wrong type register"
-                 target 'GENERAL))
+    (cond ((not (pseudo-register? target))
+          (if (not (eq? (register-type target) 'GENERAL))
+              (error "two-arg-register-operation: Wrong type register"
+                     target 'GENERAL)
+              (worst-case (register-reference target)
+                          (any-reference source1)
+                          (any-reference source2))))
+         ((register-copy-if-available source1 'GENERAL target)
+          =>
+          (lambda (alias-ref)
+            (operate alias-ref (if (= source2 source1)
+                                   alias-ref
+                                   (any-reference source2)))))
+         ((not commutative?)
+          (new-target-alias!))
+         ((register-copy-if-available source2 'GENERAL target)
+          =>
+          (lambda (alias-ref)
+            (operate alias-ref source1)))
          (else
-          (worst-case (register-reference target)
-                      (any-reference source1)
-                      (any-reference source2))))))
+          (new-target-alias!)))))
 
 (define (fixnum-2-args/register*constant operator target
                                         source constant overflow?)
@@ -407,12 +399,37 @@ MIT in each case. |#
                  (LAP)
                  (LAP (,instr W ,',target ,',source2)))))))))
 
-  (binary-operation PLUS-FIXNUM ADD true false)
+  #| (binary-operation PLUS-FIXNUM ADD true false) |#
   (binary-operation MINUS-FIXNUM SUB false false)
   (binary-operation FIXNUM-AND AND true true)
   (binary-operation FIXNUM-OR OR true true)
   (binary-operation FIXNUM-XOR XOR true false))
 
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+  (let* ((operate
+         (lambda (target source2)
+           (LAP (ADD W ,target ,source2))))
+        (standard (fixnum-2-args/standard true operate)))
+
+  (lambda (target source1 source2 overflow?)
+    (if overflow?
+       (standard target source1 source2 overflow?)
+       (let ((one (register-alias source1 'GENERAL))
+             (two (register-alias source2 'GENERAL)))
+         (cond ((not (and one two))
+                (standard target source1 source2 overflow?))
+               ((register-copy-if-available source1 'GENERAL target)
+                =>
+                (lambda (tgt)
+                  (operate tgt (register-reference two))))
+               ((register-copy-if-available source2 'GENERAL target)
+                =>
+                (lambda (tgt)
+                  (operate tgt (register-reference one))))
+               (else
+                (let ((target (target-register-reference target)))
+                  (LAP (LEA ,target (@RI one two 1)))))))))))  
+\f
 (define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
   (fixnum-2-args/standard
    false
@@ -425,7 +442,7 @@ MIT in each case. |#
                      (LAP (MOV W ,temp ,source2)))
                (NOT W ,temp)
                (AND W ,target ,temp)))))))
-\f
+
 (define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
   (fixnum-2-args/standard
    false
@@ -455,9 +472,9 @@ MIT in each case. |#
                           (slabel (generate-label 'SHIFT-NEGATIVE)))
                       (LAP (MOV W (R ,ecx) ,source2)
                            (SAR W (R ,ecx) (& ,scheme-type-width))
-                           (JS (@PCR ,slabel))
+                           (JS B (@PCR ,slabel))
                            (SHL W ,target (R ,ecx))
-                           (JMP (@PCR ,jlabel))
+                           (JMP B (@PCR ,jlabel))
                            (LABEL ,slabel)
                            (NEG W (R ,ecx))
                            (SHR W ,target (R ,ecx))
@@ -470,7 +487,8 @@ MIT in each case. |#
                   (LAP (MOV W ,temp ,target)
                        ,@(with-target temp)
                        (MOV W ,target ,temp))))))))
-    (lambda (target source1 source2)
+    (lambda (target source1 source2 overflow?)
+      overflow?                                ; ignored
       (require-register! ecx)
       (two-arg-register-operation operate
                                  false
@@ -479,7 +497,8 @@ MIT in each case. |#
                                  source2))))
 \f
 (define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
-  (lambda (target source1 source2)
+  (lambda (target source1 source2 overflow?)
+    overflow?                          ; ignored
     (if (= source2 source1)
        (load-fixnum-constant 1 (target-register-reference target))
        (let ((load-dividend (load-machine-register! source1 eax)))
@@ -493,7 +512,8 @@ MIT in each case. |#
                 (SAL W (R ,eax) (& ,scheme-type-width))))))))
 
 (define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
-  (lambda (target source1 source2)
+  (lambda (target source1 source2 overflow?)
+    overflow?                          ; ignored
     (if (= source2 source1)
        (load-fixnum-constant 0 (target-register-reference target))
        (let ((load-dividend (load-machine-register! source1 eax)))
@@ -585,7 +605,7 @@ MIT in each case. |#
             (let ((label (generate-label 'QUO-SHIFT))
                   (absn (if (negative? n) (- 0 n) n)))
               (LAP (CMP W ,target (& 0))
-                   (JGE (@PCR ,label))
+                   (JGE B (@PCR ,label))
                    (ADD W ,target (& ,(* (-1+ absn) fixnum-1)))
                    (LABEL ,label)
                    (SAR W ,target (& ,expt-of-2))
@@ -612,7 +632,7 @@ MIT in each case. |#
               ;; peephole optimizer should be able to fix this.
               (LAP (MOV W ,sign ,target)
                    (AND W ,target (& ,mask))
-                   (JZ (@PCR ,label))
+                   (JZ B (@PCR ,label))
                    (SAR W ,sign (& ,(-1+ scheme-object-width)))
                    (XOR W ,sign (& ,mask))
                    (OR W ,target ,sign)