Break out procedure to pattern match RTL against rules database. This

procedure can be used as a predicate by the RTL optimizer to determine
if particular instructions are valid.  In particular, this is used by
the instruction combiner.

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index 0767d6dd2a5a749c4d4b6fd5a7fd4ff149a29165..9be4504a8f2e4e16ebf3fb599e4b92fe64c09f9d 100644 (file)
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.3 1988/08/22 22:15:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.4 1988/08/29 22:30:22 cph Exp $
 
 Copyright (c) 1987, 1988 Massachusetts Institute of Technology
 
@@ -63,7 +63,7 @@ MIT in each case. |#
                (if (not (node-marked? (edge-right-node edge)))
                    (cgen-entry edge)))
              (rgraph-entry-edges rgraph))))
-\f
+
 (define (cgen-entry edge)
   (let ((bblock (edge-right-node edge)))
     (fluid-let ((*entry-bblock* bblock))
@@ -130,17 +130,6 @@ MIT in each case. |#
            (begin (error "CGEN-BBLOCK: No matching rules" rtl)
                   (loop)))))))
 
-(define (lap-generator/match-rtl-instruction rtl)
-  ;; Match a single RTL instruction, returning a thunk to generate the
-  ;; LAP.  This is used in the RTL optimizer at certain points to
-  ;; determine if a rewritten instruction is valid.
-  (let ((rule
-        (if (eq? (car rtl) 'ASSIGN)
-            (assq (caadr rtl) *assign-rules*)
-            (assq (car rtl) *cgen-rules*))))
-    (and rule
-        (pattern-lookup (cdr rule) rtl))))
-
 (define (bblock-input-register-map bblock)
   (if (or (eq? bblock *entry-bblock*)
          (not (node-previous=1? bblock)))
@@ -158,20 +147,38 @@ MIT in each case. |#
 \f
 (define *cgen-rules* '())
 (define *assign-rules* '())
+(define *assign-variable-rules* '())
 
 (define (add-statement-rule! pattern result-procedure)
   (let ((result (cons pattern result-procedure)))
-    (if (eq? (car pattern) 'ASSIGN)
-       (let ((entry (assq (caadr pattern) *assign-rules*)))
-         (if entry
-             (set-cdr! entry (cons result (cdr entry)))
-             (set! *assign-rules*
-                   (cons (list (caadr pattern) result)
-                         *assign-rules*))))
-       (let ((entry (assq (car pattern) *cgen-rules*)))
-         (if entry
-             (set-cdr! entry (cons result (cdr entry)))
-             (set! *cgen-rules*
-                   (cons (list (car pattern) result)
-                         *cgen-rules*))))))
-  pattern)
\ No newline at end of file
+    (cond ((not (eq? (car pattern) 'ASSIGN))
+          (let ((entry (assq (car pattern) *cgen-rules*)))
+            (if entry
+                (set-cdr! entry (cons result (cdr entry)))
+                (set! *cgen-rules*
+                      (cons (list (car pattern) result)
+                            *cgen-rules*)))))
+         ((not (pattern-variable? (cadr pattern)))
+          (let ((entry (assq (caadr pattern) *assign-rules*)))
+            (if entry
+                (set-cdr! entry (cons result (cdr entry)))
+                (set! *assign-rules*
+                      (cons (list (caadr pattern) result)
+                            *assign-rules*)))))
+         (else
+          (set! *assign-variable-rules*
+                (cons result *assign-variable-rules*)))))
+  pattern)
+
+(define (lap-generator/match-rtl-instruction rtl)
+  ;; Match a single RTL instruction, returning a thunk to generate the
+  ;; LAP.  This is used in the RTL optimizer at certain points to
+  ;; determine if a rewritten instruction is valid.
+  (if (not (rtl:assign? rtl))
+      (let ((rules (assq (rtl:expression-type rtl) *cgen-rules*)))
+       (and rules (pattern-lookup (cdr rules) rtl)))
+      (let ((rules
+            (assq (rtl:expression-type (rtl:assign-address rtl))
+                  *assign-rules*)))
+       (or (and rules (pattern-lookup (cdr rules) rtl))
+           (pattern-lookup *assign-variable-rules* rtl)))))
\ No newline at end of file