From: Chris Hanson Date: Mon, 5 Jul 2004 03:59:36 +0000 (+0000) Subject: New macro RULE-MATCHER. Rewrite rule-matching mechanism to make it X-Git-Tag: 20090517-FFI~1624 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ece7cc49f741b2b8d8eb9ce5c4594a679ad4324b;p=mit-scheme.git New macro RULE-MATCHER. Rewrite rule-matching mechanism to make it more abstract. --- diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index a24e56de6..4c7679070 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: asmmac.scm,v 1.19 2003/02/14 18:28:00 cph Exp $ +$Id: asmmac.scm,v 1.20 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1988, 1990, 1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1990,2001,2002 Massachusetts Institute of Technology +Copyright 2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -42,18 +43,19 @@ USA. environment)))) (ill-formed-syntax form))))) -(define (compile-database cases environment procedure) +(define (compile-database rules environment procedure) `(,(close-syntax 'LIST environment) ,@(map (lambda (rule) - (call-with-values (lambda () (parse-rule (car rule) (cdr rule))) - (lambda (pattern variables qualifiers actions) - `(,(close-syntax 'CONS environment) - ',pattern - ,(rule-result-expression variables - qualifiers - (procedure pattern actions) - environment))))) - cases))) + (receive (pattern variables qualifiers actions) + (parse-rule (car rule) (cdr rule)) + (make-rule-matcher + pattern + (rule-result-expression variables + qualifiers + (procedure pattern actions) + environment) + environment))) + rules))) (define (optimize-group-syntax components early? environment) (define (find-constant components) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index b7806f7a0..37e915e4f 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: lapgn1.scm,v 4.20 2003/02/14 18:28:00 cph Exp $ +$Id: lapgn1.scm,v 4.21 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1987-1999 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1998,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -204,7 +205,7 @@ USA. (bblock-register-map (edge-left-node edge)) live-registers))) edges))) - (let ((target-map (merge-register-maps maps false))) + (let ((target-map (merge-register-maps maps #f))) (for-each (lambda (class) (let ((instructions @@ -239,25 +240,24 @@ USA. (define *assign-rules* '()) (define *assign-variable-rules* '()) -(define (add-statement-rule! pattern result-procedure) - (let ((result (cons pattern result-procedure))) - (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*))))) +(define (add-statement-rule! pattern matcher) + (cond ((not (eq? (car pattern) 'ASSIGN)) + (let ((entry (assq (car pattern) *cgen-rules*))) + (if entry + (set-cdr! entry (cons matcher (cdr entry))) + (set! *cgen-rules* + (cons (list (car pattern) matcher) + *cgen-rules*))))) + ((not (pattern-variable? (cadr pattern))) + (let ((entry (assq (caadr pattern) *assign-rules*))) + (if entry + (set-cdr! entry (cons matcher (cdr entry))) + (set! *assign-rules* + (cons (list (caadr pattern) matcher) + *assign-rules*))))) + (else + (set! *assign-variable-rules* + (cons matcher *assign-variable-rules*)))) pattern) (define (lap-generator/match-rtl-instruction rtl) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 5dfef0b9f..cf2b5f671 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: macros.scm,v 4.31 2003/02/14 18:28:01 cph Exp $ +$Id: macros.scm,v 4.32 2004/07/05 03:59:36 cph Exp $ Copyright 1986,1987,1988,1989,1990,1992 Massachusetts Institute of Technology -Copyright 1993,1995,2001,2002,2003 Massachusetts Institute of Technology +Copyright 1993,1995,2001,2002,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -313,22 +313,29 @@ USA. (rsc-macro-transformer (lambda (form environment) (if (syntax-match? '(IDENTIFIER DATUM + DATUM) (cdr form)) - (let ((type (cadr form)) - (pattern (caddr form)) - (body (cdddr form))) - (call-with-values (lambda () (parse-rule pattern body)) - (lambda (pattern variables qualifiers actions) - `(,(case type - ((STATEMENT PREDICATE) - (close-syntax 'ADD-STATEMENT-RULE! environment)) - ((REWRITING) - (close-syntax 'ADD-REWRITING-RULE! environment)) - (else type)) - ',pattern - ,(rule-result-expression variables - qualifiers - `(BEGIN ,@actions) - environment))))) + (receive (pattern matcher) + (rule->matcher (caddr form) (cdddr form) environment) + `(,(case (cadr form) + ((STATEMENT PREDICATE) + (close-syntax 'ADD-STATEMENT-RULE! environment)) + ((REWRITING) + (close-syntax 'ADD-REWRITING-RULE! environment)) + ((PRE-CSE-REWRITING) + (close-syntax 'ADD-PRE-CSE-REWRITING-RULE! environment)) + (else + (error "Unknown rule type:" (cadr form)))) + ',pattern + ,matcher)) + (ill-formed-syntax form))))) + +(define-syntax rule-matcher + (rsc-macro-transformer + (lambda (form environment) + (if (syntax-match? '(DATUM + DATUM) (cdr form)) + (receive (pattern matcher) + (rule->matcher (cadr form) (cddr form) environment) + pattern + matcher) (ill-formed-syntax form))))) (define-syntax lap diff --git a/v7/src/compiler/base/make.scm b/v7/src/compiler/base/make.scm index 68b7f47e6..d810cbe42 100644 --- a/v7/src/compiler/base/make.scm +++ b/v7/src/compiler/base/make.scm @@ -1,9 +1,9 @@ #| -*-Scheme-*- -$Id: make.scm,v 4.122 2003/04/25 03:50:34 cph Exp $ +$Id: make.scm,v 4.123 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1991,1992,1993,1994,1997 Massachusetts Institute of Technology -Copyright (c) 1998,1999,2001,2002,2003 Massachusetts Institute of Technology +Copyright 1991,1992,1993,1994,1997,1998 Massachusetts Institute of Technology +Copyright 1999,2001,2002,2003,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -38,4 +38,4 @@ USA. (load-option 'COMPRESS) (load-option 'RB-TREE) (load-package-set "compiler"))) - (add-identification! "LIAR" 4 116)) \ No newline at end of file + (add-identification! "LIAR" 4 117)) \ No newline at end of file diff --git a/v7/src/compiler/base/pmlook.scm b/v7/src/compiler/base/pmlook.scm index 0270da10f..f3702819c 100644 --- a/v7/src/compiler/base/pmlook.scm +++ b/v7/src/compiler/base/pmlook.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: pmlook.scm,v 1.11 2003/02/14 18:28:01 cph Exp $ +$Id: pmlook.scm,v 1.12 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1988-1999 Massachusetts Institute of Technology +Copyright 1987,1988,1989,1992,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,52 +28,59 @@ USA. (declare (usual-integrations)) -(define pattern-variable-tag - (intern "#[(compiler pattern-matcher/lookup)pattern-variable]")) - -;;; PATTERN-LOOKUP returns either false or a pair whose car is the -;;; item matched and whose cdr is the list of variable values. Use -;;; PATTERN-VARIABLES to get a list of names that is in the same order -;;; as the list of values. - -(define (pattern-lookup entries instance) - (define (lookup-loop entries values bindings) - (define (match pattern instance) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (let ((entry (memq (cdr pattern) bindings))) - (if (not entry) - (begin (set! bindings (cons (cdr pattern) bindings)) - (set! values (cons instance values)) - true) - (eqv? instance - (list-ref values (- (length bindings) - (length entry)))))) - (and (pair? instance) - (match (car pattern) (car instance)) - (match (cdr pattern) (cdr instance)))) - (eqv? pattern instance))) - - (and (not (null? entries)) - (or (and (match (caar entries) instance) - (pattern-lookup/bind (cdar entries) values)) - (lookup-loop (cdr entries) '() '())))) - (lookup-loop entries '() '())) - -(define-integrable (pattern-lookup/bind binder values) - (apply binder values)) +;;; PATTERN-LOOKUP returns either #F or a thunk that is the result of +;;; the matching rule result expression. + +(define (pattern-lookup matchers instance) + (let loop ((matchers matchers)) + (and (pair? matchers) + (or ((car matchers) instance) + (loop (cdr matchers)))))) + +(define (pattern-lookup-1 pattern body instance) + (let loop + ((pattern pattern) + (instance instance) + (vars '()) + (vals '()) + (k (lambda (vars vals) vars (apply body vals)))) + (cond ((pattern-variable? pattern) + (let ((var (pattern-variable-name pattern))) + (let find-var ((vars* vars) (vals* vals)) + (if (pair? vars*) + (if (eq? (car vars*) var) + (and (eqv? (car vals*) instance) + (k vars vals)) + (find-var (cdr vars*) (cdr vals*))) + (k (cons var vars) (cons instance vals)))))) + ((pair? pattern) + (and (pair? instance) + (loop (car pattern) + (car instance) + vars + vals + (lambda (vars vals) + (loop (cdr pattern) + (cdr instance) + vars + vals + k))))) + (else + (and (eqv? pattern instance) + (k vars vals)))))) (define (pattern-variables pattern) - (let ((variables '())) - (define (loop pattern) - (if (pair? pattern) - (if (eq? (car pattern) pattern-variable-tag) - (if (not (memq (cdr pattern) variables)) - (set! variables (cons (cdr pattern) variables))) - (begin (loop (car pattern)) - (loop (cdr pattern)))))) - (loop pattern) - variables)) + (let loop ((pattern pattern) (vars '()) (k (lambda (vars) vars))) + (cond ((pattern-variable? pattern) + (k (let ((var (pattern-variable-name pattern))) + (if (memq var vars) + vars + (cons var vars))))) + ((pair? pattern) + (loop (car pattern) + vars + (lambda (vars) (loop (cdr pattern) vars k)))) + (else (k vars))))) (define-integrable (make-pattern-variable name) (cons pattern-variable-tag name)) @@ -82,5 +89,8 @@ USA. (and (pair? object) (eq? (car object) pattern-variable-tag))) +(define pattern-variable-tag + '|#[(compiler pattern-matcher/lookup)pattern-variable]|) + (define-integrable (pattern-variable-name var) (cdr var)) \ No newline at end of file diff --git a/v7/src/compiler/base/pmpars.scm b/v7/src/compiler/base/pmpars.scm index 28df024cc..326fc1fbf 100644 --- a/v7/src/compiler/base/pmpars.scm +++ b/v7/src/compiler/base/pmpars.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: pmpars.scm,v 1.9 2003/02/14 18:28:01 cph Exp $ +$Id: pmpars.scm,v 1.10 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1988, 1999, 2002 Massachusetts Institute of Technology +Copyright 1987,1988,2002,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -43,15 +43,13 @@ USA. ;;; qualifications failed, or the result of the body. (define (parse-rule pattern body) - (call-with-values (lambda () (extract-variables pattern)) - (lambda (pattern variables) - (call-with-values (lambda () (extract-qualifiers body)) - (lambda (qualifiers actions) - (let ((names (pattern-variables pattern))) - (values pattern - (reorder-variables variables names) - qualifiers - actions))))))) + (receive (pattern variables) (extract-variables pattern) + (receive (qualifiers actions) (extract-qualifiers body) + (let ((names (pattern-variables pattern))) + (values pattern + (reorder-variables variables names) + qualifiers + actions))))) (define (extract-variables pattern) (if (pair? pattern) @@ -62,13 +60,13 @@ USA. '() (list (cons (car pattern) (cddr pattern))))))) - (call-with-values (lambda () (extract-variables (car pattern))) - (lambda (car-pattern car-variables) - (call-with-values (lambda () (extract-variables (cdr pattern))) - (lambda (cdr-pattern cdr-variables) - (values (cons car-pattern cdr-pattern) - (merge-variables-lists car-variables - cdr-variables))))))) + (receive (car-pattern car-variables) + (extract-variables (car pattern)) + (receive (cdr-pattern cdr-variables) + (extract-variables (cdr pattern)) + (values (cons car-pattern cdr-pattern) + (merge-variables-lists car-variables + cdr-variables))))) (values pattern '()))) (define (merge-variables-lists x y) @@ -94,17 +92,39 @@ USA. (map (lambda (name) (assq name variables)) names)) +(define (rule->matcher pattern body environment) + (receive (pattern variables qualifiers actions) (parse-rule pattern body) + (values pattern + (make-rule-matcher pattern + (rule-result-expression variables + qualifiers + `(,(close-syntax + 'BEGIN + environment) + ,@actions) + environment) + environment)))) + +(define (make-rule-matcher pattern expression environment) + (let ((r-lambda (close-syntax 'LAMBDA environment)) + (instance (close-syntax 'INSTANCE environment)) + (r-pl1 (close-syntax 'PATTERN-LOOKUP-1 environment))) + `(,r-lambda (,instance) + (,r-pl1 ',pattern + ,expression + ,instance)))) + (define (rule-result-expression variables qualifiers body environment) - (call-with-values (lambda () (process-transformations variables environment)) - (lambda (outer-vars inner-vars xforms xqualifiers) - (let ((r-lambda (close-syntax 'LAMBDA environment)) - (r-let (close-syntax 'LET environment)) - (r-and (close-syntax 'AND environment))) - `(,r-lambda ,outer-vars - (,r-let ,(map list inner-vars xforms) - (,r-and ,@xqualifiers - ,@qualifiers - (,r-lambda () ,body)))))))) + (receive (outer-vars inner-vars xforms xqualifiers) + (process-transformations variables environment) + (let ((r-lambda (close-syntax 'LAMBDA environment)) + (r-let (close-syntax 'LET environment)) + (r-and (close-syntax 'AND environment))) + `(,r-lambda ,outer-vars + (,r-let ,(map list inner-vars xforms) + (,r-and ,@xqualifiers + ,@qualifiers + (,r-lambda () ,body))))))) (define (process-transformations variables environment) (let ((r-map (close-syntax 'MAP environment)) @@ -112,32 +132,32 @@ USA. (r-boolean/and (close-syntax 'BOOLEAN/AND environment))) (let loop ((variables variables)) (if (pair? variables) - (call-with-values (lambda () (loop (cdr variables))) - (lambda (outer-vars inner-vars xforms qualifiers) - (let ((name (caar variables)) - (variable (cdar variables))) - (if (pair? variable) - (let ((var (car variable))) - (if (not (null? (cdr variable))) - (error "Multiple variable qualifiers:" - (car variables))) - (let ((xform (cadr var)) - (outer-var - (if (pair? (cddr var)) - (caddr var) - name))) - (if (eq? (car var) '?) - (values (cons outer-var outer-vars) - (cons name inner-vars) - (cons `(,xform ,outer-var) xforms) - (cons name qualifiers)) - (values (cons outer-var outer-vars) - (cons name inner-vars) - (cons `(,r-map ,xform ,outer-var) xforms) - (cons `(,r-apply ,r-boolean/and ,name) - qualifiers))))) - (values (cons name outer-vars) - inner-vars - xforms - qualifiers))))) + (receive (outer-vars inner-vars xforms qualifiers) + (loop (cdr variables)) + (let ((name (caar variables)) + (variable (cdar variables))) + (if (pair? variable) + (let ((var (car variable))) + (if (not (null? (cdr variable))) + (error "Multiple variable qualifiers:" + (car variables))) + (let ((xform (cadr var)) + (outer-var + (if (pair? (cddr var)) + (caddr var) + name))) + (if (eq? (car var) '?) + (values (cons outer-var outer-vars) + (cons name inner-vars) + (cons `(,xform ,outer-var) xforms) + (cons name qualifiers)) + (values (cons outer-var outer-vars) + (cons name inner-vars) + (cons `(,r-map ,xform ,outer-var) xforms) + (cons `(,r-apply ,r-boolean/and ,name) + qualifiers))))) + (values (cons name outer-vars) + inner-vars + xforms + qualifiers)))) (values '() '() '() '()))))) \ No newline at end of file diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg index 6515bcbdf..8d19aa86a 100644 --- a/v7/src/compiler/machines/i386/compiler.pkg +++ b/v7/src/compiler/machines/i386/compiler.pkg @@ -1,8 +1,9 @@ #| -*-Scheme-*- -$Id: compiler.pkg,v 1.31 2003/02/14 18:28:03 cph Exp $ +$Id: compiler.pkg,v 1.32 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1992-1999, 2001, 2002 Massachusetts Institute of Technology +Copyright 1992,1993,1994,1996,1997,1998 Massachusetts Institute of Technology +Copyright 2001,2002,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -211,7 +212,8 @@ USA. make-pnode make-rvalue make-snode - package) + package + rule-matcher) (import (runtime syntactic-closures) syntax-match?)) @@ -294,6 +296,7 @@ USA. (export (compiler) make-pattern-variable pattern-lookup + pattern-lookup-1 pattern-variable-name pattern-variable? pattern-variables)) @@ -302,10 +305,14 @@ USA. (files "base/pmpars") (parent (compiler)) (export (compiler) + make-rule-matcher parse-rule + rule->matcher rule-result-expression) (export (compiler macros) + make-rule-matcher parse-rule + rule->matcher rule-result-expression)) (define-package (compiler pattern-matcher/early) diff --git a/v7/src/compiler/machines/i386/rulrew.scm b/v7/src/compiler/machines/i386/rulrew.scm index f86b3182e..ddc75a27b 100644 --- a/v7/src/compiler/machines/i386/rulrew.scm +++ b/v7/src/compiler/machines/i386/rulrew.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rulrew.scm,v 1.16 2003/02/14 18:28:03 cph Exp $ +$Id: rulrew.scm,v 1.17 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1992-1999 Massachusetts Institute of Technology +Copyright 1992,1993,1998,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -270,7 +270,7 @@ USA. ;; acos (x) = atan ((sqrt (1 - x^2)) / x) -(define-rule add-pre-cse-rewriting-rule! +(define-rule pre-cse-rewriting (FLONUM-1-ARG FLONUM-ACOS (? operand) #f) (rtl:make-flonum-2-args 'FLONUM-ATAN2 @@ -287,7 +287,7 @@ USA. ;; asin (x) = atan (x / (sqrt (1 - x^2))) -(define-rule add-pre-cse-rewriting-rule! +(define-rule pre-cse-rewriting (FLONUM-1-ARG FLONUM-ASIN (? operand) #f) (rtl:make-flonum-2-args 'FLONUM-ATAN2 diff --git a/v7/src/compiler/rtlopt/rerite.scm b/v7/src/compiler/rtlopt/rerite.scm index 5832be655..aa267ecab 100644 --- a/v7/src/compiler/rtlopt/rerite.scm +++ b/v7/src/compiler/rtlopt/rerite.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: rerite.scm,v 1.6 2003/02/14 18:28:08 cph Exp $ +$Id: rerite.scm,v 1.7 2004/07/05 03:59:36 cph Exp $ -Copyright (c) 1990-1999 Massachusetts Institute of Technology +Copyright 1990,1992,1993,2004 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -28,9 +28,8 @@ USA. (declare (usual-integrations)) -(define-structure (rewriting-rules - (conc-name rewriting-rules/) - (constructor make-rewriting-rules ())) +(define-structure (rewriting-rules (conc-name rewriting-rules/) + (constructor make-rewriting-rules ())) (assignment '()) (statement '()) (register '()) @@ -46,11 +45,11 @@ USA. (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 (add-rewriting-rule! pattern matcher) + (new-rewriting-rule! rules:post-cse pattern matcher)) -(define (add-pre-cse-rewriting-rule! pattern result-procedure) - (new-rewriting-rule! rules:pre-cse pattern result-procedure)) +(define (add-pre-cse-rewriting-rule! pattern matcher) + (new-rewriting-rule! rules:pre-cse pattern matcher)) (define (walk-rgraphs rules rgraphs) (if (not (and (null? (rewriting-rules/assignment rules)) @@ -121,45 +120,44 @@ USA. (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)))))) +(define (new-rewriting-rule! rules pattern matcher) + (if (and (pair? pattern) (symbol? (car pattern))) + (let ((keyword (car pattern))) + (cond ((eq? keyword 'ASSIGN) + (set-rewriting-rules/assignment! + rules + (cons matcher (rewriting-rules/assignment rules)))) + ((eq? keyword 'REGISTER) + (set-rewriting-rules/register! + rules + (cons matcher (rewriting-rules/register rules)))) + ((memq keyword rtl:expression-types) + (let ((entries + (assq keyword (rewriting-rules/expression rules)))) + (if entries + (set-cdr! entries (cons matcher (cdr entries))) + (set-rewriting-rules/expression! + rules + (cons (list keyword matcher) + (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 matcher (cdr entries))) + (set-rewriting-rules/statement! + rules + (cons (list keyword matcher) + (rewriting-rules/statement rules)))))) + (else + (error "illegal RTL type" keyword)))) + (set-rewriting-rules/generic! rules + (cons matcher + (rewriting-rules/generic rules)))) pattern) - -(define-rule add-pre-cse-rewriting-rule! + +(define-rule pre-cse-rewriting (OBJECT->ADDRESS (? source)) (QUALIFIER (value-class=address? (rtl:expression-value-class source))) source) @@ -168,7 +166,7 @@ USA. ;; Probably closure bumping should not use byte-offset-address, and use ;; a new rtl type, but... -(define-rule add-pre-cse-rewriting-rule! +(define-rule pre-cse-rewriting (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum register-known-value))) (QUALIFIER