diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/compare-test.csc | 10 | ||||
| -rw-r--r-- | csc/compare.csc | 16 | ||||
| -rw-r--r-- | csc/cps-test.csc | 234 | ||||
| -rw-r--r-- | csc/cps.csc | 185 | ||||
| -rw-r--r-- | csc/encoding.csc | 8 | ||||
| -rw-r--r-- | csc/ir1.csc | 1 | ||||
| -rw-r--r-- | csc/ir2.csc | 3 | ||||
| -rw-r--r-- | csc/match.csc | 2 | ||||
| -rw-r--r-- | csc/testing.csc | 6 |
9 files changed, 334 insertions, 131 deletions
diff --git a/csc/compare-test.csc b/csc/compare-test.csc index 68ea5e6..8791e1d 100644 --- a/csc/compare-test.csc +++ b/csc/compare-test.csc @@ -31,6 +31,9 @@ (test diff-record (assert-equal " ( + (!type . + <test-type> + ) (a . 5 ) @@ -38,9 +41,6 @@ - 5 + 6 ) - (type . - <test-type> - ) ) " (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type)))) @@ -49,7 +49,7 @@ (test diff-multiline-string (assert-equal " ( - (type . + (!type . string ) (value . @@ -67,7 +67,7 @@ (test diff-vector (assert-equal " ( - (type . + (!type . vector ) (value . diff --git a/csc/compare.csc b/csc/compare.csc index ab7e3c1..dea2366 100644 --- a/csc/compare.csc +++ b/csc/compare.csc @@ -76,17 +76,17 @@ (define (pretty w x indent) (cond + ((and (pair? x) + (symbol? (car x))) + (fprintf w "{} ({} .\n" indent (car x)) + (pretty w (cdr x) (string-append indent " ")) + (fprintf w "{} )\n" indent)) ((list? x) (fprintf w "{} (\n" indent) (loop with new-indent = (string-append indent " ") for v in x do (pretty w v new-indent)) (fprintf w "{} )\n" indent)) - ((and (pair? x) - (symbol? (car x))) - (fprintf w "{} ({} .\n" indent (car x)) - (pretty w (cdr x) (string-append indent " ")) - (fprintf w "{} )\n" indent)) (else (fprintf w "{} {}\n" indent x)))) @@ -191,13 +191,13 @@ (and (string? s) (contains s "\n"))) (lambda (s) - (list (cons 'type 'string) + (list (cons '!type 'string) (cons 'value (split s "\n"))))) (cons vector? (lambda (v) - (list (cons 'type 'vector) + (list (cons '!type 'vector) (cons 'value (vector->list v))))) (cons bytevector? (lambda (b) - (list (cons 'type 'bytevector) + (list (cons '!type 'bytevector) (cons 'value (loop for i below (bytevector-length b) collect (string-append "0x" (number->string (bytevector-u8-ref b i)))))))))) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 4259586..84b8b9a 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -116,7 +116,7 @@ (assert-equal (make-fix (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) (make-branch (make-constant #t) (make-apply (test-ref 'generated-symbol) (list (make-constant 1))) @@ -132,12 +132,21 @@ (assert-equal (make-fix (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (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 (test-ref 'f) (list (make-constant 1) (make-constant 2))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20))) tail) transform-ir2)) @@ -185,19 +194,49 @@ transform-ir2)) -(test closure +; It's pretty bad +(test closure-rest (assert-equal (make-fix - (list - (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))))) + (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int<? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + (make-fix (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c)) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 3)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'vector->list '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))))) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) (ir1->ir2 (make-lambda - (list (test-ref 'a) (test-ref 'b)) + '() (test-ref 'c) (make-constant 5)) tail) @@ -210,13 +249,41 @@ (assert-equal (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f - (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) (make-fix (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant 10))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))) + (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))) (ir1->ir2 (make-letrec #f '(f) (list f) (list (make-lambda (list x) #f x)) @@ -226,23 +293,47 @@ (test letrec-in-order + (define a (gensym)) + (define b (gensym)) (assert-equal (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'b)) (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'a)) - (make-fix - (list - (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-primitive 'poke (list (make-constant 1) (test-ref 'a) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 2) (test-ref 'b) (make-constant 0)) '() - (make-apply (test-ref 'tail) (list (make-constant 10)))))))) + (make-primitive 'poke (list (make-constant 1) (test-ref 'a) (make-constant 0)) '() + (make-primitive 'poke (list (test-ref 'a) (test-ref 'b) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (test-ref 'b))))))) (ir1->ir2 (make-letrec #t - '(a f b) - (list (gensym) (gensym) (gensym)) + '(a b) + (list a (gensym)) (list (make-constant 1) - (make-lambda (list (test-ref 'x)) #f (make-constant 5)) - (make-constant 2)) + (make-lexical-ref 'a a)) + (make-lexical-ref 'b b)) + tail) + transform-ir2)) + + +(test letrec-in-order-function + (assert-equal + (make-fix + (list (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-apply (test-ref 'tail) (list (make-constant 10)))) + (ir1->ir2 + (make-letrec #t + '(f) + (list (gensym)) + (list (make-lambda '() #f (make-constant 5))) (make-constant 10)) tail) transform-ir2)) @@ -259,16 +350,36 @@ (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) (make-fix (list - (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)) #f - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))) + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) (make-fix (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) (ir1->ir2 (make-letrec #t '(f x) @@ -286,16 +397,29 @@ (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)))))))) + (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (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-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) (make-apply (test-ref 'tail) (list (make-constant 5)))) (ir1->ir2 (make-letrec #f @@ -312,9 +436,19 @@ (assert-equal (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))))) + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list (make-library-ref 'wrong-number-of-arguments '(csc based)) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) (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) (list (make-constant #f))))))) @@ -341,7 +475,7 @@ (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) (make-fix (list - (make-closure (test-var) (list (test-var) (test-var) (test-var)) #f + (make-closure (test-var) (list (test-var) (test-var) (test-var)) (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) @@ -354,7 +488,7 @@ (closure-convert (make-primitive 'alloc (list (make-constant 1)) (list (make-lexical-ref 'a a-sym)) (make-fix (list - (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) #f + (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '() (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f)))))) (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10)))))) diff --git a/csc/cps.csc b/csc/cps.csc index d8cd8bd..1f58287 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -38,10 +38,15 @@ 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) @@ -52,7 +57,6 @@ closure-arguments closure-body closure-name - closure-rest make-apply make-atom make-branch @@ -73,22 +77,103 @@ (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 'int<? (list (make-call-builtin 'peek (list argvec (make-constant 1))) + (make-constant nargs))) + (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec)) + (loop for arg in (reverse args) + for i downfrom (+ 1 nargs) + with expr = (make-call (make-lambda (list rest) #f + (argument-conversion body)) + (list + (argument-conversion + (make-call (make-library-ref 'vector->list '(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 <update> (make-update ref atom continuation) update? - %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) (let ((names (letrec-names expr)) (gensyms (letrec-gensyms expr)) @@ -98,12 +183,11 @@ for value in vals if (lambda? value) collect (match value - ((% %lambda args rest body) + ((% %lambda args _ body) (define continuation (new-ref)) (make-closure (make-lexical-ref name gensym) (cons continuation args) - rest (to-cps body (lambda (z) @@ -115,6 +199,9 @@ 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) @@ -141,7 +228,7 @@ (define continuation-ref (new-ref)) (define result-ref (new-ref)) (make-fix - (list (make-closure continuation-ref (list result-ref) #f + (list (make-closure continuation-ref (list result-ref) (continuation result-ref))) (make-branch val (to-cps @@ -152,26 +239,18 @@ alternate (lambda (result) (make-apply continuation-ref (list result))))))))) - ((% %call proc args) + ((% %call proc (arg)) (define return-address (new-ref)) (define result (new-ref)) (make-fix - (list (make-closure return-address (list result) #f (continuation result))) + (list (make-closure return-address (list result) (continuation result))) (to-cps proc (lambda (f) - ; Technically the order of evaluation is unspecified. - ; We evaluate expressions left to right. - (loop for arg in (reverse args) - with expr = (lambda (vals) - (make-apply f (cons return-address (reverse vals)))) - do (set! expr (let ((e* expr) - (arg* arg)) ; make copies to avoid modifying the expr in the closure. - (lambda (vals) - (to-cps arg* - (lambda (val) - (e* (cons val vals))))))) - finally (return (expr '()))))))) + (to-cps + arg + (lambda (v) + (make-apply f (list return-address v)))))))) ((% %call-builtin op args) (define returns-value? (not (symbol=? op 'poke))) (loop for arg in (reverse args) @@ -182,7 +261,7 @@ (continuation result))) (make-primitive op (reverse vals) '() (continuation (make-constant #f))))) - do (set! expr (let ((e* expr) + do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. (arg* arg)) (lambda (vals) (to-cps arg* @@ -196,12 +275,12 @@ (to-cps tail continuation)))) - ((% %lambda args rest body) + ((% %lambda (arg) _ body) (define f (new-ref)) (define k (new-ref)) (make-fix (list - (make-closure f (cons k args) rest + (make-closure f (list k arg) (to-cps body (lambda (ret) @@ -212,18 +291,19 @@ (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)))) + (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)))) @@ -259,14 +339,6 @@ (_ (error "Unexpected form in get-boxed" expr)))) - (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)) @@ -321,16 +393,10 @@ 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)))) + collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun)))) (make-closure new-name - (if rest - (cdr new-args) - new-args) - (if rest - (car new-args) - #f) + new-args (let ((new-expr (convert (closure-body fun)))) (loop for arg in boxed-args for var in temp-args @@ -352,7 +418,10 @@ (define (ir1->ir2 expr continuation) - (box-conversion (to-cps expr continuation))) + (box-conversion + (to-cps + (argument-conversion expr) + continuation))) (define (free-vars-expr expr bound-vars) @@ -397,11 +466,8 @@ (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)) @@ -463,9 +529,6 @@ (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) diff --git a/csc/encoding.csc b/csc/encoding.csc index 21ee88f..5c06bec 100644 --- a/csc/encoding.csc +++ b/csc/encoding.csc @@ -3,6 +3,14 @@ (import (scheme base) (only (csc match) match)) (begin + ; I'm only going to say this once, so pay attention. + ; The format of unboxed constants is described in bytecocde/src/data.rs. + ; Boxed values are represented by a pointer to an array on the heap. The + ; first position in the array is an integer code indicating what type the + ; object is. Vectors have code 0, codes for other types are not stable. + ; Vectors are represented as an array, the first element of which is the + ; integer 0 (the type code), the second element is the vector length, and + ; the remaining slots hold the array values. (define (right-shift n1 n2) diff --git a/csc/ir1.csc b/csc/ir1.csc index 484b38f..b91e8ab 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -168,6 +168,7 @@ ; - alloc: size -> result ; - peek: pointer * offset -> result ; - poke: word * pointer * offset -> () + ; - int<?: int * int -> bool (define-match-record-type <call-builtin> (make-call-builtin operation arguments) call-builtin? diff --git a/csc/ir2.csc b/csc/ir2.csc index 7ab2803..331aa4c 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -165,12 +165,11 @@ ; does not take a continuation. Instead, the procedure will accept the ; continuation as an argument. (define-match-record-type <closure> - (make-closure name arguments rest body) + (make-closure name arguments body) closure? %closure (name closure-name) (arguments closure-arguments) - (rest closure-rest) (body closure-body)) diff --git a/csc/match.csc b/csc/match.csc index c925381..116204f 100644 --- a/csc/match.csc +++ b/csc/match.csc @@ -25,7 +25,7 @@ (define (matcher x) (unless (predicate x) (raise *no-match*)) - (list (cons 'type 'name) (cons 'field-name* (field-getter* x)) ...)))))) + (list (cons '!type 'name) (cons 'field-name* (field-getter* x)) ...)))))) (define-syntax match-pattern diff --git a/csc/testing.csc b/csc/testing.csc index e46d300..3fa8ad5 100644 --- a/csc/testing.csc +++ b/csc/testing.csc @@ -61,11 +61,9 @@ (define-syntax assert-equal (syntax-rules () ((assert-equal left right transformers ...) - (let* ((x left) - (y right) - (d (diff x y transformers ...))) + (let ((d (diff left right transformers ...))) (unless (string=? "" d) - (fatalf "Fatal:\n {}\nis not equal to\n {}.\nleft is\n {}\nright is\n {}\ndiff (-left +right):\n{}" 'left 'right x y d)))) + (fatalf "Fatal:\n {}\nis not equal to\n {}.\ndiff (-left +right):\n{}" 'left 'right d)))) ((assert-equal left right) (assert-equal equal? left right)))) |