Initial revision

diff --git a/v7/src/compiler/machines/vax/rulrew.scm b/v7/src/compiler/machines/vax/rulrew.scm
new file mode 100644 (file)
index 0000000..bb46505
--- /dev/null
+++ b/v7/src/compiler/machines/vax/rulrew.scm
@@ -0,0 +1,194 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rulrew.scm,v 1.1 1991/02/15 00:40:13 jinx Exp $
+$MC68020-Header: rulrew.scm,v 1.3 90/05/03 15:17:42 GMT jinx Exp $
+
+Copyright (c) 1990, 1991 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+  (QUALIFIER (rtl:machine-constant? type))
+  (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+  (QUALIFIER
+   (and (rtl:object->type? type)
+       (rtl:constant? (rtl:object->type-expression type))))
+  (rtl:make-cons-pointer
+   (rtl:make-machine-constant
+    (object-type (rtl:constant-value (rtl:object->type-expression datum))))
+   datum))
+
+(define-rule rewriting
+  (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+  (QUALIFIER (rtl:machine-constant? datum))
+  (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+  (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+  (QUALIFIER
+   (and (rtl:object->datum? datum)
+       (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+  (rtl:make-cons-pointer
+   type
+   (rtl:make-machine-constant
+    (careful-object-datum
+     (rtl:constant-value (rtl:object->datum-expression datum))))))
+
+(define-rule rewriting
+  (OBJECT->TYPE (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant? source))
+  (rtl:make-machine-constant (object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+  (OBJECT->DATUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant-non-pointer? source))
+  (rtl:make-machine-constant
+   (careful-object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+  (and (rtl:constant? expression)
+       (non-pointer-object? (rtl:constant-value expression))))
+\f
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+;;; Shouldn't these rules use (rtl:make-machine-constant 0)
+;;; rather than comparand?  Of course, there would have to
+;;; be more translation rules, but... -- Jinx
+
+(define-rule rewriting
+  ;; CLR instruction
+  (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'ASSIGN target comparand))
+
+(define-rule rewriting
+  ;; TST instruction
+  (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'EQ-TEST source comparand))
+
+(define-rule rewriting
+  ;; TSTL instruction
+  (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'EQ-TEST source comparand))
+
+(define (rtl:immediate-zero-constant? expression)
+  (cond ((rtl:constant? expression)
+        (let ((value (rtl:constant-value expression)))
+          (and (non-pointer-object? value)
+               (zero? (object-type value))
+               (zero? (careful-object-datum value)))))
+       ((rtl:cons-pointer? expression)
+        (and (let ((expression (rtl:cons-pointer-type expression)))
+               (and (rtl:machine-constant? expression)
+                    (zero? (rtl:machine-constant-value expression))))
+             (let ((expression (rtl:cons-pointer-datum expression)))
+               (and (rtl:machine-constant? expression)
+                    (zero? (rtl:machine-constant-value expression))))))
+       (else false)))
+\f
+;;;; Fixnums
+
+(define-rule rewriting
+  (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant-fixnum? source))
+  (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+                (REGISTER (? operand-1 register-known-value))
+                (? operand-2)
+                (? overflow?))
+  (QUALIFIER
+   (rtl:constant-fixnum-test operand-1
+     (lambda (n)
+       (or (zero? n)
+          (integer-power-of-2? n)))))
+  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+                (? operand-1)
+                (REGISTER (? operand-2 register-known-value))
+                (? overflow?))
+  (QUALIFIER
+   (rtl:constant-fixnum-test operand-2
+     (lambda (n)
+       (or (zero? n)
+          (= -1 n)
+          (integer-power-of-2? n)))))
+  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS (? operator)
+                (? operand-1)
+                (REGISTER (? operand-2 register-known-value))
+                (? overflow?))
+  (QUALIFIER
+   (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
+       (rtl:constant-fixnum-test operand-2 zero?)))
+  (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS (? operator)
+                (? operand-1)
+                (REGISTER (? operand-2 register-known-value))
+                (? overflow?))
+  (QUALIFIER
+   (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
+       (rtl:constant-fixnum-test operand-2
+         (lambda (n)
+           (or (= -1 n)
+               (integer-power-of-2? n))))))
+  (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define (rtl:constant-fixnum? expression)
+  (and (rtl:constant? expression)
+       (fix:fixnum? (rtl:constant-value expression))))
+
+(define (rtl:constant-fixnum-test expression predicate)
+  (and (rtl:object->fixnum? expression)
+       (let ((expression (rtl:object->fixnum-expression expression)))
+        (and (rtl:constant? expression)
+             (let ((n (rtl:constant-value expression)))
+               (and (fix:fixnum? n)
+                    (predicate n)))))))
\ No newline at end of file