diff options
Diffstat (limited to 'lib/csc/cps.csc')
| -rw-r--r-- | lib/csc/cps.csc | 148 |
1 files changed, 38 insertions, 110 deletions
diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc index ca6dbf4..1b8df9d 100644 --- a/lib/csc/cps.csc +++ b/lib/csc/cps.csc @@ -86,87 +86,6 @@ (make-lexical-ref 'generated-symbol (gensym))) - ; Converts an IR1 expression to an equivalent expression where every - ; procedure takes exactly one argument. - (define (argument-conversion expr) - (match expr - (_ when (or (constant? expr) - (lexical-ref? expr) - (library-ref? expr)) - expr) - ((% %lexical-set ref arg) - (make-lexical-set ref (argument-conversion arg))) - ((% %library-define ref arg) - (make-library-define ref (argument-conversion arg))) - ((% %define-syntax _ _) expr) - ((% %if test consequent alternate) - (make-if - (argument-conversion test) - (argument-conversion consequent) - (argument-conversion alternate))) - ((% %call proc args) - (define argvec (new-ref)) - (define nargs (length args)) - (make-call - (make-lambda (list argvec) #f - (make-sequence - (loop for arg in args - for i from 2 - with expr = (make-sequence - (make-call-builtin 'poke (list (make-constant 0) argvec (make-constant 0))) - (make-call-builtin 'poke (list (make-constant nargs) argvec (make-constant 1)))) - do (set! expr (make-sequence - expr - (make-call-builtin 'poke (list (argument-conversion arg) argvec (make-constant i))))) - finally (return expr)) - (make-call (argument-conversion proc) (list argvec)))) - (list (make-call-builtin 'alloc (list (make-constant (+ 2 nargs))))))) - ((% %call-builtin op args) - (make-call-builtin op (map argument-conversion args))) - ((% %sequence head tail) - (make-sequence - (argument-conversion head) - (argument-conversion tail))) - ((% %lambda args rest body) when rest - (define argvec (new-ref)) - (define nargs (length args)) - (make-lambda (list argvec) #f - (make-if (make-call-builtin 'lt (list (make-call-builtin 'peek (list argvec (make-constant 1))) - (make-constant nargs))) - (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec)) - (loop for arg in (reverse args) - for i downfrom (+ 1 nargs) - with expr = (make-call (make-lambda (list rest) #f - (argument-conversion body)) - (list - (argument-conversion - (make-call (make-library-ref 'vector->list '(csc based)) - (list argvec (make-constant nargs)))))) - ; I'm relying on beta reduction here. - do (set! expr (make-call (make-lambda (list arg) #f - expr) - (list (make-call-builtin 'peek (list argvec (make-constant i)))))) - finally (return expr))))) - ((% %lambda args _ body) - (define argvec (new-ref)) - (define nargs (length args)) - (make-lambda (list argvec) #f - (make-if (make-call-builtin 'eq (list (make-call-builtin 'peek (list argvec (make-constant 1))) - (make-constant nargs))) - (loop for arg in (reverse args) - for i downfrom (+ 1 nargs) - with expr = (argument-conversion body) - do (set! expr (make-call (make-lambda (list arg) #f - expr) - (list - (make-call-builtin 'peek (list argvec (make-constant i)))))) - finally (return expr)) - (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec))))) - ((% %letrec in-order? names gensyms exprs body) - (make-letrec in-order? names gensyms (map argument-conversion exprs) (argument-conversion body))) - (_ (error "Unexpected form in argument-conversion" expr)))) - - ; Update is a CPS expression that is used internally as part of ; CPS conversion. ; Update expressions are then removed by box-conversion. @@ -188,11 +107,11 @@ for value in vals if (lambda? value) collect (match value - ((% %lambda args _ body) + ((% %lambda args body) (define continuation (new-ref)) (make-closure (make-lexical-ref name gensym) - (cons continuation args) + (list continuation args) (to-cps body (lambda (z) @@ -249,7 +168,7 @@ alternate (lambda (result) (make-apply continuation-ref (list result))))))))) - ((% %call proc (arg)) + ((% %call proc args) (define return-address (new-ref)) (define result (new-ref)) (make-fix @@ -258,29 +177,32 @@ proc (lambda (f) (to-cps - arg + (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) (make-apply f (list return-address v)))))))) ((% %call-builtin 'call-with-current-continuation (proc)) (define return-address (new-ref)) - (define result (new-ref)) - (define argvec (new-ref)) + (define current-continuation (new-ref)) + (define result1 (new-ref)) + (define result2 (new-ref)) + (define arglist (new-ref)) (make-fix - (list (make-closure return-address (list result) - (continuation result))) - (make-primitive 'alloc (list (make-constant 3)) (list argvec) - (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 1) argvec (make-constant 1)) '() - (make-primitive 'poke (list return-address argvec (make-constant 2)) '() - (to-cps proc - (lambda (f) - (make-apply f (list return-address argvec)))))))))) + (list (make-closure return-address (list result1) + (continuation result1)) + (make-closure current-continuation (list k-unused result2) + (make-apply return-address (list result2)))) + (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist) + (to-cps proc + (lambda (f) + (make-apply f (list return-address arglist))))))) ((% %call-builtin 'call-with-values (producer consumer)) (define return-address (new-ref)) (define consumer-func (new-ref)) (define result (new-ref)) (define results (new-ref)) - (define argvec (new-ref)) (make-fix (list (make-closure return-address (list result) (continuation result)) @@ -288,14 +210,21 @@ (to-cps consumer (lambda (c) (make-apply c (list return-address results)))))) - (make-primitive 'alloc (list (make-constant 2)) (list argvec) - (make-primitive 'poke (list (make-constant 0) argvec (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 0) argvec (make-constant 1)) '() - (to-cps producer - (lambda (p) - (make-apply p (list consumer-func argvec))))))))) + (to-cps producer + (lambda (p) + (make-apply p (list consumer-func (make-constant '()))))))) ((% %call-builtin 'apply (proc args)) - (to-cps (make-call proc (list args)) continuation)) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) (continuation result))) + (to-cps + proc + (lambda (f) + (to-cps + args + (lambda (l) + (make-apply f (list return-address l)))))))) ((% %call-builtin op args) (define returns-value? (not (memq op '(poke exit)))) (loop for arg in (reverse args) @@ -320,12 +249,12 @@ (to-cps tail continuation)))) - ((% %lambda (arg) _ body) + ((% %lambda args body) (define f (new-ref)) (define k (new-ref)) (make-fix (list - (make-closure f (list k arg) + (make-closure f (list k args) (to-cps body (lambda (ret) @@ -384,7 +313,8 @@ ((% %fix funs body) (loop with m = (get-boxed body) for fun in funs - do (set! m (merge m (get-boxed (closure-body fun)))) + do (set! m (merge m (get-boxed + (closure-body fun)))) finally (return m))) (_ (error "Unexpected form in get-boxed" expr)))) @@ -477,9 +407,7 @@ (define (ir1->ir2 expr continuation) (box-conversion - (to-cps - (argument-conversion expr) - continuation))) + (to-cps expr continuation))) (define (hoist expr) |