diff options
Diffstat (limited to 'lib/csc/cps.csc')
| -rw-r--r-- | lib/csc/cps.csc | 589 |
1 files changed, 0 insertions, 589 deletions
diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc deleted file mode 100644 index 4242681..0000000 --- a/lib/csc/cps.csc +++ /dev/null @@ -1,589 +0,0 @@ -(define-library (csc cps) - (export - closure-convert - ir1->ir2) - (import (scheme base) - (only (csc gensym) - gensym - gensym->int) - (only (csc hash-map) - insert - key-not-found-error? - lookup - make-comparer - make-map - map->alist - merge) - (only (csc ir1) - %call - %call-builtin - %define-syntax - %if - %lambda - %letrec - %lexical-ref - %lexical-set - %library-define - %library-ref - %sequence - call? - constant? - if? - lambda? - letrec-gensyms - letrec-names - letrec-values - letrec? - lexical-ref-gensym - lexical-ref? - lexical-set? - 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) - %apply - %branch - %closure - %fix - %primitive - %tail - *globals* - *tail* - branch-atom - closure-arguments - closure-body - closure-name - make-apply - make-branch - make-call-closure - make-closure - make-fix - make-label - make-primitive - make-variable - tail?) - (only (csc loop) - loop - return) - (only (csc match) - define-match-record-type - match)) - (begin - - - (define (new-ref) - (make-lexical-ref 'generated-symbol (gensym))) - - - ; 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 - (ref update-ref) - (atom update-atom) - (continuation update-continuation)) - - - (define-syntax singleton-continuation - (syntax-rules () - ((singleton-continuation (val) body ...) - (lambda (x multi) - (define (b val) body ...) - (if multi - (let ((v (new-ref))) - (make-primitive 'assert-singleton (list x) (list v) - (b v))) - (b x)))))) - - - (define-syntax varargs-continuation - (syntax-rules () - ((varargs-continuation (vals) body ...) - (lambda (x multi) - (define (b vals) body ...) - (if multi - (b x) - (let ((l (new-ref))) - (make-primitive 'cons (list x (make-constant '())) (list l) - (b l)))))))) - - - (define (collect-functions-and-variables expr) - (let ((names (letrec-names expr)) - (gensyms (letrec-gensyms expr)) - (vals (letrec-values expr))) - (loop for name in names - for gensym in gensyms - for value in vals - if (lambda? value) - collect (match value - ((% %lambda args body) - (define continuation (new-ref)) - (make-closure - (make-lexical-ref name gensym) - (list continuation args) - (to-cps - body - (varargs-continuation (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))))) - - - ; 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) - (lexical-ref? expr)) - (continuation expr #f)) - ((% %library-ref . _) - (define temp (new-ref)) - (make-primitive 'peek (list *globals* expr) (list temp) - (continuation temp #f))) - ((% %lexical-set ref arg) - (to-cps - arg - (singleton-continuation (val) - (make-update ref val (continuation (make-constant #f) #f))))) - ((% %library-define ref arg) - (to-cps - arg - (singleton-continuation (val) - (make-update ref val (continuation (make-constant #f) #f))))) - ((% %define-syntax _ _) - ; no-op - (continuation (make-constant #f) #f)) - ((% %if test consequent alternate) - (to-cps - test - (singleton-continuation (val) - (define continuation-ref (new-ref)) - (define result-ref (new-ref)) - (make-fix - (list (make-closure continuation-ref (list result-ref) - (continuation result-ref #t))) - (make-branch val - (to-cps - consequent - (varargs-continuation (result) - (make-apply continuation-ref (list result)))) - (to-cps - alternate - (varargs-continuation (result) - (make-apply continuation-ref (list result))))))))) - ((% %call proc args) - (define return-address (new-ref)) - (define result (new-ref)) - (make-fix - (list (make-closure return-address (list result) (continuation result #t))) - (to-cps - proc - (singleton-continuation (f) - (to-cps - (loop for arg in (reverse args) - with arglist = (make-constant '()) - do (set! arglist (make-call-builtin 'cons (list arg arglist))) - finally (return arglist)) - (singleton-continuation (v) - (make-apply f (list return-address v)))))))) - ((% %call-builtin 'call-with-current-continuation (proc)) - (define return-address (new-ref)) - (define current-continuation (new-ref)) - (define result1 (new-ref)) - (define result2 (new-ref)) - (define arglist (new-ref)) - (make-fix - (list (make-closure return-address (list result1) - (continuation result1 #t)) - (make-closure current-continuation (list (new-ref) result2) - (make-apply return-address (list result2)))) - (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist) - (to-cps proc - (singleton-continuation (f) - (make-apply f (list return-address arglist))))))) - ((% %call-builtin 'call-with-values (producer consumer)) - (define return-address (new-ref)) - (define consumer-func (new-ref)) - (define result (new-ref)) - (define results (new-ref)) - (make-fix - (list (make-closure return-address (list result) - (continuation result #t)) - (make-closure consumer-func (list results) - (to-cps consumer - (singleton-continuation (c) - (make-apply c (list return-address results)))))) - (to-cps producer - (singleton-continuation (p) - (make-apply p (list consumer-func (make-constant '()))))))) - ((% %call-builtin 'apply (proc args)) - (define return-address (new-ref)) - (define result (new-ref)) - (make-fix - (list (make-closure return-address (list result) (continuation result #t))) - (to-cps - proc - (singleton-continuation (f) - (to-cps - args - (singleton-continuation (l) - (make-apply f (list return-address l)))))))) - ((% %call-builtin op args) - (define returns-value? (not (memq op '(poke exit)))) - (loop for arg in (reverse args) - with expr = (lambda (vals) - (if returns-value? - (let ((result (new-ref))) - (make-primitive op (reverse vals) (list result) - (continuation result #f))) - (make-primitive op (reverse vals) '() - (continuation (make-constant #f) #f)))) - do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. - (arg* arg)) - (lambda (vals) - (to-cps arg* - (singleton-continuation (val) - (e* (cons val vals))))))) - finally (return (expr '())))) - ((% %sequence head tail) - (to-cps - head - (lambda (x multi) - (to-cps - tail - continuation)))) - ((% %lambda args body) - (define f (new-ref)) - (define k (new-ref)) - (make-fix - (list - (make-closure f (list k args) - (to-cps - body - (varargs-continuation (ret) - (make-apply k (list ret)))))) - (continuation f #f))) - ((% %letrec _ _ _ _ body) - (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) - (if (null? variable-names) - (make-fix functions - (to-cps body continuation)) - (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 (singleton-continuation (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)))) - - - (define compare-refs - (make-comparer - (lambda (ref) - (gensym->int (lexical-ref-gensym ref))) - (lambda (x y) - (- (gensym->int (lexical-ref-gensym y)) (gensym->int (lexical-ref-gensym x)))))) - - - (define (make-ref-map) - (make-map compare-refs)) - - - (define (get-boxed expr) - (match expr - ((% %update ref _ continuation) - (define m (get-boxed continuation)) - (when (lexical-ref? ref) - (set! m (insert m ref #t))) - m) - ((% %primitive _ _ _ continuation) - (get-boxed continuation)) - ((% %branch _ true false) - (merge - (get-boxed true) - (get-boxed false))) - ((% %apply proc args) - (make-ref-map)) - ((% %tail) - (make-ref-map)) - ((% %fix funs body) - (loop with m = (get-boxed body) - for fun in funs - do (set! m (merge m (get-boxed - (closure-body fun)))) - finally (return m))) - (_ (error "Unexpected form in get-boxed" expr)))) - - - ; Rewrites the given expression to have no more <update> forms. - (define (box-conversion expr) - (define boxed-refs (get-boxed expr)) - (define (boxed? ref) - (and (lexical-ref? ref) - (guard (e ((key-not-found-error? e) #f)) - (lookup boxed-refs ref)))) - (define (convert-arg-list args) - (define boxed-args (loop for arg in args - if (boxed? arg) - collect arg)) - (define vars (loop for x in boxed-args - collect (new-ref))) - (define new-args (loop with v* = vars - for arg in args - collect (if (boxed? arg) - (car v*) - arg) - if (boxed? arg) - do (set! v* (cdr v*)))) - (values new-args boxed-args vars)) - (let convert ((expr expr)) - (match expr - ((% %update ref atom continuation) when (library-ref? ref) - (make-primitive 'poke (list atom *globals* ref) '() - (convert continuation))) - ((% %update ref atom continuation) when (lexical-ref? ref) - (make-primitive 'poke (list atom ref (make-constant 0)) '() (convert continuation))) - ((% %primitive op args res continuation) - ; Note that no reference in res can be boxed. - (define-values (new-args boxed-args vars) (convert-arg-list args)) - (define new-expr (make-primitive op new-args res (convert continuation))) - (loop for arg in boxed-args - for var in vars - do (set! new-expr (make-primitive 'peek (list arg (make-constant 0)) (list var) - new-expr)) - finally (return new-expr))) - ((% %branch atom true false) when (boxed? atom) - (define temp (new-ref)) - (make-primitive 'peek (list atom (make-constant 0)) (list temp) - (make-branch temp - (convert true) - (convert false)))) - ((% %branch atom true false) - (make-branch atom - (convert true) - (convert false))) - ((% %apply proc args) - (define-values (new-params boxed-params vars) (convert-arg-list (cons proc args))) - (define new-expr (make-apply (car new-params) (cdr new-params))) - (loop for p in boxed-params - for var in vars - do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var) - new-expr)) - finally (return new-expr))) - ((% %tail) - *tail*) - ((% %fix funs body) - (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs - collect (closure-name fun)))) - (define new-funs (loop for fun in funs - for new-name in new-names - collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun)))) - (make-closure - new-name - new-args - (let ((new-expr (convert (closure-body fun)))) - (loop for arg in boxed-args - for var in temp-args - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list arg) - (make-primitive 'poke (list var arg (make-constant 0)) '() - new-expr))) - finally (return new-expr))))))) - (define new-body (convert body)) - (loop for name in boxed-names - for var in temp-names - do (set! new-body (make-primitive 'poke (list var name (make-constant 0)) '() - new-body))) - (define new-expr (make-fix new-funs new-body)) - (loop for name in boxed-names - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name) - new-expr)) - finally (return new-expr))) - (_ (error "Unexpected form in box-conversion" expr))))) - - - (define (ir1->ir2 expr continuation) - (box-conversion - (to-cps expr 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 (map hoist funs) functions)) - (hoist body)) - ((% %closure name args body) - (make-closure name args (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) - (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))) - ((% %tail) - (make-ref-map)) - ((% %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)) - (when (lexical-ref? name) - (set! bound-vars (insert bound-vars name #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) - (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 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)))))))) |