From 0f423f20aae6228431d3695e60ade937858110b8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 May 2009 21:13:24 +0200 Subject: [PATCH] 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. --- 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 d5073ed0f..d476ddef9 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)))))))) (( src test then else) ;; TEST diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index d0fa74fab..5a8e2db30 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 4f177a979..9ba384f4f 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 724ea7960..eb33ae77f 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)))) +