diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-24 17:15:32 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-24 17:15:32 +0200 |
commit | 250991010f08d6a9e16dabad32941c948a8b4ba4 (patch) | |
tree | a4d39fbf43345e85a3b77d82f962131a7eeccbef | |
parent | 9e8a5b6637c71b909a0c3ca42e6756d0b2177a05 (diff) | |
download | guile-250991010f08d6a9e16dabad32941c948a8b4ba4.tar.gz |
peval: various bugfixes
* module/language/tree-il/optimize.scm (alpha-rename): Rename the
init
expressions of a <lambda-case>.
(peval): Coalesce the <let-values> clauses.
Fix pure-expression? matching of <lambda> clauses.
Loop over and maybe-unconst the inits of a <lambda-case>.
-rw-r--r-- | module/language/tree-il/optimize.scm | 39 |
1 files changed, 21 insertions, 18 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 217264a26..80665bc09 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -77,7 +77,8 @@ references to the new symbols." name (take-right new (length old))))) (_ #f)) - inits new + (map (cut loop <> mapping) inits) + new (loop body mapping) (and alt (loop alt mapping))))) (($ <lexical-ref> src name gensym) @@ -339,7 +340,7 @@ it does not handle <fix> and <let-values>, it should be called before (and (effect-free-primitive? name) (not (constructor-primitive? name)) (every loop args))) - (($ <application> _ ($ <lambda> _ body) args) + (($ <application> _ ($ <lambda> _ _ body) args) (and (loop body) (every loop args))) (($ <sequence> _ exps) (every loop exps)) @@ -477,21 +478,20 @@ it does not handle <fix> and <let-values>, it should be called before (if (const? body*) body (make-fix src names gensyms vals body)))) - (($ <let-values> lv-src producer - ($ <lambda-case> src req #f #f #f () gensyms body #f)) - ;; Peval both producer and consumer, then try to inline. If - ;; that succeeds, peval again. - (let* ((producer (maybe-unconst producer (loop producer env calls))) - (body (maybe-unconst body (loop body env calls)))) - (cond - ((inline-values producer src req gensyms body) - => (lambda (exp) (loop exp env calls))) - (else - (make-let-values lv-src producer - (make-lambda-case src req #f #f #f '() - gensyms body #f)))))) - (($ <let-values>) - exp) + (($ <let-values> lv-src producer consumer) + ;; Peval the producer, then try to inline the consumer into + ;; the producer. If that succeeds, peval again. Otherwise + ;; reconstruct the let-values, pevaling the consumer. + (let ((producer (maybe-unconst producer (loop producer env calls)))) + (or (match consumer + (($ <lambda-case> src req #f #f #f () gensyms body #f) + (cond + ((inline-values producer src req gensyms body) + => (cut loop <> env calls)) + (else #f))) + (_ #f)) + (make-let-values lv-src producer + (loop consumer env calls))))) (($ <dynwind> src winder body unwinder) (make-dynwind src (loop winder env calls) (loop body env calls) @@ -616,7 +616,10 @@ it does not handle <fix> and <let-values>, it should be called before (($ <lambda> src meta body) (make-lambda src meta (loop body env calls))) (($ <lambda-case> src req opt rest kw inits gensyms body alt) - (make-lambda-case src req opt rest kw inits gensyms + (make-lambda-case src req opt rest kw + (map maybe-unconst inits + (map (cut loop <> env calls) inits)) + gensyms (maybe-unconst body (loop body env calls)) alt)) (($ <sequence> src exps) |