This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=eebcacf41c4fe58ad8c9388d516a99f59212b223 The branch, stable-2.0 has been updated via eebcacf41c4fe58ad8c9388d516a99f59212b223 (commit) via 542aa859dede56545538fd90e6ee5b2abe3f5f25 (commit) via 20337139d20d0587ebf78c05a7efa6db2337d2e6 (commit) from e082b13b662309021c73bae1561fb5c6d191d258 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit eebcacf41c4fe58ad8c9388d516a99f59212b223 Author: Andy Wingo <[email protected]> Date: Fri Mar 2 15:51:05 2012 +0100 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. commit 542aa859dede56545538fd90e6ee5b2abe3f5f25 Author: Andy Wingo <[email protected]> Date: Fri Mar 2 16:39:56 2012 +0100 tree-il: fix `canonicalize!' for prompts * module/language/tree-il/canonicalize.scm (canonicalize!): Fix a bug in which the sense of `escape-only?' was reversed. We never saw this though, because for other reasons, no prompts were being identified as escape-only. commit 20337139d20d0587ebf78c05a7efa6db2337d2e6 Author: Andy Wingo <[email protected]> Date: Fri Mar 2 13:02:19 2012 +0100 more general treatment of call-with-prompt * module/language/tree-il/primitives.scm (*primitive-expand-table*): Don't limit the call-with-prompt to <prompt> transition to lambda expressions. Instead we can lexically bind the handler, and rely on peval to propagate a lambda expression. ----------------------------------------------------------------------- Summary of changes: module/language/tree-il/canonicalize.scm | 10 ++++---- module/language/tree-il/peval.scm | 36 ++++++++++++++++++++------- module/language/tree-il/primitives.scm | 31 +++++++++++------------ test-suite/tests/tree-il.test | 39 +++++++++++++++++++++++++++++- 4 files changed, 84 insertions(+), 32 deletions(-) diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm index 04f5612..c3229ca 100644 --- a/module/language/tree-il/canonicalize.scm +++ b/module/language/tree-il/canonicalize.scm @@ -1,6 +1,6 @@ ;;; Tree-il canonicalizer -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -58,10 +58,10 @@ (define (escape-only? handler) (match handler (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) - (tree-il-any (lambda (x) - (and (lexical-ref? x) - (eq? (lexical-ref-gensym x) cont))) - body)) + (not (tree-il-any (lambda (x) + (and (lexical-ref? x) + (eq? (lexical-ref-gensym x) cont))) + body))) (else #f))) (define (thunk-application? x) (match x diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 7aad399..7f8575e 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/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 23f5df5..c825d9a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -538,22 +538,21 @@ 'call-with-prompt (case-lambda ((src tag thunk handler) - ;; Sigh. Until the inliner does its job, manually inline - ;; (let ((h (lambda ...))) (prompt k x h)) - (cond - ((lambda? handler) - (let ((args-sym (gensym))) - (make-prompt - src tag (make-application #f thunk '()) - ;; If handler itself is a lambda, the inliner can do some - ;; trickery here. - (make-lambda-case - (tree-il-src handler) '() #f 'args #f '() (list args-sym) - (make-application #f (make-primitive-ref #f 'apply) - (list handler - (make-lexical-ref #f 'args args-sym))) - #f)))) - (else #f))) + (let ((handler-sym (gensym)) + (args-sym (gensym))) + (make-let + src '(handler) (list handler-sym) (list handler) + (make-prompt + src tag (make-application #f thunk '()) + ;; If handler itself is a lambda, the inliner can do some + ;; trickery here. + (make-lambda-case + (tree-il-src handler) '() #f 'args #f '() (list args-sym) + (make-application + #f (make-primitive-ref #f 'apply) + (list (make-lexical-ref #f 'handler handler-sym) + (make-lexical-ref #f 'args args-sym))) + #f))))) (else #f))) (hashq-set! *primitive-expand-table* diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index c4966b3..b47528e 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1532,6 +1532,33 @@ (lambda args args))) (const 1)) + ;; Handler lambda inlined + (pass-if-peval + resolve-primitives + (call-with-prompt tag + (lambda () 1) + (lambda (k x) x)) + (prompt (toplevel tag) + (const 1) + (lambda-case + (((k x) #f #f #f () (_ _)) + (lexical x _))))) + + ;; Handler toplevel not inlined + (pass-if-peval + resolve-primitives + (call-with-prompt tag + (lambda () 1) + handler) + (let (handler) (_) ((toplevel handler)) + (prompt (toplevel tag) + (const 1) + (lambda-case + ((() #f args #f () (_)) + (apply (primitive @apply) + (lexical handler _) + (lexical args _))))))) + (pass-if-peval resolve-primitives ;; `while' without `break' or `continue' has no prompts and gets its @@ -1548,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 () (_ _)) + _))))) hooks/post-receive -- GNU Guile
