mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-03 08:10:31 +02:00
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.
This commit is contained in:
Andy Wingo
parent
403d78f915
commit
25450a0d0e
8 changed files with 23 additions and 108 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,7 +189,7 @@ 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
|
||||
(decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
|
||||
#:env (current-module))
|
||||
(current-module)
|
||||
opts)
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
(fix-letrec
|
||||
(cse
|
||||
(peval
|
||||
(expand-primitives!
|
||||
(expand-primitives
|
||||
(resolve-primitives
|
||||
(compile 'in #:from 'scheme #:to 'tree-il)
|
||||
(current-module))))))))))
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
|
||||
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
|
||||
(pmatch (unparse-tree-il
|
||||
(peval (expand-primitives!
|
||||
(peval (expand-primitives
|
||||
(resolve-primitives
|
||||
(compile
|
||||
'(let ((make-adder
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue