diff options
author | Andy Wingo <wingo@pobox.com> | 2013-05-28 11:02:25 -0400 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-06-10 22:46:08 +0200 |
commit | 25450a0d0e03ab55ca48fd9996e966d213f9b435 (patch) | |
tree | 5f0ff6aa0e733e4596617e13fb93a94e934ce8c7 /module | |
parent | 403d78f915552a6eaaf2ecd7a93b2a7dc2983585 (diff) | |
download | guile-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.scm | 92 | ||||
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 2 | ||||
-rw-r--r-- | module/language/tree-il/optimize.scm | 6 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 13 | ||||
-rw-r--r-- | module/system/repl/common.scm | 10 |
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) |