summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-03-02 15:51:05 +0100
committerAndy Wingo <wingo@pobox.com>2012-03-02 16:47:39 +0100
commiteebcacf41c4fe58ad8c9388d516a99f59212b223 (patch)
tree3ee075f97c63a103adc2434cf9eef4a2af4f392a
parent542aa859dede56545538fd90e6ee5b2abe3f5f25 (diff)
downloadguile-eebcacf41c4fe58ad8c9388d516a99f59212b223.tar.gz
peval: inline applications of lambda to rest args
* module/language/tree-il/peval.scm (peval): Add optimization to hoist the inner procedure out of e.g. (lambda args (apply (lambda ...) args)) This commit restores the ability to detect escape-only prompts at compile-time. * test-suite/tests/tree-il.test: Update test for prompt with a lambda, and add a specific test for lambda application.
-rw-r--r--module/language/tree-il/peval.scm36
-rw-r--r--test-suite/tests/tree-il.test20
2 files changed, 40 insertions, 16 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 7aad3997a..7f8575e58 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1219,21 +1219,37 @@ top-level bindings from ENV and return the resulting expression."
exp
(make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (define (lift-applied-lambda body gensyms)
+ (and (not opt) rest (not kw)
+ (match body
+ (($ <application> _
+ ($ <primitive-ref> _ '@apply)
+ (($ <lambda> _ _ lcase)
+ ($ <lexical-ref> _ _ sym)
+ ...))
+ (and (equal? sym gensyms)
+ (not (lambda-case-alternate lcase))
+ lcase))
+ (_ #f))))
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(env (fold extend-env env gensyms
(make-unbound-operands vars new)))
(new-sym (lambda (old)
- (operand-sym (cdr (vhash-assq old env))))))
- (make-lambda-case src req opt rest
- (match kw
- ((aok? (kw name old) ...)
- (cons aok? (map list kw name (map new-sym old))))
- (_ #f))
- (map (cut loop <> env counter 'value) inits)
- new
- (loop body env counter ctx)
- (and alt (for-tail alt)))))
+ (operand-sym (cdr (vhash-assq old env)))))
+ (body (loop body env counter ctx)))
+ (or
+ ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+ (lift-applied-lambda body new)
+ (make-lambda-case src req opt rest
+ (match kw
+ ((aok? (kw name old) ...)
+ (cons aok? (map list kw name (map new-sym old))))
+ (_ #f))
+ (map (cut loop <> env counter 'value) inits)
+ new
+ body
+ (and alt (for-tail alt))))))
(($ <sequence> src exps)
(let lp ((exps exps) (effects '()))
(match exps
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 390a51b51..b47528e35 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1537,14 +1537,12 @@
resolve-primitives
(call-with-prompt tag
(lambda () 1)
- (lambda args args))
+ (lambda (k x) x))
(prompt (toplevel tag)
(const 1)
(lambda-case
- ((() #f args #f () (_))
- (apply (primitive @apply)
- (lambda _ _)
- (lexical args _))))))
+ (((k x) #f #f #f () (_ _))
+ (lexical x _)))))
;; Handler toplevel not inlined
(pass-if-peval
@@ -1577,7 +1575,17 @@
((() #f #f #f () ())
(apply (lexical loop _))))))
(apply (lexical loop _)))))))
- (apply (lexical lp _)))))
+ (apply (lexical lp _))))
+
+ (pass-if-peval
+ resolve-primitives
+ (lambda (a . rest)
+ (apply (lambda (x y) (+ x y))
+ a rest))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ _)))))