Generalized patterns for OR and AND.

diff --git a/v7/src/compiler/machines/i386/lapopt.scm b/v7/src/compiler/machines/i386/lapopt.scm
index 490abbdbfaa9ee082ef3a87f95fc15add723674e..670aa9f24f4cb0dd0acbfe790250078a08fb454e 100644 (file)
--- a/v7/src/compiler/machines/i386/lapopt.scm
+++ b/v7/src/compiler/machines/i386/lapopt.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapopt.scm,v 1.3 1997/10/22 06:47:47 adams Exp $
+$Id: lapopt.scm,v 1.4 1998/02/14 07:12:14 adams Exp $
 
-Copyright (c) 1992-1997 Massachusetts Institute of Technology
+Copyright (c) 1992-1998 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -93,26 +93,32 @@ MIT in each case. |#
 
 \f
 (define *rules* '())
+(define *rule-window* 0)               ; length of longest pattern
 
 (define (define-lapopt name pattern predicate constructor)
   (set! *rules*
        (cons (make-rule name
-                        (reverse! pattern)
+                        (reverse pattern)
                         (if ((access procedure? system-global-environment)
                              predicate)
                             predicate
                             (lambda (dict) dict #T))
                         constructor)
              *rules*))
+  (set! *rule-window* (max *rule-window* (length pattern)))
   name)
 
 ;; Rules are tried in the reverse order in which they are defined.
 ;;
 ;; Rules are matched against the LAP from the bottom up.
 ;;
-;; Once a rule has been applied, the rewritten LAP is matched again,
-;; so a rule must rewrite to something different to avoid a loop.
-;; (One way to ensure this is to always rewrite to fewer instructions.)
+;; Once a rule has been applied, the rewritten LAP is matched again*,
+;; so a rule must rewrite to something different to avoid a loop.  (A
+;; good way to ensure this is to always rewrite to fewer
+;; instructions.)
+;;
+;; *The matching `rewinds' slightly to ensure all patterns that might
+;; overlap the rewritten LAP are considered.
 
 (define (rewrite-lap lap)
   (let loop ((unseen (reverse lap)) (finished '()))
@@ -132,13 +138,24 @@ MIT in each case. |#
                     (lambda (dict comments unseen*)
                       (let ((dict (alist->dict dict)))
                         (if ((rule-predicate rule) dict)
-                            (let ((rewritten
-                                   (cons
-                                    `(COMMENT (LAP-OPT ,(rule-name rule)))
-                                    (append comments
-                                            ((rule-constructor rule) dict)))))
-                              (loop (append (reverse rewritten) unseen*)
-                                    finished))
+                            (let* ((insns ((rule-constructor rule) dict))
+                                   (rewritten
+                                    (cons
+                                     `(COMMENT (LAP-OPT ,(rule-name rule)))
+                                     (append comments insns))))
+                              (let backup-loop
+                                  ((i (- *rule-window* (length insns)))
+                                   (unseen
+                                    (append (reverse rewritten) unseen*))
+                                   (finished finished))
+                                (if (and (> i 0) (pair? finished))
+                                    (backup-loop
+                                     (if (eq? (caar finished) 'COMMENT)
+                                         i
+                                         (- i 1))
+                                     (cons (car finished) unseen)
+                                     (cdr finished))
+                                    (loop unseen finished))))
                             (try-rules (cdr rules)))))
                     (lambda ()
                       (try-rules (cdr rules)))))))))))
@@ -278,6 +295,11 @@ MIT in each case. |#
    (bit-string-or (signed-integer->bit-string 32 x)
                  (signed-integer->bit-string 32 y))))
 
+(define (and-32-signed x y)
+  (bit-string->signed-integer
+   (bit-string-and (signed-integer->bit-string 32 x)
+                  (signed-integer->bit-string 32 y))))
+
 (define (ror-32-signed w count)
   (let ((bs (signed-integer->bit-string 32 w)))
     (bit-string->signed-integer
@@ -296,14 +318,23 @@ MIT in each case. |#
     `((OR W (R ,(dict 'reg))
          (& ,(or-32-signed (dict 'const-1) (dict 'const-2)))))))
 
+(define-lapopt 'AND-AND
+  `((AND W (R (? reg)) (& (? const-1)))
+    (AND W (R (? reg)) (& (? const-2))))
+  #F
+  (lambda (dict)
+    `((AND W (R ,(dict 'reg))
+          (& ,(and-32-signed (dict 'const-1) (dict 'const-2)))))))
+
 ;; These rules match a whole fixnum detag-AND/OR-retag operation.  In
 ;; principle, these operations could be done in rulfix.scm, but the
 ;; instruction combiner wants all the intermediate steps.
 
+
+;; Relies on OR-OR collapsing the constant with the tag injection
 (define-lapopt 'FIXNUM-OR-CONST-IN-PLACE
   `((SAL W (? reg) (& ,scheme-type-width))
     (OR W (? reg) (& (? const)))
-    (OR W (? reg) (& ,fixnum-tag))
     (ROR W (? reg) (& ,scheme-type-width)))
   #F
   (lambda (dict)
@@ -311,18 +342,33 @@ MIT in each case. |#
          (& ,(careful-object-datum
               (sar-32 (dict 'const) scheme-type-width)))))))
 
-(define-lapopt 'FIXNUM-AND-CONST-IN-PLACE
+(define-lapopt 'FIXNUM-AND-OR-CONST-IN-PLACE
   `((SAL W (? reg) (& ,scheme-type-width))
-    (AND W (? reg) (& (? const)))
-    (OR W (? reg) (& ,fixnum-tag))
+    (AND W (? reg) (& (? const-1)))
+    (OR W (? reg) (& (? const-2)))
     (ROR W (? reg) (& ,scheme-type-width)))
   #F
   (lambda (dict)
-    `((AND W ,(dict 'reg)
-          (& ,(make-non-pointer-literal
-               fixnum-tag
-               (careful-object-datum
-                (sar-32 (dict 'const) scheme-type-width))))))))
+    (let ((and-value
+          (careful-object-datum (sar-32 (dict 'const-1) scheme-type-width)))
+         (or-value
+          (careful-object-datum (sar-32 (dict 'const-2) scheme-type-width))))
+      (define (tagged value) (make-non-pointer-literal fixnum-tag value))
+      ;; Either AND must keep the tag bits, or OR must inject them, so
+      ;; at least one of AND or OR must be a 32-bit pattern.  Choose to
+      ;; minimize code size, break ties in favor of GC safely on
+      ;; illegal operands.
+      (cond ((zero? or-value)
+            `((AND W ,(dict 'reg) (& ,(tagged and-value)))))
+           ((fits-in-signed-byte? and-value)
+            `((AND W ,(dict 'reg) (& ,and-value))
+              (OR W ,(dict 'reg)  (& ,(tagged or-value)))))
+           ((fits-in-signed-byte? or-value)
+            `((AND W ,(dict 'reg) (& ,(tagged and-value)))
+              (OR W ,(dict 'reg)  (& ,or-value))))
+           (else                       ; neither fits
+            `((AND W ,(dict 'reg) (& ,(tagged and-value)))
+              (OR W ,(dict 'reg)  (& ,(tagged or-value)))))))))
 \f
 ;; FIXNUM-NOT.  The first (partial) pattern uses the XOR operation to
 ;; put the tag bits in the low part of the result.  This pattern