From 52da9c556a170ed8e5f811c3acd56088baf94c80 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Sun, 26 Jun 2022 20:14:19 -0700 Subject: Finish CPS. Wow we actually finished CPS. Next is closure conversion, then codegen, and then we should be able to run some end to end tests. Then we can look at garbage collection, and from there continue building features down the long road to self hosting. --- csc/cps-test.csc | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ csc/cps.csc | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ csc/ir1.csc | 2 +- csc/ir2.csc | 52 ++++++++++++++++++++++++++++++++++++++---------- csc/list-test.csc | 13 ++++++++++++ csc/list.csc | 10 +++++++++- 6 files changed, 182 insertions(+), 12 deletions(-) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index ea1d177..d51d10c 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -6,6 +6,9 @@ make-constant make-define-syntax make-if + make-lambda + make-lambda-case + make-letrec make-lexical-ref make-lexical-set make-library-ref @@ -15,9 +18,11 @@ make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update) (only (csc loop) loop @@ -130,3 +135,57 @@ (cons 2 (make-klabel (make-atom (make-constant 2) 1)))) (soup->alist (ir1->ir2 (make-sequence (make-constant 1) (make-constant 2)))))) + + +(test closure + (assert-equal soup=? + (list + (cons 0 (make-klabel + (make-closure + (list (make-lambda-args 2 #t 3)) + 1))) + (cons 1 (make-ktail)) + (cons 2 (make-ktail)) + (cons 3 (make-kargs (list (make-lexical-ref 'a #f) + (make-lexical-ref 'b #f) + (make-lexical-ref 'c #f)) + (make-atom (make-constant 5) 2)))) + (soup->alist (ir1->ir2 (make-lambda + (make-lambda-case + '(a b) + 'c + '(#f #f #f) + (make-constant 5) + #f)))))) + + +(test letrec-to-lambda + (assert-equal soup=? + (list + ; God help you when it's time to debug this test. + (cons 0 (make-klabel + (make-closure + (list + (make-lambda-args 1 #f 7)) + 3))) + (cons 1 (make-ktail)) + (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-call-closure + (make-lexical-ref 'generated-symbol #f) + (list (make-lexical-ref 'generated-symbol #f)) + 1))) + (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-atom (make-constant #f) 2))) + (cons 4 (make-ktail)) + (cons 5 (make-klabel + (make-atom (make-constant 2) 4))) + (cons 6 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) + (make-update (make-lexical-ref 'a #f) (make-lexical-ref 'generated-symbol #f) 5))) + (cons 7 (make-kargs (list (make-lexical-ref 'a #f)) + (make-atom (make-constant 1) 6)))) + (soup->alist (ir1->ir2 (make-letrec + #t + '(a) + '(#f) + (list (make-constant 1)) + (make-constant 2)))))) diff --git a/csc/cps.csc b/csc/cps.csc index 55e7e81..0c85707 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -16,6 +16,18 @@ if-consequent if-test if? + lambda-body + lambda-case-alternate + lambda-case-arguments + lambda-case-body + lambda-case-gensyms + lambda-case-rest + lambda? + letrec-expression + letrec-gensyms + letrec-names + letrec-values + letrec? lexical-ref? lexical-set-expression lexical-set-ref @@ -24,8 +36,13 @@ library-define-ref library-define? library-ref? + make-call make-constant + make-lambda + make-lambda-case make-lexical-ref + make-lexical-set + make-sequence sequence-head sequence-tail sequence?) @@ -33,9 +50,11 @@ make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update) (only (csc loop) loop @@ -105,6 +124,45 @@ (make-klabel (to-cps (sequence-tail expr) continuation add-continuation))) add-continuation)) + ((lambda? expr) + (make-closure + (loop with tail = (add-continuation (make-ktail)) + for lambda-case = (lambda-body expr) then (lambda-case-alternate lambda-case) + while lambda-case + collect (let ((args (lambda-case-arguments lambda-case)) + (rest (lambda-case-rest lambda-case))) + (make-lambda-args + (length args) + (not (not rest)) + (add-continuation + (make-kargs (map make-lexical-ref + (append args (list rest)) + (lambda-case-gensyms lambda-case)) + (to-cps (lambda-case-body lambda-case) tail add-continuation)))))) + continuation)) + ((letrec? expr) + ; We re-write a letrec into a corresponding lambda form. + (let ((names (letrec-names expr)) + (gensyms (letrec-gensyms expr))) + (to-cps + (make-call + (make-lambda + (make-lambda-case + names + #f + gensyms + (make-sequence + (loop for name in names + for gensym in gensyms + for value in (letrec-values expr) + for set = (make-lexical-set (make-lexical-ref name gensym) value) + for body = set then (make-sequence body set) + finally (return body)) + (letrec-expression expr)) + #f)) + (map (lambda (x) (make-constant #f)) names)) + continuation + add-continuation))) (else (error "unexpected type in to-cps" expr)))) diff --git a/csc/ir1.csc b/csc/ir1.csc index cf745c6..26b885b 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -170,7 +170,7 @@ ; body is the name of the clause (??). If the procedure is called with an ; appropriate number of arguments, body is evaluated in tail position. ; Otherwise if there is an alternate, it should be a - ; expression, representing the next clause to try. If alternate is nil, an + ; expression, representing the next clause to try. If alternate is #f, an ; error is signaled. (define-record-type (make-lambda-case arguments rest gensyms body alternate) diff --git a/csc/ir2.csc b/csc/ir2.csc index fc31ce3..1872b65 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -10,6 +10,9 @@ call-closure-args call-closure-closure call-closure? + closure-cases + closure-continuation + closure? ir2=? kargs-expression kargs-refs @@ -17,12 +20,18 @@ klabel-expression klabel? ktail? + lambda-args-kargs + lambda-args-nargs + lambda-args-rest + lambda-args? make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update update-atom update-continuation @@ -61,6 +70,7 @@ make-lexical-ref make-lexical-set make-library-ref) + (only (csc list) all) (only (csc loop) loop return)) @@ -128,6 +138,26 @@ (continuation call-closure-continuation)) + ; One branch of a case-lambda. nargs encodes the number of required + ; arguments, and rest is a boolean indicating whether the function takes a + ; rest parameter. kargs is a continuation ID pointing to a + ; kargs continuation. + (define-record-type + (make-lambda-args nargs rest kargs) + lambda-args? + (nargs lambda-args-nargs) + (rest lambda-args-rest) + (kargs lambda-args-kargs)) + + + ; A lambda expression. + (define-record-type + (make-closure cases continuation) + closure? + (cases closure-cases) + (continuation closure-continuation)) + + ; CPS continuations. @@ -171,22 +201,24 @@ (y-args (call-closure-args y))) (and (ir1=? (call-closure-closure x) (call-closure-closure y)) (= (length x-args) (length y-args)) - (loop for x-arg in (call-closure-args x) - for y-arg in (call-closure-args y) - unless (ir1=? x-arg y-arg) - return #f - finally (return #t)) + (all (lambda (x) x) (map ir1=? x-args y-args)) (= (call-closure-continuation x) (call-closure-continuation y))))) + ((and (lambda-args? x) (lambda-args? y)) + (and (= (lambda-args-nargs x) (lambda-args-nargs y)) + (boolean=? (lambda-args-rest x) (lambda-args-rest y)) + (= (lambda-args-kargs x) (lambda-args-kargs y)))) + ((and (closure? x) (closure? y)) + (let ((x-cases (closure-cases x)) + (y-cases (closure-cases y))) + (and (= (length x-cases) (length y-cases)) + (all (lambda (x) x) (map ir2=? x-cases y-cases)) + (= (closure-continuation x) (closure-continuation y))))) ((and (ktail? x) (ktail? y)) #t) ((and (kargs? x) (kargs? y)) (let ((x-refs (kargs-refs x)) (y-refs (kargs-refs y))) (and (= (length x-refs) (length y-refs)) - (loop for x-ref in x-refs - for y-ref in y-refs - unless (ir1=? x-ref y-ref) - return #f - finally (return #t)) + (all (lambda (x) x) (map ir1=? x-refs y-refs)) (ir2=? (kargs-expression x) (kargs-expression y))))) ((and (klabel? x) (klabel? y)) (ir2=? (klabel-expression x) (klabel-expression y))) diff --git a/csc/list-test.csc b/csc/list-test.csc index d4c145a..faa90b6 100644 --- a/csc/list-test.csc +++ b/csc/list-test.csc @@ -98,5 +98,18 @@ (test unzip-empty (assert (values= (values '() '()) (unzip '())))) + (test unzip-simple (assert (values= (values '(1 2 3) '(4 5 6)) (unzip '((1 . 4) (2 . 5) (3 . 6)))))) + + +(test all-even + (assert-equal + #t + (all (lambda (x) (= 0 (remainder x 2))) '(2 12 8)))) + + +(test some-odd + (assert-equal + #f + (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8)))) diff --git a/csc/list.csc b/csc/list.csc index 95fff04..cc64168 100644 --- a/csc/list.csc +++ b/csc/list.csc @@ -1,5 +1,6 @@ (define-library (csc list) (export + all enumerate filter intercalate @@ -70,4 +71,11 @@ (loop for x in l collect (car x) into xs collect (cdr x) into ys - finally (return (values xs ys)))))) + finally (return (values xs ys)))) + + + (define (all pred l) + (loop for x in l + unless (pred x) + return #f + finally (return #t))))) -- cgit v1.3.1