diff options
Diffstat (limited to 'csc/cps.csc')
| -rw-r--r-- | csc/cps.csc | 151 |
1 files changed, 85 insertions, 66 deletions
diff --git a/csc/cps.csc b/csc/cps.csc index cdd6611..0dc8a96 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -447,6 +447,24 @@ continuation))) + (define (hoist expr) + (define functions '()) + (define body + (let hoist ((expr expr)) + (match expr + ((% %primitive op args res cont) + (make-primitive op args res (hoist cont))) + ((% %branch atom true false) + (make-branch atom (hoist true) (hoist false))) + ((% %apply . _) expr) + ((% %tail) expr) + ((% %fix funs body) + (set! functions (append funs functions)) + (hoist body)) + (_ (error "Unexpected form in hoist" expr))))) + (make-fix functions body)) + + (define (free-vars-expr expr bound-vars) (define (free? ref) (and (lexical-ref? ref) @@ -514,70 +532,71 @@ ; 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)))))) - ((% %tail) - *tail*) - ((% %fix functions body) - (define frees (map free-vars functions)) - (define fn-ptrs (loop for fun in functions - collect (make-label (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))) - 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. + (hoist + (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)))))) + ((% %tail) + *tail*) + ((% %fix functions body) + (define frees (map free-vars functions)) + (define fn-ptrs (loop for fun in functions + collect (make-label (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))) + new-body)))) (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))))))) + 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)))))))) |