more abstract.
#| -*-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.
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)
#| -*-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.
(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
(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)
#| -*-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.
(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
#| -*-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.
(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
#| -*-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.
(declare (usual-integrations))
\f
-(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))
(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
#| -*-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.
;;; 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)
'()
(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)
(map (lambda (name) (assq name variables))
names))
\f
+(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))
(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
#| -*-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.
make-pnode
make-rvalue
make-snode
- package)
+ package
+ rule-matcher)
(import (runtime syntactic-closures)
syntax-match?))
(export (compiler)
make-pattern-variable
pattern-lookup
+ pattern-lookup-1
pattern-variable-name
pattern-variable?
pattern-variables))
(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)
#| -*-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.
;; 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
;; 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
#| -*-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.
(declare (usual-integrations))
\f
-(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 '())
(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))
(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!
+\f
+(define-rule pre-cse-rewriting
(OBJECT->ADDRESS (? source))
(QUALIFIER (value-class=address? (rtl:expression-value-class source)))
source)
;; 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
projects / mit-scheme.git / commitdiff