diff options
Diffstat (limited to 'csc/cps.csc')
| -rw-r--r-- | csc/cps.csc | 237 |
1 files changed, 115 insertions, 122 deletions
diff --git a/csc/cps.csc b/csc/cps.csc index cf4a26d..b6decbb 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -1,37 +1,28 @@ (define-library (csc cps) (export ir1->ir2) - (import (only (csc gensym) gensym) + (import (scheme base) + (only (csc gensym) gensym) (only (csc hash-map) insert make-map merge) (only (csc ir1) - call-arguments - call-procedure + %call + %define-syntax + %if + %lambda + %letrec + %lexical-set + %library-define + %sequence call? constant? - define-syntax? - if-alternate - if-consequent - if-test if? - lambda-arguments - lambda-body - lambda-rest lambda? - letrec-expression - letrec-gensyms - letrec-in-order? - letrec-names - letrec-values letrec? lexical-ref? - lexical-set-expression - lexical-set-ref lexical-set? - library-define-expression - library-define-ref library-define? library-ref? make-call @@ -40,8 +31,6 @@ make-lexical-ref make-lexical-set make-sequence - sequence-head - sequence-tail sequence?) (only (csc ir2) make-apply @@ -57,7 +46,7 @@ (only (csc loop) loop return) - (scheme base)) + (only (csc match) match)) (begin @@ -66,48 +55,52 @@ (define (collect-functions-and-variables expr) - (loop for name in (letrec-names expr) - for gensym in (letrec-gensyms expr) - for value in (letrec-values expr) - if (lambda? value) - collect (let ((continuation (new-ref))) - (make-closure - (make-lexical-ref name gensym) - (cons continuation (lambda-arguments value)) - (lambda-rest value) - (ir1->ir2 - (lambda-body value) - (lambda (z) - (make-apply continuation (list z)))))) - into functions - else - collect (make-lexical-ref name gensym) into variable-names - and collect value into variable-values - finally (return (values functions variable-names variable-values)))) + (match expr + ((% %letrec _ names gensyms vals _) + (loop for name in names + for gensym in gensyms + for value in vals + if (lambda? value) + collect (match value + ((% %lambda args rest body) + (define continuation (new-ref)) + (make-closure + (make-lexical-ref name gensym) + (cons continuation args) + rest + (ir1->ir2 + body + (lambda (z) + (make-apply continuation (list z))))))) + into functions + else + collect (make-lexical-ref name gensym) into variable-names + and collect value into variable-values + finally (return (values functions variable-names variable-values)))))) (define (ir1->ir2 expr continuation) - (cond - ((or (constant? expr) - (lexical-ref? expr) - (library-ref? expr)) + (match expr + (_ (when (or (constant? expr) + (lexical-ref? expr) + (library-ref? expr))) (continuation expr)) - ((lexical-set? expr) + ((% %lexical-set ref arg) (ir1->ir2 - (lexical-set-expression expr) + arg (lambda (val) - (make-update (lexical-set-ref expr) val (continuation (make-constant #f)))))) - ((library-define? expr) + (make-update ref val (continuation (make-constant #f)))))) + ((% %library-define ref arg) (ir1->ir2 - (library-define-expression expr) + arg (lambda (val) - (make-update (library-define-ref expr) val (continuation (make-constant #f)))))) - ((define-syntax? expr) + (make-update ref val (continuation (make-constant #f)))))) + ((% %define-syntax _ _) ; no-op (continuation (make-constant #f))) - ((if? expr) + ((% %if test consequent alternate) (ir1->ir2 - (if-test expr) + test (lambda (val) (define continuation-ref (new-ref)) (define result-ref (new-ref)) @@ -116,81 +109,81 @@ (continuation result-ref))) (make-branch val (ir1->ir2 - (if-consequent expr) + consequent (lambda (result) (make-apply continuation-ref (list result)))) (ir1->ir2 - (if-alternate expr) + alternate (lambda (result) (make-apply continuation-ref (list result))))))))) - ((call? expr) - (let ((return-address (new-ref)) - (result (new-ref))) - (make-fix - (list (make-closure return-address (list result) #f (continuation result))) - (ir1->ir2 - (call-procedure expr) - (lambda (f) - ; Technically the order of evaluation is unspecified. - ; We evaluate expressions left to right. - ; - ; I would use the loop macro, but it mutates the loop - ; variables which plays badly with building a lambda. - (let loop ((args (reverse (call-arguments expr))) - (exprs (lambda (vals) - (make-apply f (cons return-address (reverse vals)))))) - (if (null? args) - (exprs '()) - (loop (cdr args) - (lambda (vals) - (ir1->ir2 - (car args) - (lambda (val) - (exprs (cons val vals))))))))))))) - ((sequence? expr) + ((% %call proc args) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) #f (continuation result))) + (ir1->ir2 + proc + (lambda (f) + ; Technically the order of evaluation is unspecified. + ; We evaluate expressions left to right. + ; + ; I would use the loop macro, but it mutates the loop + ; variables which plays badly with building a lambda. + (let loop ((args* (reverse args)) + (exprs (lambda (vals) + (make-apply f (cons return-address (reverse vals)))))) + (if (null? args*) + (exprs '()) + (loop (cdr args*) + (lambda (vals) + (ir1->ir2 + (car args*) + (lambda (val) + (exprs (cons val vals)))))))))))) + ((% %sequence head tail) (ir1->ir2 - (sequence-head expr) + head (lambda (x) (ir1->ir2 - (sequence-tail expr) - continuation)))) - ((lambda? expr) - (let ((f (new-ref)) - (k (new-ref))) - (make-fix - (list - (make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr) - (ir1->ir2 - (lambda-body expr) - (lambda (ret) - (make-apply k (list ret)))))) - (continuation f)))) - ((letrec? expr) - (let-values (((functions variable-names variable-values) (collect-functions-and-variables expr))) - (make-fix functions - (ir1->ir2 - ; We re-write a letrec into a corresponding lambda form. - (if (letrec-in-order? expr) - (loop for name in (reverse variable-names) - for value in (reverse variable-values) - for expr = (make-call - (make-lambda - (list name) - #f - (letrec-expression expr)) - (list value)) - then (make-call - (make-lambda - (list name) - #f - expr) - (list value)) - finally (return expr)) - (make-call - (make-lambda - variable-names - #f - (letrec-expression expr)) - variable-values)) + tail continuation)))) - (else (error "unexpected type in ir1->ir2" expr)))))) + ((% %lambda args rest body) + (define f (new-ref)) + (define k (new-ref)) + (make-fix + (list + (make-closure f (cons k args) rest + (ir1->ir2 + body + (lambda (ret) + (make-apply k (list ret)))))) + (continuation f))) + ((% %letrec in-order? _ _ _ body) + (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) + (make-fix functions + (ir1->ir2 + ; We re-write a letrec into a corresponding lambda form. + (if in-order? + (loop for name in (reverse variable-names) + for value in (reverse variable-values) + for expr = (make-call + (make-lambda + (list name) + #f + body) + (list value)) + then (make-call + (make-lambda + (list name) + #f + expr) + (list value)) + finally (return expr)) + (make-call + (make-lambda + variable-names + #f + body) + variable-values)) + continuation))) + (_ (error "unexpected type in ir1->ir2" expr)))))) |