From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 24 Sep 2009 07:44:26 +0000 (-0700)
Subject: Remove complex and unused optimizer. Change "combination" to "form"
X-Git-Tag: 20100708-Gtk~316^2~1
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=431d0136e166610bc5dd5ffe35974760e6296e5e;p=mit-scheme.git
Remove complex and unused optimizer. Change "combination" to "form"
in places where it was being used incorrectly. A couple of other
tweaks.
---
diff --git a/src/runtime/structure-parser.scm b/src/runtime/structure-parser.scm
index a49d27e6f..3af5be30d 100644
--- a/src/runtime/structure-parser.scm
+++ b/src/runtime/structure-parser.scm
@@ -784,8 +784,8 @@ USA.
;;;; Optimizer
-;;; Made easier by two facts: each bound name is unique, and we never
-;;; copy expressions.
+;;; Made easier because: (1) each bound name is unique; (2) we never
+;;; copy expressions; and (3) there are no side-effects.
(define (optimize-result expr)
(fixup-lambdas
@@ -803,7 +803,7 @@ USA.
rewrite-lambda
rewrite-loop
(lambda (expr loop)
- (let ((expr (rewrite-combination expr loop)))
+ (let ((expr (rewrite-form expr loop)))
(if (syntax-match? '('LAMBDA (* SYMBOL) EXPRESSION)
(car expr))
(optimize-let (cadar expr)
@@ -874,7 +874,7 @@ USA.
expr))))
rewrite-lambda
rewrite-loop
- rewrite-combination))
+ rewrite-form))
(define (fixup-lambdas expr)
(walk-expr expr
@@ -890,7 +890,7 @@ USA.
names)
,body)))
rewrite-loop
- rewrite-combination))
+ rewrite-form))
(define (peephole-optimizer expr)
(walk-expr expr
@@ -900,7 +900,7 @@ USA.
rewrite-lambda
rewrite-loop
(lambda (expr loop)
- (let ((expr (rewrite-combination expr loop)))
+ (let ((expr (rewrite-form expr loop)))
(let loop ((optimizers (get-peephole-optimizers expr)))
(if (pair? optimizers)
((car optimizers) expr
@@ -924,15 +924,9 @@ USA.
(define-peephole-optimizer `('CONS EXPRESSION EXPRESSION)
(lambda (expr win lose)
- (if (equal? (cadr expr) (null-vals))
- (win (caddr expr))
- (lose))))
-
-(define-peephole-optimizer `('CONS EXPRESSION EXPRESSION)
- (lambda (expr win lose)
- (if (equal? (caddr expr) (null-vals))
- (win (cadr expr))
- (lose))))
+ (cond ((equal? (cadr expr) (null-vals)) (win (caddr expr)))
+ ((equal? (caddr expr) (null-vals)) (win (cadr expr)))
+ (else (lose)))))
(define-peephole-optimizer `('FIX:+ ,fix:fixnum? ,fix:fixnum?)
(lambda (expr win lose)
@@ -993,6 +987,8 @@ USA.
(win (cadr expr)))
((memq '#T (cdr expr))
(win (delq '#T (cdr expr))))
+ ((memq '#F (cdr expr))
+ (win '#F))
((any (lambda (expr)
(syntax-match? '('AND * EXPRESSION) expr))
(cdr expr))
@@ -1004,59 +1000,9 @@ USA.
(cdr expr)))))
(else (lose)))))
-(define-peephole-optimizer '('AND * EXPRESSION)
- (lambda (expr win lose)
- (let ((test?
- (lambda (expr)
- (or (syntax-match? `('FIX:< ,fix:fixnum? EXPRESSION)
- expr)
- (syntax-match? `('FIX:= ,fix:fixnum? EXPRESSION)
- expr)))))
- (let ((expr* (list-copy expr)))
- (let loop1 ((exprs (cdr expr*)) (changed? #f))
- (cond ((find-tail test? exprs)
- => (lambda (tail)
- (let ((related-test?
- (lambda (expr)
- (and (test? expr)
- (equal? (caddr expr)
- (caddr (car tail)))))))
- (let loop2 ((changed? changed?))
- (let ((other (find related-test? (cdr tail))))
- (if other
- (let ((expr (resolve-tests (car tail) other)))
- (if expr
- (begin
- (set-car! tail expr)
- (set-cdr! tail
- (delq! other (cdr tail)))
- (loop2 #t))
- (begin
- (set-car! tail '#F)
- (set-cdr! tail
- (remove! related-test?
- (cdr tail)))
- (loop1 (cdr tail) #t))))
- (loop1 (cdr tail) changed?)))))))
- (changed? (win expr*))
- (else (lose))))))))
-
-(define (resolve-tests expr expr*)
- (if (eq? (car expr) 'FIX:=)
- (if (if (eq? (car expr*) 'FIX:=)
- (fix:= (cadr expr*) (cadr expr))
- (fix:< (cadr expr*) (cadr expr)))
- expr
- #f)
- (if (fix:< (cadr expr) (cadr expr*))
- expr*
- (if (eq? (car expr*) 'FIX:<)
- expr
- #f))))
-
(define (walk-expr expr
if-constant if-quote if-reference
- if-lambda if-loop if-combination)
+ if-lambda if-loop if-form)
(let loop ((expr expr))
(cond ((syntax-match? '('LAMBDA (* SYMBOL) EXPRESSION) expr)
(if-lambda expr loop))
@@ -1066,7 +1012,7 @@ USA.
((syntax-match? '('QUOTE EXPRESSION) expr)
(if-quote expr))
((syntax-match? '(+ EXPRESSION) expr)
- (if-combination expr loop))
+ (if-form expr loop))
((syntax-match? 'IDENTIFIER expr)
(if-reference expr))
(else
@@ -1093,7 +1039,7 @@ USA.
(caddr expr))
,(loop (cadddr expr))))
-(define (rewrite-combination expr loop)
+(define (rewrite-form expr loop)
(map loop expr))
;;; Edwin Variables: