diff options
Diffstat (limited to 'csc/cps.csc')
| -rw-r--r-- | csc/cps.csc | 197 |
1 files changed, 165 insertions, 32 deletions
diff --git a/csc/cps.csc b/csc/cps.csc index cf46e05..827f4b7 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -1,5 +1,6 @@ (define-library (csc cps) (export + closure-convert ir1->ir2) (import (scheme base) (only (csc gensym) @@ -10,6 +11,7 @@ key-not-found-error? lookup make-map + map->alist merge) (only (csc ir1) %call @@ -17,6 +19,7 @@ %if %lambda %letrec + %lexical-ref %lexical-set %library-define %sequence @@ -58,7 +61,8 @@ make-kargs make-klabel make-ktail - make-primitive) + make-primitive + make-variable) (only (csc loop) loop return) @@ -189,34 +193,23 @@ (lambda (ret) (make-apply k (list ret)))))) (continuation f))) - ((% %letrec in-order? _ _ _ body) + ((% %letrec _ _ _ _ body) (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) - (make-fix functions - (to-cps - ; 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))) + (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)))) (_ (error "unexpected type in to-cps" expr)))) @@ -224,7 +217,8 @@ (make-map (lambda (ref) (gensym->int (lexical-ref-gensym ref))) - (lambda (x y) (< (gensym->int (lexical-ref-gensym x)) + (lambda (x y) + (< (gensym->int (lexical-ref-gensym x)) (gensym->int (lexical-ref-gensym y)))))) @@ -248,7 +242,7 @@ for fun in funs do (set! m (merge m (get-boxed (closure-body fun)))) finally (return m))) - (_ (error "Unexpected form in get-boxed")))) + (_ (error "Unexpected form in get-boxed" expr)))) (define (all-closure-args fun) @@ -339,8 +333,147 @@ (loop for name in boxed-names do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name) new-expr)) - finally (return expr)))))) + finally (return new-expr))) + (_ (error "Unexpected form in box-conversion" expr))))) (define (ir1->ir2 expr continuation) - (box-conversion (to-cps expr continuation))))) + (box-conversion (to-cps expr continuation))) + + + (define (free-vars-expr expr bound-vars) + (define (free? ref) + (and (lexical-ref? ref) + (not (guard (e ((key-not-found-error? e) #f)) + (lookup bound-vars ref))))) + (match expr + ((% %primitive _ args res continuation) + (loop for r in res + if (lexical-ref? r) + do (set! bound-vars (insert bound-vars r #t))) + (loop with m = (free-vars-expr continuation bound-vars) + for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %branch atom true false) + (define m (merge (free-vars-expr true bound-vars) (free-vars-expr false bound-vars))) + (if (free? atom) + (set! m (insert m atom #t))) + m) + ((% %apply proc args) + (define m (make-ref-map)) + (if (free? proc) + (set! m (insert m proc #t))) + (loop for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %fix funs body) + (loop for fun in funs + for name = (closure-name fun) + if (lexical-ref? name) + do (set! bound-vars (insert bound-vars name #t))) + (define m (free-vars-expr body bound-vars)) + (loop for fun in funs + do (set! m (merge m (free-vars-closure fun bound-vars))) + finally (return m))) + (_ (error "Unexpected form in free-vars-expr" expr)))) + + + (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)) + + + ; Returns a list of the free variables in a closure. + (define (free-vars expr) + (define m (free-vars-closure expr (make-ref-map))) + (map car (map->alist m))) + + + (define (translate-ref ref env) + (if (lexical-ref? ref) + (guard (e ((key-not-found-error? e) (error "Undefined symbol in closure-convert" ref))) + (lookup env ref)) + ref)) + + + ; converts a CPS expression into an equivalent expression with no + ; free variables. + (define (closure-convert expr) + (let convert ((expr expr) + (env (make-ref-map))) + (define (translate ref) + (translate-ref ref env)) + (match expr + ((% %primitive op args res continuation) + (loop for r in res + do (set! env (insert env r (make-variable (gensym))))) + (make-primitive op (map translate args) (map translate res) (convert continuation env))) + ((% %branch atom true false) + (make-branch (translate atom) (convert true env) (convert false env))) + ((% %apply proc args) + (let ((p (translate proc)) + (fn (make-variable (gensym)))) + (make-primitive 'peek (list p (make-constant 0)) (list fn) + (make-apply fn (cons p (map translate args)))))) + ((% %fix functions body) + (define frees (map free-vars functions)) + (define fn-ptrs (loop for fun in functions + collect (make-variable (gensym)))) + (define converted-functions (loop for fun in functions + for fn-ptr in fn-ptrs + for free-list in frees + for env* = env + for name = (closure-name fun) + for closure = (make-variable (gensym)) + if (lexical-ref? name) + do (set! env* (insert env* name closure)) + do (loop for arg in (closure-arguments fun) + do (set! env* (insert env* arg (make-variable (gensym))))) + (loop for var in free-list + do (set! env* (insert env* var (make-variable (gensym))))) + collect (let ((new-body (convert (closure-body fun) env*))) + (loop for var in free-list + for i from 0 + do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) + new-body))) + (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) + if (lexical-ref? name) + do (set! env (insert env name (make-variable (gensym))))) + (let ((new-body (convert body env))) + ; Build the closures. + (loop for fun in functions + for free-list in frees + for ptr in fn-ptrs + for closure = (translate (closure-name fun)) + do (loop for var in free-list + for i from 1 + do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() + new-body))) + (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() + new-body))) + ; Allocate the closures. + (loop for fun in functions + for free-list in frees + for closure = (translate (closure-name fun)) + do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) + new-body))) + (make-fix converted-functions new-body))) + (_ (error "Unexpected form in closure-convert" expr))))))) |