diff options
author | Ludovic Courtès <ludo@gnu.org> | 2011-09-17 16:49:41 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2011-09-17 16:49:41 +0200 |
commit | 2ae0775e405de414e2da4806588b674c07793b8e (patch) | |
tree | 1329b0876275de277bcce7dd91a055d6e809716f /module/language/tree-il/optimize.scm | |
parent | 3f2d6efc7b61999a4522b1c35d6f4a875a2c74c0 (diff) | |
download | guile-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.scm | 71 |
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 |