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 - (( proc args) - (set! (call-proc x) (lp proc)) - (set! (call-args x) (map lp args))) - - (( name args) - (set! (primcall-args x) (map lp args))) - - (( test consequent alternate) - (set! (conditional-test x) (lp test)) - (set! (conditional-consequent x) (lp consequent)) - (set! (conditional-alternate x) (lp alternate))) - - (( exp) - (set! (lexical-set-exp x) (lp exp))) - - (( exp) - (set! (module-set-exp x) (lp exp))) - - (( exp) - (set! (toplevel-set-exp x) (lp exp))) - - (( exp) - (set! (toplevel-define-exp x) (lp exp))) - - (( body) - (if body - (set! (lambda-body x) (lp body)))) - - (( inits body alternate) - (set! inits (map lp inits)) - (set! (lambda-case-body x) (lp body)) - (if alternate (set! (lambda-case-alternate x) (lp alternate)))) - - (( head tail) - (set! (seq-head x) (lp head)) - (set! (seq-tail x) (lp tail))) - - (( vals body) - (set! (let-vals x) (map lp vals)) - (set! (let-body x) (lp body))) - - (( vals body) - (set! (letrec-vals x) (map lp vals)) - (set! (letrec-body x) (lp body))) - - (( vals body) - (set! (fix-vals x) (map lp vals)) - (set! (fix-body x) (lp body))) - - (( exp body) - (set! (let-values-exp x) (lp exp)) - (set! (let-values-body x) (lp body))) - - (( 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))) - - (( fluids vals body) - (set! (dynlet-fluids x) (map lp fluids)) - (set! (dynlet-vals x) (map lp vals)) - (set! (dynlet-body x) (lp body))) - - (( fluid) - (set! (dynref-fluid x) (lp fluid))) - - (( fluid exp) - (set! (dynset-fluid x) (lp fluid)) - (set! (dynset-exp x) (lp exp))) - - (( tag body handler) - (set! (prompt-tag x) (lp tag)) - (set! (prompt-body x) (lp body)) - (set! (prompt-handler x) (lp handler))) - - (( 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 (( 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 ( make-repl repl-language repl-options @@ -189,10 +189,10 @@ See , 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) diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index e29bac92c..e60fdf39e 100644 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@ -40,7 +40,7 @@ (fix-letrec (cse (peval - (expand-primitives! + (expand-primitives (resolve-primitives (compile 'in #:from 'scheme #:to 'tree-il) (current-module)))))))))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index abc995c22..8f237b8ef 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -36,7 +36,7 @@ (syntax-rules () ((_ in pat) (pass-if-peval in pat - (expand-primitives! + (expand-primitives (resolve-primitives (compile 'in #:from 'scheme #:to 'tree-il) (current-module))))) @@ -488,7 +488,7 @@ ;; and ;; . (pmatch (unparse-tree-il - (peval (expand-primitives! + (peval (expand-primitives (resolve-primitives (compile '(let ((make-adder diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 62052770c..a98921b53 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -66,7 +66,7 @@ (beautify-user-module! m) m)) (orig (parse-tree-il 'in)) - (resolved (expand-primitives! (resolve-primitives orig module)))) + (resolved (expand-primitives (resolve-primitives orig module)))) (or (equal? (unparse-tree-il resolved) 'expected) (begin (format (current-error-port)