--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rulrew.scm,v 1.1 1990/01/18 22:48:52 cph Exp $
+
+Copyright (c) 1990 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
+
+(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: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:object->datum-expression datum)))))
+
+(define-rule rewriting
+ (OBJECT->TYPE (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant? source))
+ (rtl:make-machine-constant (object-type source)))
+
+(define-rule rewriting
+ (OBJECT->DATUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-non-pointer? source))
+ (rtl:make-machine-constant (careful-object-datum 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.
+
+(define-rule rewriting
+ ;; CLR.L instruction
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target comparand))
+
+(define-rule rewriting
+ ;; TST.L instruction
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source comparand))
+
+(define-rule rewriting
+ ;; TST.L 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-log-base-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-log-base-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-log-base-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
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdflow.scm,v 1.1 1990/01/18 22:49:11 cph Exp $
+
+Copyright (c) 1990 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 Dataflow Analysis
+
+(declare (usual-integrations))
+\f
+(define (rtl-dataflow-analysis rgraphs)
+ (for-each (lambda (rgraph)
+ (let ((rnodes (generate-dataflow-graph rgraph)))
+ (set-rgraph-register-value-classes!
+ rgraph
+ (vector-map rnodes
+ (lambda (rnode)
+ (and rnode
+ (rnode/value-class rnode)))))
+ (generate-known-values! rnodes)
+ (set-rgraph-register-known-values!
+ rgraph
+ (vector-map rnodes
+ (lambda (rnode)
+ (and rnode
+ (rnode/known-value rnode)))))))
+ rgraphs))
+
+(define (rnode/value-class rnode)
+ (let ((union
+ (reduce value-class/nearest-common-ancestor
+ false
+ ;; Here we assume that no member of
+ ;; `rnode/values' is a register expression.
+ (map rtl:expression-value-class
+ (rnode/values rnode)))))
+ ;; Really this test should look for non-leaf value
+ ;; classes, except that the "immediate" class (which is
+ ;; the only other non-leaf class) is generated by the
+ ;; `machine-constant' expression. The `machine-constant'
+ ;; expression should be typed so that its class could be
+ ;; more precisely determined.
+ (if (and (pseudo-register? (rnode/register rnode))
+ (or (eq? union value-class=value)
+ (eq? union value-class=word)
+ (eq? union value-class=unboxed)))
+ (error "mixed-class register" rnode union))
+ union))
+
+(define-structure (rnode
+ (conc-name rnode/)
+ (constructor make-rnode (register))
+ (print-procedure
+ (unparser/standard-method 'RNODE
+ (lambda (state rnode)
+ (unparse-object state (rnode/register rnode))))))
+ (register false read-only true)
+ (forward-links '())
+ (backward-links '())
+ (initial-values '())
+ (values '())
+ (known-value false)
+ (classified-values))
+\f
+(define (generate-dataflow-graph rgraph)
+ (let ((rnodes (make-vector (rgraph-n-registers rgraph) false)))
+ (for-each (lambda (bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (walk-rtl rnodes (rinst-rtl rinst)))))
+ (rgraph-bblocks rgraph))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (set-rnode/values!
+ rnode
+ (rtx-set/union* (rnode/initial-values rnode)
+ (map rnode/initial-values
+ (rnode/backward-links rnode))))))
+ rnodes))
+
+(define (for-each-rnode rnodes procedure)
+ (for-each-vector-element rnodes
+ (lambda (rnode)
+ (if rnode
+ (procedure rnode)))))
+
+(define (walk-rtl rnodes rtl)
+ (let ((get-rnode
+ (lambda (expression)
+ (let ((register (rtl:register-number expression)))
+ (or (vector-ref rnodes register)
+ (let ((rnode (make-rnode register)))
+ (vector-set! rnodes register rnode)
+ rnode))))))
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl))
+ (expression (rtl:assign-expression rtl)))
+ (if (rtl:pseudo-register-expression? address)
+ (let ((target (get-rnode address)))
+ (if (rtl:pseudo-register-expression? expression)
+ (rnode/connect! target (get-rnode expression))
+ (let ((values (rnode/initial-values target)))
+ (if (not (there-exists? values
+ (lambda (value)
+ (rtl:expression=? expression value))))
+ (set-rnode/initial-values!
+ target
+ (cons expression values)))))))))))
+
+(define (rnode/connect! target source)
+ (if (not (memq source (rnode/backward-links target)))
+ (begin
+ (set-rnode/backward-links! target
+ (cons source (rnode/backward-links target)))
+ (set-rnode/forward-links! source
+ (cons target (rnode/forward-links source)))
+ (for-each (lambda (source) (rnode/connect! target source))
+ (rnode/backward-links source))
+ (for-each (lambda (target) (rnode/connect! target source))
+ (rnode/forward-links target)))))
+\f
+(define (generate-known-values! rnodes)
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (set-rnode/classified-values! rnode
+ (map expression->classified-value
+ (rnode/values rnode)))))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (let ((expression (initial-known-value (rnode/classified-values rnode))))
+ (set-rnode/known-value! rnode expression)
+ (if (not (eq? expression 'UNDETERMINED))
+ (set-rnode/classified-values! rnode '())))))
+ (let loop ()
+ (let ((new-constant? false))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
+ (let ((values
+ (values-substitution-step
+ rnodes
+ (rnode/classified-values rnode))))
+ (if (there-exists? values
+ (lambda (value)
+ (eq? (car value) 'SUBSTITUTABLE-REGISTERS)))
+ (set-rnode/classified-values! rnode values)
+ (let ((expression (values-unique-expression values)))
+ (if expression (set! new-constant? true))
+ (set-rnode/known-value! rnode expression)
+ (set-rnode/classified-values! rnode '())))))))
+ (if new-constant? (loop))))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
+ (begin
+ (set-rnode/known-value!
+ rnode
+ (values-unique-expression (rnode/classified-values rnode)))
+ (set-rnode/classified-values! rnode '()))))))
+
+(define (expression->classified-value expression)
+ (cons (cond ((rtl:constant-expression? expression)
+ 'CONSTANT)
+ ((rtl:contains-no-substitutable-registers? expression)
+ 'NO-SUBSTITUTABLE-REGISTERS)
+ (else
+ 'SUBSTITUTABLE-REGISTERS))
+ expression))
+\f
+(define (initial-known-value values)
+ (and (not (null? values))
+ (let loop ((value (car values)) (rest (cdr values)))
+ (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED)
+ ((null? rest) (values-unique-expression values))
+ (else (loop (car rest) (cdr rest)))))))
+
+(define (values-unique-expression values)
+ (let ((class (caar values))
+ (expression (cdar values)))
+ (and (for-all? (cdr values)
+ (lambda (value)
+ (and (eq? class (car value))
+ (rtl:expression=? expression (cdr value)))))
+ expression)))
+
+(define (values-substitution-step rnodes values)
+ (map (lambda (value)
+ (if (eq? (car value) 'SUBSTITUTABLE-REGISTERS)
+ (let ((substitution? false))
+ (let ((expression
+ (let loop ((expression (cdr value)))
+ (if (rtl:register? expression)
+ (let ((value
+ (register-known-value rnodes expression)))
+ (if value
+ (begin (set! substitution? true) value)
+ expression))
+ (rtl:map-subexpressions expression loop)))))
+ (if substitution?
+ (expression->classified-value expression)
+ value)))
+ value))
+ values))
+
+(define (register-known-value rnodes expression)
+ (let ((rnode (vector-ref rnodes (rtl:register-number expression))))
+ (and rnode
+ (let ((value (rnode/known-value rnode)))
+ (and (not (eq? value 'UNDETERMINED))
+ value)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rerite.scm,v 1.1 1990/01/18 22:49:26 cph Rel $
+
+Copyright (c) 1990 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 Rewriting
+
+(declare (usual-integrations))
+\f
+(define-structure (rewriting-rules
+ (conc-name rewriting-rules/)
+ (constructor make-rewriting-rules ()))
+ (assignment '())
+ (statement '())
+ (register '())
+ (expression '())
+ (generic '()))
+
+(define rules:pre-cse (make-rewriting-rules))
+(define rules:post-cse (make-rewriting-rules))
+
+(define (rtl-rewriting:pre-cse rgraphs)
+ (walk-rgraphs rules:pre-cse rgraphs))
+
+(define (rtl-rewriting:post-cse rgraphs)
+ (walk-rgraphs rules:post-cse rgraphs))
+
+(define (add-rewriting-rule! pattern result-procedure)
+ (new-rewriting-rule! rules:post-cse pattern result-procedure))
+
+(define (walk-rgraphs rules rgraphs)
+ (if (not (and (null? (rewriting-rules/assignment rules))
+ (null? (rewriting-rules/statement rules))
+ (null? (rewriting-rules/register rules))
+ (null? (rewriting-rules/expression rules))
+ (null? (rewriting-rules/generic rules))))
+ (for-each (lambda (rgraph)
+ (walk-rgraph rules rgraph))
+ rgraphs)))
+
+(define (walk-rgraph rules rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each (lambda (bblock) (walk-bblock rules bblock))
+ (rgraph-bblocks rgraph))))
+
+(define (walk-bblock rules bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (walk-rinst rules rinst))))
+
+(define (walk-rinst rules rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ ;; Typically there will be few rules, and few instructions that
+ ;; match, so it is worth checking before rewriting anything.
+ (if (or (match-rtl-statement rules rtl)
+ (rtl:any-subexpression? rtl
+ (letrec ((loop
+ (lambda (expression)
+ (or (match-rtl-expression rules expression)
+ (rtl:any-subexpression? expression loop)))))
+ loop)))
+ (set-rinst-rtl!
+ rinst
+ (let loop
+ ((rtl
+ (rtl:map-subexpressions rtl
+ (letrec ((loop
+ (lambda (expression)
+ (let ((match-result
+ (match-rtl-expression rules expression)))
+ (if match-result
+ (loop (match-result))
+ expression)))))
+ loop))))
+ (let ((match-result (match-rtl-statement rules rtl)))
+ (if match-result
+ (loop (match-result))
+ rtl)))))))
+\f
+(define (match-rtl-statement rules rtl)
+ (or (if (rtl:assign? rtl)
+ (pattern-lookup (rewriting-rules/assignment rules) rtl)
+ (let ((entries
+ (assq (rtl:expression-type rtl)
+ (rewriting-rules/statement rules))))
+ (and entries
+ (pattern-lookup (cdr entries) rtl))))
+ (pattern-lookup (rewriting-rules/generic rules) rtl)))
+
+(define (match-rtl-expression rules expression)
+ (or (if (rtl:register? expression)
+ (pattern-lookup (rewriting-rules/register rules) expression)
+ (let ((entries
+ (assq (rtl:expression-type expression)
+ (rewriting-rules/expression rules))))
+ (and entries
+ (pattern-lookup (cdr entries) expression))))
+ (pattern-lookup (rewriting-rules/generic rules) expression)))
+
+(define (new-rewriting-rule! rules pattern result-procedure)
+ (let ((entry (cons pattern result-procedure)))
+ (if (not (and (pair? pattern) (symbol? (car pattern))))
+ (set-rewriting-rules/generic! rules
+ (cons entry
+ (rewriting-rules/generic rules)))
+ (let ((keyword (car pattern)))
+ (cond ((eq? keyword 'ASSIGN)
+ (set-rewriting-rules/assignment!
+ rules
+ (cons entry (rewriting-rules/assignment rules))))
+ ((eq? keyword 'REGISTER)
+ (set-rewriting-rules/register!
+ rules
+ (cons entry (rewriting-rules/register rules))))
+ ((memq keyword rtl:expression-types)
+ (let ((entries
+ (assq keyword (rewriting-rules/expression rules))))
+ (if entries
+ (set-cdr! entries (cons entry (cdr entries)))
+ (set-rewriting-rules/expression!
+ rules
+ (cons (list keyword entry)
+ (rewriting-rules/expression rules))))))
+ ((or (memq keyword rtl:statement-types)
+ (memq keyword rtl:predicate-types))
+ (let ((entries
+ (assq keyword (rewriting-rules/statement rules))))
+ (if entries
+ (set-cdr! entries (cons entry (cdr entries)))
+ (set-rewriting-rules/statement!
+ rules
+ (cons (list keyword entry)
+ (rewriting-rules/statement rules))))))
+ (else
+ (error "illegal RTL type" keyword))))))
+ pattern)
+
+(define-rule
+ (lambda (pattern result-procedure)
+ (new-rewriting-rule! rules:pre-cse pattern result-procedure))
+ (OBJECT->ADDRESS (? source))
+ (QUALIFIER (value-class=address? (rtl:expression-value-class source)))
+ source)
\ No newline at end of file
projects / mit-scheme.git / commitdiff