From e615308b928585013461482f879f536527c5acc2 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Wed, 20 Jul 2022 15:39:23 -0700 Subject: Perform argument conversion. The point of argument conversion is to validate on each function call that the right number of arguments were passed, and to ensure that no function has more than 1 argument. This second condition makes CPS slightly simpler, and ensures that the arguments will all fit in locals. We take the strategy of allocating a vector for each function call. Ideally we would optimize away most of these allocations, but for now I just want it to work. --- csc/cps.csc | 185 ++++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 124 insertions(+), 61 deletions(-) (limited to 'csc/cps.csc') 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 'intlist '(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 (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 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 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) -- cgit v1.3.1