diff options
Diffstat (limited to 'lib/csc')
| -rw-r--r-- | lib/csc/cps-test.csc | 192 | ||||
| -rw-r--r-- | lib/csc/cps.csc | 148 | ||||
| -rw-r--r-- | lib/csc/ir1.csc | 7 | ||||
| -rw-r--r-- | lib/csc/macros-test.csc | 37 | ||||
| -rw-r--r-- | lib/csc/macros.csc | 32 |
5 files changed, 87 insertions, 329 deletions
diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc index ab92646..8bef0aa 100644 --- a/lib/csc/cps-test.csc +++ b/lib/csc/cps-test.csc @@ -139,18 +139,9 @@ (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))) - (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list (test-ref 'generated-symbol)) + (make-primitive 'cons (list (make-constant 10) (test-ref 'generated-symbol)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20))) tail) transform-ir2)) @@ -199,49 +190,13 @@ transform-ir2)) - ; It's pretty bad - (test closure-rest + (test closure (assert-equal (make-fix - (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'lt (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) - (make-fix (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c)) - (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 3)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'vector->list '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))))) + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c)) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) (ir1->ir2 (make-lambda - '() (test-ref 'c) (make-constant 5)) tail) @@ -254,44 +209,17 @@ (assert-equal (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))) - (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))) + (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) (ir1->ir2 (make-letrec #f '(f) (list f) - (list (make-lambda (list x) #f x)) + (list (make-lambda x x)) (make-call (make-lexical-ref 'f f) (list (make-constant 10)))) tail) transform-ir2)) @@ -320,25 +248,15 @@ (test letrec-in-order-function (assert-equal (make-fix - (list (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-apply (test-ref 'generated-symbol) (list (make-constant 5))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args)) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) (make-apply (test-ref 'tail) (list (make-constant 10)))) (ir1->ir2 (make-letrec #t '(f) (list (gensym)) - (list (make-lambda '() #f (make-constant 5))) + (list (make-lambda (test-ref 'args) (make-constant 5))) (make-constant 10)) tail) transform-ir2)) @@ -355,41 +273,21 @@ (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'args)) + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) - (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant '())))))) (ir1->ir2 (make-letrec #t '(f x) (list f x) - (list (make-lambda '() #f (make-lexical-ref 'x x)) + (list (make-lambda (test-ref 'args) (make-lexical-ref 'x x)) (make-call (make-lexical-ref 'f f) '())) (make-lexical-ref 'x x)) tail) @@ -401,37 +299,18 @@ (assert-equal (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) - (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'x) (make-constant 0)) '() - (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'args)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'args) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'args) (make-constant 0)) '() + (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) (make-apply (test-ref 'tail) (list (make-constant 5)))) (ir1->ir2 (make-letrec #f '(f) (list (gensym)) - (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f - (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10)))) + (list (make-lambda (make-lexical-ref 'args test-sym) + (make-lexical-set (make-lexical-ref 'args test-sym) (make-constant 10)))) (make-constant 5)) tail) transform-ir2)) @@ -441,19 +320,8 @@ (assert-equal (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f)) (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'eq (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-apply (test-ref 'generated-symbol) (list (make-constant 10))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'args)) + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '() (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '() (make-apply (test-ref 'tail) (list (make-constant #f))))))) @@ -461,7 +329,7 @@ #f '(f) (list test-sym) - (list (make-lambda '() #f (make-constant 10))) + (list (make-lambda (test-ref 'args) (make-constant 10))) (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5))) tail) transform-ir2)) 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) diff --git a/lib/csc/ir1.csc b/lib/csc/ir1.csc index 5cc0bf0..c88123e 100644 --- a/lib/csc/ir1.csc +++ b/lib/csc/ir1.csc @@ -29,7 +29,6 @@ if? lambda-arguments lambda-body - lambda-rest lambda? letrec-expression letrec-gensyms @@ -192,14 +191,12 @@ ; <lambda> body - ; A closure. Arguments is a list of lexical-refs. - ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter. + ; A closure. Arguments is a lexical-ref. (define-match-record-type <lambda> - (make-lambda arguments rest body) + (make-lambda arguments body) lambda? %lambda (arguments lambda-arguments) - (rest lambda-rest) (body lambda-body)) diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc index be573cb..ee4e295 100644 --- a/lib/csc/macros-test.csc +++ b/lib/csc/macros-test.csc @@ -242,12 +242,12 @@ (test builtin-syntax-rules-define (assert-equal (make-library-define (make-library-ref 'exit 'main) - (make-lambda '() #f (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main)))))) + (make-lambda (test-ref 'args) (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main)))))) (expand-body 'main '((let-syntax (define (syntax-rules () - ((define (f . args) body ...) + ((define (f) body ...) (builtin-define f (lambda args body ...))))) (define (exit) (call-builtin exit code)))) @@ -259,40 +259,25 @@ (make-lexical-ref sym (gensym))) - (test builtin-lambda-rest - (assert-equal - (make-lambda (list - (test-ref 'a) - (test-ref 'b) - (test-ref 'c)) - (test-ref 'd) - (make-sequence (make-constant #f) (make-constant 5))) - (expand-body 'main - '((lambda - (a b c . d) (quote 5))) - builtins-environment) - transform-ir1)) - - (test builtin-lambda-ref (assert-equal - (make-lambda (list (test-ref 'x)) #f - (make-sequence (make-constant #f) (test-ref 'x))) + (make-lambda (test-ref 'args) + (make-sequence (make-constant #f) (test-ref 'args))) (expand-body 'main - '((lambda (x) x)) + '((lambda args args)) builtins-environment) transform-ir1)) (test builtin-case-lambda-defines (assert-equal - (make-lambda (list (test-ref 'x)) #f + (make-lambda (test-ref 'args) (make-letrec #t '(a b) (list (gensym) (gensym)) (list (make-constant 6) (test-ref 'a)) (make-sequence (make-constant #f) (make-constant 7)))) (expand-body 'main - '((lambda (x) + '((lambda args (builtin-define a (quote 6)) (builtin-define b a) (quote 7))) @@ -325,13 +310,13 @@ (test builtin-lexical-set (assert-equal - (make-lambda (list (test-ref 'x)) #f + (make-lambda (test-ref 'args) (make-sequence (make-constant #f) - (make-lexical-set (test-ref 'x) (make-constant 5)))) + (make-lexical-set (test-ref 'args) (make-constant 5)))) (expand-body 'main - '((lambda (x) - (set! x 5))) + '((lambda args + (set! args 5))) builtins-environment) transform-ir1)) diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc index 6278142..cf4549f 100644 --- a/lib/csc/macros.csc +++ b/lib/csc/macros.csc @@ -666,18 +666,6 @@ (_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x))))))) - (define (split-args-rest formals) - (syntax-case formals - ('() - (values '() #f)) - ((var . vars) when (identifier? var) - (let-values (((args rest) (split-args-rest vars))) - (values (cons (identifier-name var) args) rest))) - (var when (identifier? var) - (values '() (identifier-name var))) - (_ (raise-syntax-error "unexpected form in split-args-rest" (clean-syntax formals))))) - - (define (expand-lambda-body-rest body env) (let loop ((body body) (expanded-body (make-constant #f))) @@ -731,20 +719,12 @@ (make-macro-transformer (lambda (x env) (syntax-case x - ((_ formals . body) - (let-values (((args rest) (split-args-rest formals))) - (define refs (map (lambda (name) - (make-lexical-ref name (gensym))) - args)) - (loop for ref in refs - do (set! env (add-binding (lexical-ref-name ref) ref env))) - (make-lambda - refs - (if rest - (make-lexical-ref rest (gensym)) - #f) - (expand-lambda-body body env)))) - (_ (raise-syntax-error "unexpected form in lambda" x)))))) + ((_ args . body) when (identifier? args) + (define ref (make-lexical-ref (identifier-name args) (gensym))) + (set! env (add-binding args ref env)) + (make-lambda + ref + (expand-lambda-body body env))))))) (define builtin-define |