mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

fix apply and call/cc in drop contexts

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-05-21 21:13:24 +02:00
parent 30a5e062d0
commit 0f423f20aa
4 changed files with 82 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

49
module/language/tree-il/compile-glil.scm
View file

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

3
module/language/tree-il/inline.scm
View file

@ -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)

1
module/language/tree-il/optimize.scm
View file

@ -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?

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

@ -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))))