aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRose Hogenson <rhogenson@google.com>2022-07-20 15:39:23 -0700
committerRose Hogenson <rhogenson@posteo.net>2022-07-20 20:08:14 -0700
commite615308b928585013461482f879f536527c5acc2 (patch)
treedd00eef6713c103f755b98c5ffde1e2ca2d994f7
parentd18813441649665f42b524443c65d0b6bb4ac59a (diff)
downloadchromatopelma-e615308b928585013461482f879f536527c5acc2.tar.zst
Perform argument conversion.
The point of argument conversion is to validate on each function call that the right number of arguments were passed, and to ensure that no function has more than 1 argument. This second condition makes CPS slightly simpler, and ensures that the arguments will all fit in locals. We take the strategy of allocating a vector for each function call. Ideally we would optimize away most of these allocations, but for now I just want it to work.
-rw-r--r--csc/compare-test.csc10
-rw-r--r--csc/compare.csc16
-rw-r--r--csc/cps-test.csc234
-rw-r--r--csc/cps.csc185
-rw-r--r--csc/encoding.csc8
-rw-r--r--csc/ir1.csc1
-rw-r--r--csc/ir2.csc3
-rw-r--r--csc/match.csc2
-rw-r--r--csc/testing.csc6
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))))