summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-02-15 15:20:40 +0100
committerAndy Wingo <wingo@pobox.com>2013-02-15 15:20:40 +0100
commit91c763ee3f195dc0e26339608da01250d6924009 (patch)
tree5311099f53ab7d520d0b54ca010ac6969a057e19
parent85edd670f5674bd4c25547936b1faf61e2d7a397 (diff)
downloadguile-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.scm32
-rw-r--r--test-suite/tests/peval.test31
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.