summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-05-28 11:02:25 -0400
committerAndy Wingo <wingo@pobox.com>2013-06-10 22:46:08 +0200
commit25450a0d0e03ab55ca48fd9996e966d213f9b435 (patch)
tree5f0ff6aa0e733e4596617e13fb93a94e934ce8c7 /module
parent403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (diff)
downloadguile-25450a0d0e03ab55ca48fd9996e966d213f9b435.tar.gz
Pre-order tree-il rewrites are now non-destructive
* module/language/tree-il.scm (pre-order): Re-implement in terms of pre-post-order, and rename from pre-order!. * module/language/tree-il/primitives.scm (expand-primitives): Adapt to pre-order change, and rename from expand-primitives!. * module/language/tree-il/optimize.scm (optimize): Adapt to expand-primitives! change, and rename from optimize!. * module/language/tree-il/compile-glil.scm: * module/system/repl/common.scm: * test-suite/tests/cse.test: * test-suite/tests/peval.test: * test-suite/tests/tree-il.test: Adapt to expand-primitives and optimize changes.
Diffstat (limited to 'module')
-rw-r--r--module/language/tree-il.scm92
-rw-r--r--module/language/tree-il/compile-glil.scm2
-rw-r--r--module/language/tree-il/optimize.scm6
-rw-r--r--module/language/tree-il/primitives.scm13
-rw-r--r--module/system/repl/common.scm10
5 files changed, 19 insertions, 104 deletions
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index b5b7807bd..0a5b72ae9 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -62,7 +62,7 @@
tree-il-fold
make-tree-il-folder
post-order
- pre-order!
+ pre-order
tree-il=?
tree-il-hash))
@@ -616,94 +616,8 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order f x)
(pre-post-order (lambda (x) x) f x))
-(define (pre-order! f x)
- (let lp ((x x))
- (let ((x (or (f x) x)))
- (record-case x
- ((<call> proc args)
- (set! (call-proc x) (lp proc))
- (set! (call-args x) (map lp args)))
-
- ((<primcall> name args)
- (set! (primcall-args x) (map lp args)))
-
- ((<conditional> test consequent alternate)
- (set! (conditional-test x) (lp test))
- (set! (conditional-consequent x) (lp consequent))
- (set! (conditional-alternate x) (lp alternate)))
-
- ((<lexical-set> exp)
- (set! (lexical-set-exp x) (lp exp)))
-
- ((<module-set> exp)
- (set! (module-set-exp x) (lp exp)))
-
- ((<toplevel-set> exp)
- (set! (toplevel-set-exp x) (lp exp)))
-
- ((<toplevel-define> exp)
- (set! (toplevel-define-exp x) (lp exp)))
-
- ((<lambda> body)
- (if body
- (set! (lambda-body x) (lp body))))
-
- ((<lambda-case> inits body alternate)
- (set! inits (map lp inits))
- (set! (lambda-case-body x) (lp body))
- (if alternate (set! (lambda-case-alternate x) (lp alternate))))
-
- ((<seq> head tail)
- (set! (seq-head x) (lp head))
- (set! (seq-tail x) (lp tail)))
-
- ((<let> vals body)
- (set! (let-vals x) (map lp vals))
- (set! (let-body x) (lp body)))
-
- ((<letrec> vals body)
- (set! (letrec-vals x) (map lp vals))
- (set! (letrec-body x) (lp body)))
-
- ((<fix> vals body)
- (set! (fix-vals x) (map lp vals))
- (set! (fix-body x) (lp body)))
-
- ((<let-values> exp body)
- (set! (let-values-exp x) (lp exp))
- (set! (let-values-body x) (lp body)))
-
- ((<dynwind> winder pre body post unwinder)
- (set! (dynwind-winder x) (lp winder))
- (set! (dynwind-pre x) (lp pre))
- (set! (dynwind-body x) (lp body))
- (set! (dynwind-post x) (lp post))
- (set! (dynwind-unwinder x) (lp unwinder)))
-
- ((<dynlet> fluids vals body)
- (set! (dynlet-fluids x) (map lp fluids))
- (set! (dynlet-vals x) (map lp vals))
- (set! (dynlet-body x) (lp body)))
-
- ((<dynref> fluid)
- (set! (dynref-fluid x) (lp fluid)))
-
- ((<dynset> fluid exp)
- (set! (dynset-fluid x) (lp fluid))
- (set! (dynset-exp x) (lp exp)))
-
- ((<prompt> tag body handler)
- (set! (prompt-tag x) (lp tag))
- (set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler)))
-
- ((<abort> tag args tail)
- (set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args))
- (set! (abort-tail x) (lp tail)))
-
- (else #f))
- x)))
+(define (pre-order f x)
+ (pre-post-order f (lambda (x) x) x))
;; FIXME: We should have a better primitive than this.
(define (struct-nfields x)
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index db154cda9..353bd0381 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -64,7 +64,7 @@
(let* ((x (make-lambda (tree-il-src x) '()
(make-lambda-case #f '() #f #f #f '() '() x #f)))
- (x (optimize! x e opts))
+ (x (optimize x e opts))
(x (canonicalize x))
(allocation (analyze-lexicals x)))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index b95f1ae67..4fb8f5989 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -26,9 +26,9 @@
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
- #:export (optimize!))
+ #:export (optimize))
-(define (optimize! x env opts)
+(define (optimize x env opts)
(let ((peval (match (memq #:partial-eval? opts)
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
@@ -43,5 +43,5 @@
(verify-tree-il
(cse
(verify-tree-il
- (peval (expand-primitives! (resolve-primitives x env))
+ (peval (expand-primitives (resolve-primitives x env))
env)))))))
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 32e172289..cbda2db6d 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -26,7 +26,7 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives add-interesting-primitive!
- expand-primitives!
+ expand-primitives
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
singly-valued-primitive? equality-primitive?
@@ -160,7 +160,7 @@
integer->char char->integer number->string string->number
struct-vtable
string-length vector-length
- ;; These all should get expanded out by expand-primitives!.
+ ;; These all should get expanded out by expand-primitives.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
@@ -293,14 +293,15 @@
(define *primitive-expand-table* (make-hash-table))
-(define (expand-primitives! x)
- (pre-order!
+(define (expand-primitives x)
+ (pre-order
(lambda (x)
(record-case x
((<primcall> src name args)
(let ((expand (hashq-ref *primitive-expand-table* name)))
- (and expand (apply expand src args))))
- (else #f)))
+ (or (and expand (apply expand src args))
+ x)))
+ (else x)))
x))
;;; I actually did spend about 10 minutes trying to redo this with
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 5da7c48f0..94b41ea4f 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -25,7 +25,7 @@
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm program)
- #:autoload (language tree-il optimize) (optimize!)
+ #:autoload (language tree-il optimize) (optimize)
#:use-module (ice-9 control)
#:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
@@ -189,10 +189,10 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(define (repl-optimize repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
- #:env (current-module))
- (current-module)
- opts)
+ (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+ #:env (current-module))
+ (current-module)
+ opts)
#:from 'tree-il #:to from)))
(define (repl-parse repl form)