mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
peval: Alpha-rename anonymous lambdas that are duplicated.
* module/language/tree-il/optimize.scm (alpha-rename): New procedure. (peval)[maybe-unlambda]: Use it. * test-suite/tests/tree-il.test ("partial evaluation"): Add two test cases for <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
This commit is contained in:
parent
3f2d6efc7b
commit
2ae0775e40
2 changed files with 129 additions and 0 deletions
|
@ -41,6 +41,70 @@
|
||||||
(peval (expand-primitives! (resolve-primitives! x env))
|
(peval (expand-primitives! (resolve-primitives! x env))
|
||||||
env)))))
|
env)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Partial evaluation.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (alpha-rename exp)
|
||||||
|
"Alpha-rename EXP. For any lambda in EXP, generate new symbols and
|
||||||
|
replace all lexical references to the former symbols with lexical
|
||||||
|
references to the new symbols."
|
||||||
|
;; XXX: This should be factorized somehow.
|
||||||
|
(let loop ((exp exp)
|
||||||
|
(mapping vlist-null)) ; maps old to new gensyms
|
||||||
|
(match exp
|
||||||
|
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
|
||||||
|
;; Create new symbols to replace GENSYMS and propagate them down
|
||||||
|
;; in BODY and ALT.
|
||||||
|
(let* ((new (map (compose gensym symbol->string) gensyms))
|
||||||
|
(mapping (fold vhash-consq mapping gensyms new)))
|
||||||
|
(make-lambda-case src req opt rest kw inits new
|
||||||
|
(loop body mapping)
|
||||||
|
(and alt (loop alt mapping)))))
|
||||||
|
(($ <lexical-ref> src name gensym)
|
||||||
|
;; Possibly replace GENSYM by the new gensym defined in MAPPING.
|
||||||
|
(let ((val (vhash-assq gensym mapping)))
|
||||||
|
(if val
|
||||||
|
(make-lexical-ref src name (cdr val))
|
||||||
|
exp)))
|
||||||
|
(($ <lambda> src meta body)
|
||||||
|
(make-lambda src meta (loop body mapping)))
|
||||||
|
(($ <let> src names gensyms vals body)
|
||||||
|
;; As for `lambda-case' rename GENSYMS to avoid any collision.
|
||||||
|
(let* ((new (map (compose gensym symbol->string) gensyms))
|
||||||
|
(mapping (fold vhash-consq mapping gensyms new))
|
||||||
|
(vals (map (cut loop <> mapping) vals))
|
||||||
|
(body (loop body mapping)))
|
||||||
|
(make-let src names new vals body)))
|
||||||
|
(($ <letrec> src in-order? names gensyms vals body)
|
||||||
|
;; Likewise.
|
||||||
|
(let* ((new (map (compose gensym symbol->string) gensyms))
|
||||||
|
(mapping (fold vhash-consq mapping gensyms new))
|
||||||
|
(vals (map (cut loop <> mapping) vals))
|
||||||
|
(body (loop body mapping)))
|
||||||
|
(make-letrec src in-order? names new vals body)))
|
||||||
|
(($ <const>)
|
||||||
|
exp)
|
||||||
|
(($ <void>)
|
||||||
|
exp)
|
||||||
|
(($ <toplevel-ref>)
|
||||||
|
exp)
|
||||||
|
(($ <module-ref>)
|
||||||
|
exp)
|
||||||
|
(($ <primitive-ref>)
|
||||||
|
exp)
|
||||||
|
(($ <conditional> src condition subsequent alternate)
|
||||||
|
(make-conditional src
|
||||||
|
(loop condition mapping)
|
||||||
|
(loop subsequent mapping)
|
||||||
|
(loop alternate mapping)))
|
||||||
|
(($ <application> src proc args)
|
||||||
|
(make-application src (loop proc mapping)
|
||||||
|
(map (cut loop <> mapping) args)))
|
||||||
|
(($ <sequence> src exps)
|
||||||
|
(make-sequence src (map (cut loop <> mapping) exps))))))
|
||||||
|
|
||||||
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
|
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
|
||||||
"Partially evaluate EXP in compilation environment CENV, with
|
"Partially evaluate EXP in compilation environment CENV, with
|
||||||
top-level bindings from ENV and return the resulting expression. Since
|
top-level bindings from ENV and return the resulting expression. Since
|
||||||
|
@ -189,6 +253,13 @@ it does not handle <fix> and <let-values>, it should be called before
|
||||||
(make-lexical-ref src name (car x))))
|
(make-lexical-ref src name (car x))))
|
||||||
(vlist-fold cons '() env)) ; todo: optimize
|
(vlist-fold cons '() env)) ; todo: optimize
|
||||||
new))
|
new))
|
||||||
|
(($ <lambda> src ()
|
||||||
|
(and lc ($ <lambda-case>)))
|
||||||
|
;; This is an anonymous lambda that we're going to inline. The
|
||||||
|
;; variable allocation process assumes globally unique gensyms to
|
||||||
|
;; alpha-rename the lambda to avoid any collision with other
|
||||||
|
;; copies of it.
|
||||||
|
(make-lambda src '() (alpha-rename lc)))
|
||||||
(_ new)))
|
(_ new)))
|
||||||
|
|
||||||
(catch 'match-error
|
(catch 'match-error
|
||||||
|
|
|
@ -828,6 +828,64 @@
|
||||||
(lexical x _))))
|
(lexical x _))))
|
||||||
(toplevel top)))))
|
(toplevel top)))))
|
||||||
|
|
||||||
|
(pass-if-peval
|
||||||
|
;; In this example, the two anonymous lambdas are inlined more than
|
||||||
|
;; once; thus, they should use different gensyms for their
|
||||||
|
;; arguments, because the variable allocation process assumes
|
||||||
|
;; globally unique gensyms. This test in itself doesn't check that;
|
||||||
|
;; we rely on the next one to catch any error.
|
||||||
|
;;
|
||||||
|
;; Bug reported at
|
||||||
|
;; <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>.
|
||||||
|
(letrec ((fold (lambda (f x3 b null? car cdr)
|
||||||
|
(if (null? x3)
|
||||||
|
b
|
||||||
|
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
|
||||||
|
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
|
||||||
|
(letrec (fold) (_) (_)
|
||||||
|
(if (apply (primitive zero?) (toplevel x))
|
||||||
|
(const 1)
|
||||||
|
(apply (primitive *) ; f
|
||||||
|
(apply (lambda () ; car
|
||||||
|
(lambda-case
|
||||||
|
(((x1) #f #f #f () (_))
|
||||||
|
(lexical x1 _))))
|
||||||
|
(toplevel x))
|
||||||
|
(apply (lexical fold _) ; fold
|
||||||
|
(primitive *)
|
||||||
|
(apply (lambda () ; cdr
|
||||||
|
(lambda-case
|
||||||
|
(((x2) #f #f #f () (_))
|
||||||
|
(apply (primitive -)
|
||||||
|
(lexical x2 _) (const 1)))))
|
||||||
|
(toplevel x))
|
||||||
|
(const 1)
|
||||||
|
(primitive zero?)
|
||||||
|
(lambda () ; car
|
||||||
|
(lambda-case
|
||||||
|
(((x1) #f #f #f () (_))
|
||||||
|
(lexical x1 _))))
|
||||||
|
(lambda () ; cdr
|
||||||
|
(lambda-case
|
||||||
|
(((x2) #f #f #f () (_))
|
||||||
|
(apply (primitive -)
|
||||||
|
(lexical x2 _) (const 1))))))))))
|
||||||
|
|
||||||
|
(pass-if "inlined lambdas are alpha-renamed"
|
||||||
|
;; This one should compile without errors; see above for an
|
||||||
|
;; explanation.
|
||||||
|
(and (compile
|
||||||
|
'(letrec ((fold (lambda (f x3 b null? car cdr)
|
||||||
|
(if (null? x3)
|
||||||
|
b
|
||||||
|
(f (car x3)
|
||||||
|
(fold f (cdr x3) b null? car cdr))))))
|
||||||
|
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
|
||||||
|
#:opts '(#:partial-eval? #t)
|
||||||
|
#:to 'glil)
|
||||||
|
#t))
|
||||||
|
|
||||||
(pass-if-peval
|
(pass-if-peval
|
||||||
;; Higher order, mutually recursive procedures.
|
;; Higher order, mutually recursive procedures.
|
||||||
(letrec ((even? (lambda (x)
|
(letrec ((even? (lambda (x)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue