From: Chris Hanson Date: Thu, 18 Jan 1990 22:49:26 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~11585 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1b136cc4b417f54d93e609e2c7fae221e43b6011;p=mit-scheme.git Initial revision --- diff --git a/v7/src/compiler/machines/bobcat/rulrew.scm b/v7/src/compiler/machines/bobcat/rulrew.scm new file mode 100644 index 000000000..efc268150 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/rulrew.scm @@ -0,0 +1,186 @@ +#| -*-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)) + +;;;; 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)))) + +;;; 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))) + +;;;; 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 diff --git a/v7/src/compiler/rtlopt/rdflow.scm b/v7/src/compiler/rtlopt/rdflow.scm new file mode 100644 index 000000000..c8881b42d --- /dev/null +++ b/v7/src/compiler/rtlopt/rdflow.scm @@ -0,0 +1,238 @@ +#| -*-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)) + +(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)) + +(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))))) + +(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)) + +(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 diff --git a/v7/src/compiler/rtlopt/rerite.scm b/v7/src/compiler/rtlopt/rerite.scm new file mode 100644 index 000000000..4974d641b --- /dev/null +++ b/v7/src/compiler/rtlopt/rerite.scm @@ -0,0 +1,172 @@ +#| -*-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)) + +(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))))))) + +(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