[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 0f423f20aa
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 0f423f20aae6228431d3695e60ade937858110b8 |
Date: |
Thu, 21 May 2009 19:16:59 +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=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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. 0f423f20aae6228431d3695e60ade937858110b8,
Andy Wingo <=