[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 0f423f20aae6228431d3695e60ade937858110b8

[Andy Wingo]

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=0f423f20aae6228431d3695e60ade937858110b8

The branch, syncase-in-boot-9 has been updated
       via  0f423f20aae6228431d3695e60ade937858110b8 (commit)
      from  30a5e062d022aafdb72cea648f3a4de0e72feb6d (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 0f423f20aae6228431d3695e60ade937858110b8
Author: Andy Wingo <address@hidden>
Date:   Thu May 21 21:13:24 2009 +0200

    fix apply and call/cc in drop contexts
    
    * module/language/tree-il/compile-glil.scm (flatten): Actually apply only
      needs one arg after the proc. And shit, call/cc and apply in drop
      contexts also need to be able to return arbitrary numbers of values;
      work it by trampolining through their applicative (non-@) definitions.
      Also, simplify the single-valued drop case to avoid the
      truncate-values.
    
    * module/language/tree-il/inline.scm (call/cc):
    * module/language/tree-il/optimize.scm (*interesting-primitive-names*):
      Define call/cc as "interesting". Perhaps we should be hashing on value
      and not on variable.
    
    * test-suite/tests/tree-il.test ("application"): Fix up test for new,
      sleeker output. (Actually the GLIL is more verbose, but the assembly is
      better.)
      ("apply", "call/cc"): Add some more tests.

-----------------------------------------------------------------------

Summary of changes:
 module/language/tree-il/compile-glil.scm |   49 ++++++++++++++++++++---------
 module/language/tree-il/inline.scm       |    3 ++
 module/language/tree-il/optimize.scm     |    1 +
 test-suite/tests/tree-il.test            |   46 ++++++++++++++++++++++++++-
 4 files changed, 82 insertions(+), 17 deletions(-)

diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index d5073ed..d476dde 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -184,7 +184,7 @@
        (cond
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@apply)
-              (>= (length args) 2))
+              (>= (length args) 1))
          (let ((proc (car args))
                (args (cdr args)))
            (cond
@@ -200,13 +200,23 @@
                 (emit-code src (make-glil-call 'return/values* (length 
args))))))
 
             (else
-             (comp-push proc)
-             (for-each comp-push args)
              (case context
-               ((drop) (emit-code src (make-glil-call 'apply (1+ (length 
args))))
-                       (emit-code src (make-glil-call 'drop 1)))
-               ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length 
args)))))
-               ((push) (emit-code src (make-glil-call 'apply (1+ (length 
args))))))))))
+               ((tail)
+                (comp-push proc)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'goto/apply (1+ (length 
args)))))
+               ((push)
+                (comp-push proc)
+                (for-each comp-push args)
+                (emit-code src (make-glil-call 'apply (1+ (length args)))))
+               ((drop)
+                ;; Well, shit. The proc might return any number of
+                ;; values (including 0), since it's in a drop context,
+                ;; yet apply does not create a MV continuation. So we
+                ;; mv-call out to our trampoline instead.
+                (comp-drop
+                 (make-application src (make-primitive-ref #f 'apply)
+                                   (cons proc args)))))))))
 
         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
               (not (eq? context 'push)))
@@ -248,12 +258,19 @@
         ((and (primitive-ref? proc)
               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
               (= (length args) 1))
-         (comp-push (car args))
          (case context
-           ((tail) (emit-code src (make-glil-call 'goto/cc 1)))
-           ((push) (emit-code src (make-glil-call 'call/cc 1)))
-           ((drop) (emit-code src (make-glil-call 'call/cc 1))
-                   (emit-code src (make-glil-call 'drop 1)))))
+           ((tail)
+            (comp-push (car args))
+            (emit-code src (make-glil-call 'goto/cc 1)))
+           ((push)
+            (comp-push (car args))
+            (emit-code src (make-glil-call 'call/cc 1)))
+           ((drop)
+            ;; Crap. Just like `apply' in drop context.
+            (comp-drop
+             (make-application
+              src (make-primitive-ref #f 'call-with-current-continuation)
+              args)))))
 
         ((and (primitive-ref? proc)
               (or (hash-ref *primcall-ops*
@@ -273,12 +290,14 @@
              ((tail) (emit-code src (make-glil-call 'goto/args len)))
              ((push) (emit-code src (make-glil-call 'call len)))
              ((drop)
-              (let ((MV (make-label)))
+              (let ((MV (make-label)) (POST (make-label)))
                 (emit-code src (make-glil-mv-call len MV))
-                (emit-code #f (make-glil-const 1))
+                (emit-code #f (make-glil-call 'drop 1))
+                (emit-branch #f 'br POST)
                 (emit-label MV)
                 (emit-code #f (make-glil-mv-bind '() #f))
-                (emit-code #f (make-glil-unbind)))))))))
+                (emit-code #f (make-glil-unbind))
+                (emit-label POST))))))))
 
       ((<conditional> src test then else)
        ;;     TEST
diff --git a/module/language/tree-il/inline.scm 
b/module/language/tree-il/inline.scm
index d0fa74f..5a8e2db 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -147,4 +147,7 @@
 (define-primitive-expander call-with-current-continuation (proc)
   (@call-with-current-continuation proc))
 
+(define-primitive-expander call/cc (proc)
+  (@call-with-current-continuation proc))
+
 (define-primitive-expander values (x) x)
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 4f177a9..9ba384f 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -45,6 +45,7 @@
   '(apply @apply
     call-with-values @call-with-values
     call-with-current-continuation @call-with-current-continuation
+    call/cc
     values
     eq? eqv? equal?
     = < > <= >= zero?
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 724ea79..eb33ae7 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -71,9 +71,11 @@
   (assert-tree-il->glil/pmatch
    (begin (apply (toplevel foo) (const 1)) (void))
    (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
-            (const 1) (label ,l2) (mv-bind () #f) (unbind)
+            (call drop 1) (branch br ,l2)
+            (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l4)
             (void) (call return 1))
-   (eq? l1 l2))
+   (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel bar)))
    (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
@@ -415,3 +417,43 @@
             (unbind)
             (unbind))
    (eq? l1 l2)))
+
+(with-test-prefix "apply"
+  (assert-tree-il->glil
+   (apply (primitive @apply) (toplevel foo) (toplevel bar))
+   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 
2)))
+  (assert-tree-il->glil/pmatch
+   (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+   (program 0 0 0 0 ()
+            (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) 
(mv-call 2 ,l1)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l4)
+            (void) (call return 1))
+   (and (eq? l1 l3) (eq? l2 l4)))
+  (assert-tree-il->glil
+   (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel 
baz)))
+   (program 0 0 0 0 ()
+            (toplevel ref foo)
+            (toplevel ref bar) (toplevel ref baz) (call apply 2)
+            (call goto/args 1))))
+
+(with-test-prefix "call/cc"
+  (assert-tree-il->glil
+   (apply (primitive @call-with-current-continuation) (toplevel foo))
+   (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+  (assert-tree-il->glil/pmatch
+   (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) 
(void))
+   (program 0 0 0 0 ()
+            (toplevel ref call-with-current-continuation) (toplevel ref foo) 
(mv-call 1 ,l1)
+            (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
+            (label ,l4)
+            (void) (call return 1))
+   (and (eq? l1 l3) (eq? l2 l4)))
+  (assert-tree-il->glil
+   (apply (toplevel foo)
+          (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+   (program 0 0 0 0 ()
+            (toplevel ref foo)
+            (toplevel ref bar) (call call/cc 1)
+            (call goto/args 1))))
+


hooks/post-receive
-- 
GNU Guile