diff options
author | Andy Wingo <wingo@pobox.com> | 2013-02-15 15:20:40 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-02-15 15:20:40 +0100 |
commit | 91c763ee3f195dc0e26339608da01250d6924009 (patch) | |
tree | 5311099f53ab7d520d0b54ca010ac6969a057e19 | |
parent | 85edd670f5674bd4c25547936b1faf61e2d7a397 (diff) | |
download | guile-91c763ee3f195dc0e26339608da01250d6924009.tar.gz |
local rewrite for apply to a let-bound rest list
* module/language/tree-il/peval.scm (peval): Add a special-case inlining
pattern for apply to a let-bound rest arg that preserves effect
ordering.
* test-suite/tests/peval.test ("partial evaluation"): Add a test, and
update an older test with a better result.
-rw-r--r-- | module/language/tree-il/peval.scm | 32 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 31 |
2 files changed, 58 insertions, 5 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 895531337..da3f4a82c 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -437,6 +437,13 @@ top-level bindings from ENV and return the resulting expression." new)) vars)) + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + (define (assigned-lexical? sym) (var-set? (lookup-var sym))) @@ -872,6 +879,31 @@ top-level bindings from ENV and return the resulting expression." (begin (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ <let> src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args)) + ($ <application> asrc + ($ <primitive-ref> _ (or 'apply '@apply)) + (proc args ... + ($ <lexical-ref> _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-application + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) (($ <let> src names gensyms vals body) (define (compute-alias exp) ;; It's very common for macros to introduce something like: diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index da633448c..923b0d16a 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -943,12 +943,33 @@ (lambda () (lambda-case ((() #f #f #f () ()) + (let (_) (_) ((apply (toplevel foo!))) + (let (z) (_) ((toplevel z)) + (apply (primitive 'list) + (lexical z _) + (lexical _ _)))))))) + + (pass-if-peval resolve-primitives + ;; Rest args referenced more than once are not destructured. + (lambda () + (let ((args (list 'foo))) + (set-car! args 'bar) + (@apply + (lambda (z x) + (list z x)) + z + args))) + (lambda () + (lambda-case + ((() #f #f #f () ()) (let (args) (_) - ((apply (primitive list) (apply (toplevel foo!)))) - (apply (primitive @apply) - (lambda . _) - (toplevel z) - (lexical args _))))))) + ((apply (primitive list) (const foo))) + (begin + (apply (primitive set-car!) (lexical args _) (const bar)) + (apply (primitive @apply) + (lambda . _) + (toplevel z) + (lexical args _)))))))) (pass-if-peval resolve-primitives ;; Let-values inlining, even with consumers with rest args. |