guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-67-geebcac


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-67-geebcacf
Date: Fri, 02 Mar 2012 15:49:04 +0000

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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]