diff options
| -rw-r--r-- | csc/cps-test.csc | 153 | ||||
| -rw-r--r-- | csc/cps.csc | 233 | ||||
| -rw-r--r-- | csc/ir2.csc | 104 |
3 files changed, 345 insertions, 145 deletions
diff --git a/csc/cps-test.csc b/csc/cps-test.csc index d3cfb6d..3f0d743 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -1,4 +1,5 @@ (import (scheme base) + (only (csc gensym) gensym) (only (csc ir1) make-call make-constant @@ -13,55 +14,60 @@ (only (csc ir2) ir2=? make-apply - make-fix make-atom make-branch make-call-closure make-closure + make-fix make-kargs make-klabel make-ktail - make-update) + make-primitive) (only (csc testing) assert-equal test) (csc cps)) +(define (test-ref name) + (make-lexical-ref name (gensym))) + + (define (tail x) - (make-apply (make-lexical-ref 'tail #f) (list x))) + (make-apply (test-ref 'tail) (list x))) (test atom-const (assert-equal ir2=? - (make-apply (make-lexical-ref 'tail #f) (list (make-constant 5))) + (make-apply (test-ref 'tail) (list (make-constant 5))) (ir1->ir2 (make-constant 5) tail))) (test atom-lexical-ref (assert-equal ir2=? - (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'var #f))) - (ir1->ir2 (make-lexical-ref 'var #f) tail))) + (make-apply (test-ref 'tail) (list (test-ref 'var))) + (ir1->ir2 (test-ref 'var) tail))) (test atom-library-ref (assert-equal ir2=? - (make-apply (make-lexical-ref 'tail #f) - (list (make-library-ref 'var '(csc builtins)))) + (make-primitive 'peek (list (make-library-ref 'var '(csc builtins)) (make-constant 0)) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail))) (test lexical-set (assert-equal ir2=? - (make-update (make-lexical-ref 'var #f) (make-constant 5) - (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))) - (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5)) + (make-primitive 'poke (list (make-constant 5) (test-ref 'var) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant #f)))) + (ir1->ir2 (make-lexical-set (test-ref 'var) (make-constant 5)) tail))) (test no-op-define-syntax (assert-equal ir2=? - (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))) + (make-apply (test-ref 'tail) (list (make-constant #f))) (ir1->ir2 (make-define-syntax 'name '(transformer)) tail))) @@ -70,11 +76,11 @@ (assert-equal ir2=? (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f - (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) (make-branch (make-constant #t) - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 1))) - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 2))))) + (make-apply (test-ref 'generated-symbol) (list (make-constant 1))) + (make-apply (test-ref 'generated-symbol) (list (make-constant 2))))) (ir1->ir2 (make-if (make-constant #t) (make-constant 1) (make-constant 2)) @@ -85,22 +91,22 @@ (assert-equal ir2=? (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f - (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) - (make-apply (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f) + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant 1) (make-constant 2)))) - (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2))) + (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 1) (make-constant 2))) tail))) (test sequence (assert-equal ir2=? - (make-update (make-lexical-ref 'a #f) (make-constant 5) - (make-update (make-lexical-ref 'b #f) (make-constant 6) - (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))))) - (ir1->ir2 (make-sequence (make-lexical-set (make-lexical-ref 'a #f) (make-constant 5)) - (make-lexical-set (make-lexical-ref 'b #f) (make-constant 6))) + (make-primitive 'poke (list (make-constant 5) (test-ref 'a) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 6) (test-ref 'b) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant #f))))) + (ir1->ir2 (make-sequence (make-lexical-set (test-ref 'a) (make-constant 5)) + (make-lexical-set (test-ref 'b) (make-constant 6))) tail))) @@ -108,16 +114,16 @@ (assert-equal ir2=? (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) - (list (make-lexical-ref 'generated-symbol #f) - (make-lexical-ref 'a #f) - (make-lexical-ref 'b #f)) - (make-lexical-ref 'c #f) - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5))))) - (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))) + (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) + (test-ref 'a) + (test-ref 'b)) + (test-ref 'c) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) (ir1->ir2 (make-lambda - (list (make-lexical-ref 'a #f) (make-lexical-ref 'b #f)) - (make-lexical-ref 'c #f) + (list (test-ref 'a) (test-ref 'b)) + (test-ref 'c) (make-constant 5)) tail))) @@ -126,38 +132,81 @@ (assert-equal ir2=? (make-fix (list - (make-closure (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f) - (make-lexical-ref 'x #f)) #f - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) + (test-ref 'x)) #f + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f - (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f) - (make-lexical-ref 'a #f)) #f + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) + (test-ref 'a)) #f (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) (make-fix (list - (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f) - (make-lexical-ref 'b #f)) #f - (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 10))))) - (make-apply (make-lexical-ref 'generated-symbol #f) - (list (make-lexical-ref 'generated-symbol #f) + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) + (test-ref 'b)) #f + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) + (make-apply (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (make-constant 2))))))) - (make-apply (make-lexical-ref 'generated-symbol #f) - (list (make-lexical-ref 'generated-symbol #f) + (make-apply (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (make-constant 1)))))) (ir1->ir2 (make-letrec #t '(a f b) - '(#f #f #f) + (list (gensym) (gensym) (gensym)) (list (make-constant 1) - (make-lambda (list (make-lexical-ref 'x #f)) #f (make-constant 5)) + (make-lambda (list (test-ref 'x)) #f (make-constant 5)) (make-constant 2)) (make-constant 10)) tail))) + + +(test set-argument + (make-fix + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) + (test-ref 'generated-symbol)) #f + (make-primitive 'alloc (list (make-constant 1)) + (list (test-ref 'x)) + (make-primitive 'poke (list (test-ref 'generated-symbol) + (test-ref 'x) + (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 10) + (test-ref 'x) + (make-constant 0)) '() + (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) + (make-apply (test-ref 'tail) (make-constant 5))) + (ir1->ir2 (make-letrec + #f + '(f) + (list (gensym)) + (list (make-lambda (list (test-ref 'x)) #f + (make-lexical-set (test-ref 'x) (make-constant 10)))) + (make-constant 5)) + tail)) + + +(test set-function + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f)) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))))) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '() + (make-apply (test-ref 'tail) (make-constant #f)))))) + (ir1->ir2 (make-letrec + #f + '(f) + (list (gensym)) + (list (make-lambda '() #f (make-constant 10))) + (make-lexical-set (test-ref 'f) (make-constant 5))) + tail)) diff --git a/csc/cps.csc b/csc/cps.csc index b6decbb..cf46e05 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -2,9 +2,13 @@ (export ir1->ir2) (import (scheme base) - (only (csc gensym) gensym) + (only (csc gensym) + gensym + gensym->int) (only (csc hash-map) insert + key-not-found-error? + lookup make-map merge) (only (csc ir1) @@ -20,7 +24,11 @@ constant? if? lambda? + letrec-gensyms + letrec-names + letrec-values letrec? + lexical-ref-gensym lexical-ref? lexical-set? library-define? @@ -33,6 +41,14 @@ make-sequence sequence?) (only (csc ir2) + %apply + %branch + %fix + %primitive + closure-arguments + closure-body + closure-name + closure-rest make-apply make-atom make-branch @@ -42,56 +58,71 @@ make-kargs make-klabel make-ktail - make-update) + make-primitive) (only (csc loop) loop return) - (only (csc match) match)) + (only (csc match) + define-match-record-type + match)) (begin + ; 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 (new-ref) (make-lexical-ref 'generated-symbol (gensym))) (define (collect-functions-and-variables expr) - (match expr - ((% %letrec _ names gensyms vals _) - (loop for name in names - for gensym in gensyms - for value in vals - if (lambda? value) - collect (match value - ((% %lambda args rest body) - (define continuation (new-ref)) - (make-closure - (make-lexical-ref name gensym) - (cons continuation args) - rest - (ir1->ir2 - 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)))))) + (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 rest body) + (define continuation (new-ref)) + (make-closure + (make-lexical-ref name gensym) + (cons continuation args) + rest + (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))))) - (define (ir1->ir2 expr continuation) + (define (to-cps expr continuation) (match expr (_ (when (or (constant? expr) (lexical-ref? expr) (library-ref? expr))) (continuation expr)) ((% %lexical-set ref arg) - (ir1->ir2 + (to-cps arg (lambda (val) (make-update ref val (continuation (make-constant #f)))))) ((% %library-define ref arg) - (ir1->ir2 + (to-cps arg (lambda (val) (make-update ref val (continuation (make-constant #f)))))) @@ -99,7 +130,7 @@ ; no-op (continuation (make-constant #f))) ((% %if test consequent alternate) - (ir1->ir2 + (to-cps test (lambda (val) (define continuation-ref (new-ref)) @@ -108,11 +139,11 @@ (list (make-closure continuation-ref (list result-ref) #f (continuation result-ref))) (make-branch val - (ir1->ir2 + (to-cps consequent (lambda (result) (make-apply continuation-ref (list result)))) - (ir1->ir2 + (to-cps alternate (lambda (result) (make-apply continuation-ref (list result))))))))) @@ -121,7 +152,7 @@ (define result (new-ref)) (make-fix (list (make-closure return-address (list result) #f (continuation result))) - (ir1->ir2 + (to-cps proc (lambda (f) ; Technically the order of evaluation is unspecified. @@ -136,15 +167,15 @@ (exprs '()) (loop (cdr args*) (lambda (vals) - (ir1->ir2 + (to-cps (car args*) (lambda (val) (exprs (cons val vals)))))))))))) ((% %sequence head tail) - (ir1->ir2 + (to-cps head (lambda (x) - (ir1->ir2 + (to-cps tail continuation)))) ((% %lambda args rest body) @@ -153,7 +184,7 @@ (make-fix (list (make-closure f (cons k args) rest - (ir1->ir2 + (to-cps body (lambda (ret) (make-apply k (list ret)))))) @@ -161,7 +192,7 @@ ((% %letrec in-order? _ _ _ body) (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) (make-fix functions - (ir1->ir2 + (to-cps ; We re-write a letrec into a corresponding lambda form. (if in-order? (loop for name in (reverse variable-names) @@ -186,4 +217,130 @@ body) variable-values)) continuation))) - (_ (error "unexpected type in ir1->ir2" expr)))))) + (_ (error "unexpected type in to-cps" expr)))) + + + (define (make-ref-map) + (make-map + (lambda (ref) + (gensym->int (lexical-ref-gensym ref))) + (lambda (x y) (< (gensym->int (lexical-ref-gensym x)) + (gensym->int (lexical-ref-gensym y)))))) + + + (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)) + ((% %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")))) + + + (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 <update> forms. + (define (box-conversion expr) + (define boxed-refs (get-boxed expr)) + (define (boxed? ref) + (or (library-ref? ref) ; globals are always boxed + (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) + (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) + (if (boxed? atom) + (let ((var (new-ref))) + (make-primitive 'peek (list atom (make-constant 0)) (list var) + (make-branch var (convert true) (convert 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))) + ((% %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 + for rest = (closure-rest fun) + collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (all-closure-args fun)))) + (make-closure + new-name + (if rest + (cdr new-args) + new-args) + (if rest + (car new-args) + #f) + (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 expr)))))) + + + (define (ir1->ir2 expr continuation) + (box-conversion (to-cps expr continuation))))) diff --git a/csc/ir2.csc b/csc/ir2.csc index 40109fe..7aea0a3 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -1,5 +1,10 @@ (define-library (csc ir2) (export + %apply + %branch + %closure + %fix + %primitive apply-arguments apply-procedure apply? @@ -37,10 +42,12 @@ make-kargs make-klabel make-ktail - make-update - update-atom - update-continuation - update-ref + make-primitive + primitive-arguments + primitive-continuation + primitive-operation + primitive-results + primitive? ; Re-exports from IR1. constant-expression @@ -80,7 +87,8 @@ loop return) (only (csc match) - define-match-record-type)) + define-match-record-type + match)) (begin ; This library defines the intermediate representation IR2. ; It's CPS time bitch. @@ -92,26 +100,6 @@ ; - constant, ; - lexical-ref, ; - or library-ref - ; After closure conversion, lexical refs are no longer allowed. - ; Lexical refs are converted to one of the below data types. - - - ; A variable representing the address of a function in the same compilation - ; unit. This will be a constant after linking. - (define-match-record-type <label> - (make-label gensym) - label? - %label - (gensym label-gensym)) - - - ; A local variable. This can be an argument to a function or the result of - ; a primitive. - (define-match-record-type <var> - (make-var gensym) - var? - %var - (gensym var-gensym)) ; CPS expressions: @@ -120,14 +108,21 @@ ; And they take a continuation. - ; Modifies a library or lexically bound variable to the given atom. - (define-match-record-type <update> - (make-update ref atom continuation) - update? - %update - (ref update-ref) - (atom update-atom) - (continuation update-continuation)) + ; A primitive encodes one of a number of primitive operations. + ; Each operation takes a number of arguments, + ; and binds some number of result variables. + ; The known primitives are listed below, along with their arity. + ; - alloc: size -> result + ; - peek: pointer * offset -> result + ; - poke: word * pointer * offset -> () + (define-match-record-type <primitive> + (make-primitive operation arguments results continuation) + primitive? + %primitive + (operation primitive-operation) + (arguments primitive-arguments) + (results primitive-results) + (continuation primitive-continuation)) ; Branches depending on the given atom. @@ -190,28 +185,27 @@ (define (ir2=?-sametype x y) - (cond - ((and (update? x) (update? y)) - (and (ir1=? (update-ref x) (update-ref y)) - (ir1=? (update-atom x) (update-atom y)) - (ir2=? (update-continuation x) (update-continuation y)))) - ((and (branch? x) (branch? y)) - (and (ir1=? (branch-atom x) (branch-atom y)) - (ir2=? (branch-true x) (branch-true y)) - (ir2=? (branch-false x) (branch-false y)))) - ((and (apply? x) (apply? y)) - (let ((x-args (apply-arguments x)) - (y-args (apply-arguments y))) - (and (ir1=? (apply-procedure x) (apply-procedure y)) - (= (length x-args) (length y-args)) - (all ir1=? x-args y-args)))) - ((and (fix? x) (fix? y)) - (let ((x-funs (fix-functions x)) - (y-funs (fix-functions y))) - (and (= (length x-funs) (length y-funs)) - (all closure=? x-funs y-funs) - (ir2=? (fix-body x) (fix-body y))))) - (else #f))) + (match (cons x y) + (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont)) + (and (symbol=? x-oper y-oper) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args) + (= (length x-res) (length y-res)) + (all ir1=? x-res y-res) + (ir2=? x-cont y-cont))) + (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false)) + (and (ir1=? x-atom y-atom) + (ir2=? x-true y-true) + (ir2=? x-false y-false))) + (((% %apply x-proc x-args) . (% %apply y-proc y-args)) + (and (ir1=? x-proc y-proc) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args))) + (((% %fix x-funs x-body) . (% %fix y-funs y-body)) + (and (= (length x-funs) (length y-funs)) + (all closure=? x-funs y-funs) + (ir2=? x-body y-body))) + (_ #f))) (define (ir2=? x y) |