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