mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

peval: inline applications of lambda to rest args

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2012-03-02 15:51:05 +01:00
parent 542aa859de
commit eebcacf41c
2 changed files with 40 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

36
module/language/tree-il/peval.scm
View file

@ -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

20
test-suite/tests/tree-il.test
View file

@ -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 () (_ _))
_)))))