diff options
author | Andy Wingo <wingo@pobox.com> | 2012-03-02 15:51:05 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-03-02 16:47:39 +0100 |
commit | eebcacf41c4fe58ad8c9388d516a99f59212b223 (patch) | |
tree | 3ee075f97c63a103adc2434cf9eef4a2af4f392a | |
parent | 542aa859dede56545538fd90e6ee5b2abe3f5f25 (diff) | |
download | guile-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.scm | 36 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 20 |
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 () (_ _)) + _))))) |