diff options
Diffstat (limited to 'csc/cps.csc')
| -rw-r--r-- | csc/cps.csc | 185 |
1 files changed, 124 insertions, 61 deletions
diff --git a/csc/cps.csc b/csc/cps.csc index d8cd8bd..1f58287 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -38,10 +38,15 @@ library-define? library-ref? make-call + make-call-builtin make-constant + make-if make-lambda + make-letrec make-lexical-ref make-lexical-set + make-library-define + make-library-ref make-sequence sequence?) (only (csc ir2) @@ -52,7 +57,6 @@ closure-arguments closure-body closure-name - closure-rest make-apply make-atom make-branch @@ -73,22 +77,103 @@ (begin + (define (new-ref) + (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 'int<? (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 'int=? (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. (define-match-record-type <update> (make-update ref atom continuation) update? - %update + %update (ref update-ref) (atom update-atom) (continuation update-continuation)) - (define (new-ref) - (make-lexical-ref 'generated-symbol (gensym))) - - (define (collect-functions-and-variables expr) (let ((names (letrec-names expr)) (gensyms (letrec-gensyms expr)) @@ -98,12 +183,11 @@ for value in vals if (lambda? value) collect (match value - ((% %lambda args rest body) + ((% %lambda args _ body) (define continuation (new-ref)) (make-closure (make-lexical-ref name gensym) (cons continuation args) - rest (to-cps body (lambda (z) @@ -115,6 +199,9 @@ finally (return (values functions variable-names variable-values))))) + ; Converts the given IR1 expression that has undergone argument conversion + ; into an IR2 expression in continuation passing style. + ; The resulting expression will include <update> forms. (define (to-cps expr continuation) (match expr (_ when (or (constant? expr) @@ -141,7 +228,7 @@ (define continuation-ref (new-ref)) (define result-ref (new-ref)) (make-fix - (list (make-closure continuation-ref (list result-ref) #f + (list (make-closure continuation-ref (list result-ref) (continuation result-ref))) (make-branch val (to-cps @@ -152,26 +239,18 @@ alternate (lambda (result) (make-apply continuation-ref (list result))))))))) - ((% %call proc args) + ((% %call proc (arg)) (define return-address (new-ref)) (define result (new-ref)) (make-fix - (list (make-closure return-address (list result) #f (continuation result))) + (list (make-closure return-address (list result) (continuation result))) (to-cps proc (lambda (f) - ; Technically the order of evaluation is unspecified. - ; We evaluate expressions left to right. - (loop for arg in (reverse args) - with expr = (lambda (vals) - (make-apply f (cons return-address (reverse vals)))) - do (set! expr (let ((e* expr) - (arg* arg)) ; make copies to avoid modifying the expr in the closure. - (lambda (vals) - (to-cps arg* - (lambda (val) - (e* (cons val vals))))))) - finally (return (expr '()))))))) + (to-cps + arg + (lambda (v) + (make-apply f (list return-address v)))))))) ((% %call-builtin op args) (define returns-value? (not (symbol=? op 'poke))) (loop for arg in (reverse args) @@ -182,7 +261,7 @@ (continuation result))) (make-primitive op (reverse vals) '() (continuation (make-constant #f))))) - do (set! expr (let ((e* expr) + do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. (arg* arg)) (lambda (vals) (to-cps arg* @@ -196,12 +275,12 @@ (to-cps tail continuation)))) - ((% %lambda args rest body) + ((% %lambda (arg) _ body) (define f (new-ref)) (define k (new-ref)) (make-fix (list - (make-closure f (cons k args) rest + (make-closure f (list k arg) (to-cps body (lambda (ret) @@ -212,18 +291,19 @@ (if (null? variable-names) (make-fix functions (to-cps body continuation)) - (loop with new-expr = (make-fix functions - (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) - (make-update var x - new-body)))) - finally (return new-body))) - for var in variable-names - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) - new-expr)) - finally (return new-expr)))) + (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) + (make-update var x + new-body)))) + finally (return new-body)))) + (unless (null? functions) + (set! new-expr (make-fix functions new-expr))) + (loop for var in variable-names + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) + new-expr)) + finally (return new-expr))))) (_ (error "unexpected type in to-cps" expr)))) @@ -259,14 +339,6 @@ (_ (error "Unexpected form in get-boxed" expr)))) - (define (all-closure-args fun) - (define args (closure-arguments fun)) - (define rest (closure-rest fun)) - (when rest - (set! args (cons rest args))) - args) - - ; Rewrites the given expression to have no more <update> forms. (define (box-conversion expr) (define boxed-refs (get-boxed expr)) @@ -321,16 +393,10 @@ collect (closure-name fun)))) (define new-funs (loop for fun in funs for new-name in new-names - for rest = (closure-rest fun) - collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (all-closure-args fun)))) + collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun)))) (make-closure new-name - (if rest - (cdr new-args) - new-args) - (if rest - (car new-args) - #f) + new-args (let ((new-expr (convert (closure-body fun)))) (loop for arg in boxed-args for var in temp-args @@ -352,7 +418,10 @@ (define (ir1->ir2 expr continuation) - (box-conversion (to-cps expr continuation))) + (box-conversion + (to-cps + (argument-conversion expr) + continuation))) (define (free-vars-expr expr bound-vars) @@ -397,11 +466,8 @@ (define (free-vars-closure fun bound-vars) (define name (closure-name fun)) - (define rest (closure-rest fun)) (when (lexical-ref? name) (set! bound-vars (insert bound-vars name #t))) - (when rest - (set! bound-vars (insert bound-vars rest #t))) (loop for arg in (closure-arguments fun) do (set! bound-vars (insert bound-vars arg #t))) (free-vars-expr (closure-body fun) bound-vars)) @@ -463,9 +529,6 @@ (make-closure fn-ptr (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) - (if (closure-rest fun) - (translate (closure-rest fun)) - #f) new-body)))) (loop for fun in functions for name = (closure-name fun) |