summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2011-09-17 16:49:41 +0200
committerLudovic Courtès <ludo@gnu.org>2011-09-17 16:49:41 +0200
commit2ae0775e405de414e2da4806588b674c07793b8e (patch)
tree1329b0876275de277bcce7dd91a055d6e809716f /module/language/tree-il/optimize.scm
parent3f2d6efc7b61999a4522b1c35d6f4a875a2c74c0 (diff)
downloadguile-2ae0775e405de414e2da4806588b674c07793b8e.tar.gz
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>.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r--module/language/tree-il/optimize.scm71
1 files changed, 71 insertions, 0 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 86f1f2f35..cb7bdf645 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -41,6 +41,70 @@
(peval (expand-primitives! (resolve-primitives! x 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))
"Partially evaluate EXP in compilation environment CENV, with
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))))
(vlist-fold cons '() env)) ; todo: optimize
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)))
(catch 'match-error