From acc561366f3fe6ec0377103f52ef0f7e923711c9 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 1 Aug 2022 19:35:19 -0700 Subject: Modify the project structure. Now the lib directory contains what will eventually end up on the user's /usr/lib/csc. When I write make install, it will copy all of the .csc files from lib into the destination lib directory. This means I can start working on the standard library in lib/scheme. --- lib/csc/cps.csc | 602 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 602 insertions(+) create mode 100644 lib/csc/cps.csc (limited to 'lib/csc/cps.csc') diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc new file mode 100644 index 0000000..f2a9c90 --- /dev/null +++ b/lib/csc/cps.csc @@ -0,0 +1,602 @@ +(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 + %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-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))) + + + ; 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 + (ref update-ref) + (atom update-atom) + (continuation update-continuation)) + + + (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) + (cons continuation args) + (to-cps + body + (lambda (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 forms. + (define (to-cps expr continuation) + (match expr + (_ when (or (constant? expr) + (lexical-ref? expr)) + (continuation expr)) + ((% %library-ref . _) + (unless (library-ref? expr) + (error "wtf")) + (define temp (new-ref)) + (make-primitive 'peek (list *globals* expr) (list temp) + (continuation temp))) + ((% %lexical-set ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %library-define ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %define-syntax _ _) + ; no-op + (continuation (make-constant #f))) + ((% %if test consequent alternate) + (to-cps + test + (lambda (val) + (define continuation-ref (new-ref)) + (define result-ref (new-ref)) + (make-fix + (list (make-closure continuation-ref (list result-ref) + (continuation result-ref))) + (make-branch val + (to-cps + consequent + (lambda (result) + (make-apply continuation-ref (list result)))) + (to-cps + alternate + (lambda (result) + (make-apply continuation-ref (list result))))))))) + ((% %call proc (arg)) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) (continuation result))) + (to-cps + proc + (lambda (f) + (to-cps + arg + (lambda (v) + (make-apply f (list return-address v)))))))) + ((% %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))) + (make-primitive op (reverse vals) '() + (continuation (make-constant #f))))) + do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. + (arg* arg)) + (lambda (vals) + (to-cps arg* + (lambda (val) + (e* (cons val vals))))))) + finally (return (expr '())))) + ((% %sequence head tail) + (to-cps + head + (lambda (x) + (to-cps + tail + continuation)))) + ((% %lambda (arg) _ body) + (define f (new-ref)) + (define k (new-ref)) + (make-fix + (list + (make-closure f (list k arg) + (to-cps + body + (lambda (ret) + (make-apply k (list ret)))))) + (continuation 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 (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)))) + + + (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 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 + (argument-conversion 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 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) + (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)))))))) -- cgit v1.3.1