diff options
Diffstat (limited to 'lib/csc/cps.csc')
| -rw-r--r-- | lib/csc/cps.csc | 88 |
1 files changed, 55 insertions, 33 deletions
diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc index 1b8df9d..4242681 100644 --- a/lib/csc/cps.csc +++ b/lib/csc/cps.csc @@ -98,6 +98,30 @@ (continuation update-continuation)) + (define-syntax singleton-continuation + (syntax-rules () + ((singleton-continuation (val) body ...) + (lambda (x multi) + (define (b val) body ...) + (if multi + (let ((v (new-ref))) + (make-primitive 'assert-singleton (list x) (list v) + (b v))) + (b x)))))) + + + (define-syntax varargs-continuation + (syntax-rules () + ((varargs-continuation (vals) body ...) + (lambda (x multi) + (define (b vals) body ...) + (if multi + (b x) + (let ((l (new-ref))) + (make-primitive 'cons (list x (make-constant '())) (list l) + (b l)))))))) + + (define (collect-functions-and-variables expr) (let ((names (letrec-names expr)) (gensyms (letrec-gensyms expr)) @@ -114,7 +138,7 @@ (list continuation args) (to-cps body - (lambda (z) + (varargs-continuation (z) (make-apply continuation (list z))))))) into functions else @@ -130,58 +154,56 @@ (match expr (_ when (or (constant? expr) (lexical-ref? expr)) - (continuation expr)) + (continuation expr #f)) ((% %library-ref . _) - (unless (library-ref? expr) - (error "wtf")) (define temp (new-ref)) (make-primitive 'peek (list *globals* expr) (list temp) - (continuation temp))) + (continuation temp #f))) ((% %lexical-set ref arg) (to-cps arg - (lambda (val) - (make-update ref val (continuation (make-constant #f)))))) + (singleton-continuation (val) + (make-update ref val (continuation (make-constant #f) #f))))) ((% %library-define ref arg) (to-cps arg - (lambda (val) - (make-update ref val (continuation (make-constant #f)))))) + (singleton-continuation (val) + (make-update ref val (continuation (make-constant #f) #f))))) ((% %define-syntax _ _) ; no-op - (continuation (make-constant #f))) + (continuation (make-constant #f) #f)) ((% %if test consequent alternate) (to-cps test - (lambda (val) + (singleton-continuation (val) (define continuation-ref (new-ref)) (define result-ref (new-ref)) (make-fix (list (make-closure continuation-ref (list result-ref) - (continuation result-ref))) + (continuation result-ref #t))) (make-branch val (to-cps consequent - (lambda (result) + (varargs-continuation (result) (make-apply continuation-ref (list result)))) (to-cps alternate - (lambda (result) + (varargs-continuation (result) (make-apply continuation-ref (list result))))))))) ((% %call proc args) (define return-address (new-ref)) (define result (new-ref)) (make-fix - (list (make-closure return-address (list result) (continuation result))) + (list (make-closure return-address (list result) (continuation result #t))) (to-cps proc - (lambda (f) + (singleton-continuation (f) (to-cps (loop for arg in (reverse args) with arglist = (make-constant '()) do (set! arglist (make-call-builtin 'cons (list arg arglist))) finally (return arglist)) - (lambda (v) + (singleton-continuation (v) (make-apply f (list return-address v)))))))) ((% %call-builtin 'call-with-current-continuation (proc)) (define return-address (new-ref)) @@ -191,12 +213,12 @@ (define arglist (new-ref)) (make-fix (list (make-closure return-address (list result1) - (continuation result1)) - (make-closure current-continuation (list k-unused result2) + (continuation result1 #t)) + (make-closure current-continuation (list (new-ref) result2) (make-apply return-address (list result2)))) (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist) (to-cps proc - (lambda (f) + (singleton-continuation (f) (make-apply f (list return-address arglist))))))) ((% %call-builtin 'call-with-values (producer consumer)) (define return-address (new-ref)) @@ -205,25 +227,25 @@ (define results (new-ref)) (make-fix (list (make-closure return-address (list result) - (continuation result)) + (continuation result #t)) (make-closure consumer-func (list results) (to-cps consumer - (lambda (c) + (singleton-continuation (c) (make-apply c (list return-address results)))))) (to-cps producer - (lambda (p) + (singleton-continuation (p) (make-apply p (list consumer-func (make-constant '()))))))) ((% %call-builtin 'apply (proc args)) (define return-address (new-ref)) (define result (new-ref)) (make-fix - (list (make-closure return-address (list result) (continuation result))) + (list (make-closure return-address (list result) (continuation result #t))) (to-cps proc - (lambda (f) + (singleton-continuation (f) (to-cps args - (lambda (l) + (singleton-continuation (l) (make-apply f (list return-address l)))))))) ((% %call-builtin op args) (define returns-value? (not (memq op '(poke exit)))) @@ -232,20 +254,20 @@ (if returns-value? (let ((result (new-ref))) (make-primitive op (reverse vals) (list result) - (continuation result))) + (continuation result #f))) (make-primitive op (reverse vals) '() - (continuation (make-constant #f))))) + (continuation (make-constant #f) #f)))) do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. (arg* arg)) (lambda (vals) (to-cps arg* - (lambda (val) + (singleton-continuation (val) (e* (cons val vals))))))) finally (return (expr '())))) ((% %sequence head tail) (to-cps head - (lambda (x) + (lambda (x multi) (to-cps tail continuation)))) @@ -257,9 +279,9 @@ (make-closure f (list k args) (to-cps body - (lambda (ret) + (varargs-continuation (ret) (make-apply k (list ret)))))) - (continuation f))) + (continuation f #f))) ((% %letrec _ _ _ _ body) (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) (if (null? variable-names) @@ -268,7 +290,7 @@ (let ((new-expr (loop for var in (reverse variable-names) for val in (reverse variable-values) with new-body = (to-cps body continuation) - do (set! new-body (to-cps val (lambda (x) + do (set! new-body (to-cps val (singleton-continuation (x) (make-update var x new-body)))) finally (return new-body)))) |