mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +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 exp
(make-lambda src meta (for-values body)))))) (make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <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)) (let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars)) (new (fresh-gensyms vars))
(env (fold extend-env env gensyms (env (fold extend-env env gensyms
(make-unbound-operands vars new))) (make-unbound-operands vars new)))
(new-sym (lambda (old) (new-sym (lambda (old)
(operand-sym (cdr (vhash-assq old env)))))) (operand-sym (cdr (vhash-assq old env)))))
(make-lambda-case src req opt rest (body (loop body env counter ctx)))
(match kw (or
((aok? (kw name old) ...) ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(cons aok? (map list kw name (map new-sym old)))) (lift-applied-lambda body new)
(_ #f)) (make-lambda-case src req opt rest
(map (cut loop <> env counter 'value) inits) (match kw
new ((aok? (kw name old) ...)
(loop body env counter ctx) (cons aok? (map list kw name (map new-sym old))))
(and alt (for-tail alt))))) (_ #f))
(map (cut loop <> env counter 'value) inits)
new
body
(and alt (for-tail alt))))))
(($ <sequence> src exps) (($ <sequence> src exps)
(let lp ((exps exps) (effects '())) (let lp ((exps exps) (effects '()))
(match exps (match exps

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

@ -1537,14 +1537,12 @@
resolve-primitives resolve-primitives
(call-with-prompt tag (call-with-prompt tag
(lambda () 1) (lambda () 1)
(lambda args args)) (lambda (k x) x))
(prompt (toplevel tag) (prompt (toplevel tag)
(const 1) (const 1)
(lambda-case (lambda-case
((() #f args #f () (_)) (((k x) #f #f #f () (_ _))
(apply (primitive @apply) (lexical x _)))))
(lambda _ _)
(lexical args _))))))
;; Handler toplevel not inlined ;; Handler toplevel not inlined
(pass-if-peval (pass-if-peval
@ -1577,7 +1575,17 @@
((() #f #f #f () ()) ((() #f #f #f () ())
(apply (lexical loop _)))))) (apply (lexical loop _))))))
(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 () (_ _))
_)))))