From a89d6c82e981fec7d6e4c975e083d2b9e04467ad Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 1 May 2023 07:56:42 -0700 Subject: Rewrite most of the compiler. This represents a major step back in terms of functionality, and amount of code. The latter I think constitutes a major win. Next steps are to reimplement syntax-rules, call/cc, and call-with-values. --- lib/csc/assert-test.csc | 14 - lib/csc/assert.csc | 11 - lib/csc/codegen-test.csc | 132 ------- lib/csc/codegen.csc | 259 ------------ lib/csc/codegen.scheme | 161 ++++++++ lib/csc/compare-test.csc | 98 ----- lib/csc/compare.csc | 248 ------------ lib/csc/compiler.csc | 202 ---------- lib/csc/compiler.scheme | 263 +++++++++++++ lib/csc/config.csc | 7 - lib/csc/config.scheme | 7 + lib/csc/cps-test.csc | 379 ------------------ lib/csc/cps.csc | 589 ---------------------------- lib/csc/cps.scheme | 355 +++++++++++++++++ lib/csc/encoding-test.csc | 121 ------ lib/csc/encoding.csc | 208 ---------- lib/csc/encoding.scheme | 246 ++++++++++++ lib/csc/flag.csc | 120 ------ lib/csc/format-test.csc | 26 -- lib/csc/format.csc | 50 --- lib/csc/gensym.csc | 27 -- lib/csc/gensym.scheme | 21 + lib/csc/hash-map-test.csc | 155 -------- lib/csc/hash-map.csc | 492 ----------------------- lib/csc/ir.scheme | 131 +++++++ lib/csc/ir1.csc | 216 ---------- lib/csc/ir2.csc | 217 ----------- lib/csc/linker-test.csc | 49 --- lib/csc/linker.csc | 119 ------ lib/csc/list-test.csc | 123 ------ lib/csc/list.csc | 85 ---- lib/csc/list.scheme | 73 ++++ lib/csc/loop-test.csc | 294 -------------- lib/csc/loop.csc | 419 -------------------- lib/csc/macros-test.csc | 357 ----------------- lib/csc/macros.csc | 976 ---------------------------------------------- lib/csc/macros.scheme | 346 ++++++++++++++++ lib/csc/map.scheme | 316 +++++++++++++++ lib/csc/match-test.csc | 113 ------ lib/csc/match.csc | 80 ---- lib/csc/sort-test.csc | 37 -- lib/csc/sort.csc | 28 -- lib/csc/strings-test.csc | 121 ------ lib/csc/strings.csc | 72 ---- lib/csc/testing.csc | 91 ----- lib/csc/vec-test.csc | 35 -- lib/csc/vec.csc | 65 --- 47 files changed, 1919 insertions(+), 6635 deletions(-) delete mode 100644 lib/csc/assert-test.csc delete mode 100644 lib/csc/assert.csc delete mode 100644 lib/csc/codegen-test.csc delete mode 100644 lib/csc/codegen.csc create mode 100644 lib/csc/codegen.scheme delete mode 100644 lib/csc/compare-test.csc delete mode 100644 lib/csc/compare.csc delete mode 100644 lib/csc/compiler.csc create mode 100644 lib/csc/compiler.scheme delete mode 100644 lib/csc/config.csc create mode 100644 lib/csc/config.scheme delete mode 100644 lib/csc/cps-test.csc delete mode 100644 lib/csc/cps.csc create mode 100644 lib/csc/cps.scheme delete mode 100644 lib/csc/encoding-test.csc delete mode 100644 lib/csc/encoding.csc create mode 100644 lib/csc/encoding.scheme delete mode 100644 lib/csc/flag.csc delete mode 100644 lib/csc/format-test.csc delete mode 100644 lib/csc/format.csc delete mode 100644 lib/csc/gensym.csc create mode 100644 lib/csc/gensym.scheme delete mode 100644 lib/csc/hash-map-test.csc delete mode 100644 lib/csc/hash-map.csc create mode 100644 lib/csc/ir.scheme delete mode 100644 lib/csc/ir1.csc delete mode 100644 lib/csc/ir2.csc delete mode 100644 lib/csc/linker-test.csc delete mode 100644 lib/csc/linker.csc delete mode 100644 lib/csc/list-test.csc delete mode 100644 lib/csc/list.csc create mode 100644 lib/csc/list.scheme delete mode 100644 lib/csc/loop-test.csc delete mode 100644 lib/csc/loop.csc delete mode 100644 lib/csc/macros-test.csc delete mode 100644 lib/csc/macros.csc create mode 100644 lib/csc/macros.scheme create mode 100644 lib/csc/map.scheme delete mode 100644 lib/csc/match-test.csc delete mode 100644 lib/csc/match.csc delete mode 100644 lib/csc/sort-test.csc delete mode 100644 lib/csc/sort.csc delete mode 100644 lib/csc/strings-test.csc delete mode 100644 lib/csc/strings.csc delete mode 100644 lib/csc/testing.csc delete mode 100644 lib/csc/vec-test.csc delete mode 100644 lib/csc/vec.csc (limited to 'lib/csc') diff --git a/lib/csc/assert-test.csc b/lib/csc/assert-test.csc deleted file mode 100644 index 4e8d2d3..0000000 --- a/lib/csc/assert-test.csc +++ /dev/null @@ -1,14 +0,0 @@ -(define-library (csc assert-test) - (import (scheme base) - (only (csc testing) - assert-raises - test) - (csc assert)) - (begin - (test assert-raises - (assert-raises error-object? - (assert #f))) - - - (test assert-ok - (assert #t)))) diff --git a/lib/csc/assert.csc b/lib/csc/assert.csc deleted file mode 100644 index 84d2096..0000000 --- a/lib/csc/assert.csc +++ /dev/null @@ -1,11 +0,0 @@ -(define-library (csc assert) - (export assert) - (import (scheme base)) - (begin - - - (define-syntax assert - (syntax-rules () - ((assert condition) - (unless condition - (error "assertion failed" 'condition))))))) diff --git a/lib/csc/codegen-test.csc b/lib/csc/codegen-test.csc deleted file mode 100644 index 752f250..0000000 --- a/lib/csc/codegen-test.csc +++ /dev/null @@ -1,132 +0,0 @@ -(define-library (csc codegen-test) - (import (scheme base) - (only (csc gensym) - gensym) - (only (csc ir2) - *globals* - make-apply - make-branch - make-closure - make-constant - make-fix - make-label - make-library-ref - make-primitive - make-variable) - (only (csc loop) - loop - return) - (only (csc match) - match) - (only (csc testing) - assert-equal - test) - (csc codegen)) - (begin - - - (define (test-var) - (make-variable (gensym))) - - - (define (test-label) - (make-label (gensym))) - - - (test codegen-apply - (define p (test-var)) - (assert-equal - '((peek (local 1) (local 0) (const 5)) - (mov (local 2) (local 1)) - (mov (local 1) (const 10)) - (jmp (local 2)) - (label 0)) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-constant 5)) (list p) - (make-apply p (list (make-constant 10)))))))) - - - (test codegen-call-global - (define p (test-var)) - (assert-equal - '((peek (local 1) (local 0) (global cons (csc based))) - (mov (local 3) (local 1)) - (mov (local 1) (const 5)) - (mov (local 2) (const ())) - (jmp (local 3)) - (label 0)) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p) - (make-apply p (list (make-constant 5) (make-constant '())))))))) - - - (test codegen-call-known - (define f (test-label)) - (define ret (test-var)) - (assert-equal - '((mov (local 1) (label 1)) - (jmp (label 1)) - (label 1) - (mov (local 2) (local 1)) - (jmp (local 2)) - (label 0)) - (ir2->ir3 - (make-fix - (list (make-closure f (list ret) - (make-apply ret (list ret)))) - (make-apply f (list f)))))) - - - (test codegen-permute - (define f (test-label)) - (define g (test-label)) - (define f1 (test-var)) - (define f2 (test-var)) - (define g1 (test-var)) - (define g2 (test-var)) - (define g3 (test-var)) - (assert-equal - '((mov (local 1) (const 0)) - (mov (local 2) (const 1)) - (jmp (label 1)) - (label 1) - (mov (local 255) (local 1)) - (mov (local 1) (local 2)) - (mov (local 2) (local 255)) - (mov (local 3) (const 0)) - (jmp (label 2)) - (label 2) - (mov (local 2) (local 1)) - (mov (local 1) (local 3)) - (jmp (label 1)) - (label 0)) - (ir2->ir3 - (make-fix - (list (make-closure f (list f1 f2) - (make-apply g (list f2 f1 (make-constant 0)))) - (make-closure g (list g1 g2 g3) - (make-apply f (list g3 g1)))) - (make-apply f (list (make-constant 0) (make-constant 1))))))) - - - (test codegen-branch - (define p (test-var)) - (assert-equal - '((peek (local 1) (local 0) (const 1)) - (jmpif (const #t) (label 1)) - (mov (local 2) (local 1)) - (mov (local 1) (const 10)) - (jmp (local 2)) - (label 1) - (mov (local 2) (local 1)) - (mov (local 1) (const 5)) - (jmp (local 2)) - (label 0)) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-constant 1)) (list p) - (make-branch (make-constant #t) - (make-apply p (list (make-constant 5))) - (make-apply p (list (make-constant 10))))))))))) diff --git a/lib/csc/codegen.csc b/lib/csc/codegen.csc deleted file mode 100644 index 1198bce..0000000 --- a/lib/csc/codegen.csc +++ /dev/null @@ -1,259 +0,0 @@ -(define-library (csc codegen) - (export - ir2->ir3) - (import (scheme base) - (only (csc gensym) - gensym - gensym->int) - (only (csc hash-map) - compare-numbers - delete - hash-bytevector - insert - lookup - make-comparer - make-map - map-for-each) - (only (csc ir2) - %apply - %branch - %constant - %globals - %label - %library-ref - %primitive - %tail - %variable - closure-arguments - closure-body - closure-name - constant-expression - constant? - fix-body - fix-functions - globals? - label-gensym - label? - library-ref-library - library-ref-name - library-ref? - make-apply - make-constant - make-label - make-primitive - variable-gensym - variable?) - (only (csc loop) - loop) - (only (csc match) - match)) - (begin - - - (define (atom->bytecode atom translate-local) - (match atom - ((% %constant x) - (cond - ((and (integer? x) - (> x (- (expt 2 30) 1))) ; out of range for a small int - (error "I don't support big ints yet")) - ((or (integer? x) - (boolean? x) - (null? x)) - (list 'const x)) - (else (error "Only small ints and bool constants are supported for now" x)))) - ((% %library-ref x lib) - (list 'global x lib)) - ((% %variable sym) - (list 'local (translate-local atom))) - ((% %globals) - ; The globals array is stored in register 0. - (list 'local 0)) - ((% %label sym) - (list 'label (translate-local atom))) - (_ (error "Unexpected form in atom->bytecode" atom)))) - - - (define-record-type - (make-not-empty) - not-empty?) - - - (define *not-empty* (make-not-empty)) - - - (define (empty? m) - (guard (e ((not-empty? e) #f)) - (map-for-each (lambda (k v) - (raise *not-empty*)) - m) - #t)) - - - (define *temp-reg* 255) - - - (define (get-satisfying m pred) - (define elem #f) - (guard (e ((not-empty? e) elem)) - (map-for-each (lambda (k v) - (when (pred k) - (set! elem k) - (raise *not-empty*))) - m) - #f)) - - - (define (get-least m) - (define least #f) - (map-for-each (lambda (k v) - (when (or (not least) - (< k least)) - (set! least k))) - m) - least) - - - (define (chains in->out) - (define out->in (make-map compare-numbers)) - (map-for-each (lambda (k v) - (set! out->in (insert out->in v k))) - in->out) - (define currently-in-temp #f) - (loop with results = out->in - with save-regs = in->out - for easy-result = (get-satisfying results (lambda (x) (not (lookup save-regs x #f)))) - until (empty? results) - if easy-result - collect (let ((in (lookup out->in easy-result))) - (set! results (delete results easy-result)) - (set! save-regs (delete save-regs in)) - (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result)))) - else if currently-in-temp - collect (let ((target (lookup in->out currently-in-temp))) - (set! results (delete results target)) - (list 'mov (list 'local target) (list 'local *temp-reg*))) - and do (set! currently-in-temp #f) - else - append (let* ((any-result (get-least results)) - (in (lookup out->in any-result))) - (set! currently-in-temp any-result) - (set! results (delete results any-result)) - (set! save-regs (delete save-regs any-result)) - (list - (list 'mov (list 'local *temp-reg*) (list 'local any-result)) - (list 'mov (list 'local any-result) (list 'local in)))))) - - - (define (hash-symbol s) - (hash-bytevector (string->utf8 (symbol->string s)))) - - - (define (cmp-symbols s1 s2) - (cond - ((symbol=? s1 s2) 0) - ((stringstring s1) (symbol->string s2)) -1) - (else 1))) - - - (define (ir2->bytecode expr translate-local) - (define (a->b atom) - (atom->bytecode atom translate-local)) - (match expr - ((% %primitive op args res cont) - (cons - (append (list op) (map a->b res) (map a->b args)) - (ir2->bytecode cont translate-local))) - ((% %branch atom true false) - (define temp (translate-local (make-label (gensym)))) - (append - (list - (list 'jmpif (a->b atom) (list 'label temp))) - (ir2->bytecode false translate-local) - (list - (list 'label temp)) - (ir2->bytecode true translate-local))) - ((% %apply proc args) - (define in->out (make-map compare-numbers)) - (define constants - (loop for arg in args - for i from 1 - if (variable? arg) - unless (= (translate-local arg) i) - do (set! in->out (insert in->out (translate-local arg) i)) - end - else if (globals? arg) - do (set! in->out (insert in->out 0 i)) - else if (constant? arg) - collect (list 'mov (list 'local i) (list 'const (constant-expression arg))) - else if (label? arg) - collect (list 'mov (list 'local i) (list 'label (translate-local arg))) - else if (library-ref? arg) - collect (list 'mov (list 'local i) (list 'global - (library-ref-name arg) - (library-ref-library arg))) - else - do (error "Unexpected form in arguments list" arg))) - (define proc-temp (translate-local proc)) - (when (and (variable? proc) - (<= proc-temp (length args))) - (let ((available-reg (+ 1 (length args)))) - (set! in->out (insert in->out proc-temp available-reg)) - (set! proc-temp available-reg))) - (append - (chains in->out) - constants - (list - (if (label? proc) - (list 'jmp (list 'label proc-temp)) - (list 'jmp (list 'local proc-temp)))))) - ((% %tail) - (list - (list 'jmp (list 'label 0)))) - (_ (error "Unexpected form in ir2->bytecode" expr)))) - - - (define compare-labels - (make-comparer - (lambda (x) (gensym->int (label-gensym x))) - (lambda (x y) (- (gensym->int (label-gensym y)) (gensym->int (label-gensym x)))))) - - - (define compare-variables - (make-comparer - (lambda (x) (gensym->int (variable-gensym x))) - (lambda (x y) (- (gensym->int (variable-gensym y)) (gensym->int (variable-gensym x)))))) - - - ; Converts an IR2 program into bytecode. - (define (ir2->ir3 expr) - (define label-map (make-map compare-labels)) - (define next-label-id 1) ; start at 1 because label 0 is used for tail. - (define (translate-label x) - (or (lookup label-map x #f) - (let ((id next-label-id)) - (set! next-label-id (+ 1 next-label-id)) - (set! label-map (insert label-map x id)) - id))) - (define (make-locals-map args) - (define locals-map (make-map compare-variables)) - (loop for arg in args - for i from 1 - do (set! locals-map (insert locals-map arg i))) - (define local-count (length args)) - (lambda (x) - (if (label? x) - (translate-label x) - (or (lookup locals-map x #f) - (begin - (set! local-count (+ 1 local-count)) - ; start at 1, because register 0 holds the globals array - (set! locals-map (insert locals-map x local-count)) - local-count))))) - (append - (ir2->bytecode (fix-body expr) (make-locals-map '())) - (loop for func in (fix-functions expr) - collect (list 'label (translate-label (closure-name func))) - append (ir2->bytecode (closure-body func) (make-locals-map (closure-arguments func)))) - (list - (list 'label 0)))))) diff --git a/lib/csc/codegen.scheme b/lib/csc/codegen.scheme new file mode 100644 index 0000000..5423e91 --- /dev/null +++ b/lib/csc/codegen.scheme @@ -0,0 +1,161 @@ +(define-library (csc codegen) + (export cps->bytecode) + (import (scheme base) + (prefix (csc gensym) gensym.) + (prefix (csc ir) ir.) + (prefix (csc list) list.) + (prefix (csc map) map.)) + (import (scheme write)) + (begin + + + (define (const? x) + (or (ir.const? x) + (ir.void? x) + (ir.label? x))) + + + (define (const->bytecode atom) + (cond + ((ir.const? atom) + (let ((x (ir.const-val atom))) + (cond + ((and (integer? x) + (> x (- (expt 2 30) 1))) ; out of range for a small int + (error "I don't support big ints yet")) + ((or (integer? x) + (boolean? x) + (null? x)) + (list 'const x)) + (else (error "Only small ints and bool constants are supported for now" x))))) + ((ir.void? atom) + 'void) + ((ir.label? atom) + (list 'label (gensym.gensym->int (ir.label-var atom)))) + (else (error "unexpected form in const->bytecode" atom)))) + + + (define (atom->bytecode atom translate) + (if (gensym.gensym? atom) + (translate atom) + (const->bytecode atom))) + + + (define *temp-reg* 255) + + + ; https://en.wikipedia.org/wiki/Topological_sorting + (define (topological-sort g) + (define s + (list.filter + (lambda (x) (not (memv x (map cdr g)))) + (map car g))) + (let loop ((s s) + (g g)) + (if (null? s) + (if (null? g) + '() + (let ((n (caar g))) + (cons (list 'mov (list 'local *temp-reg*) (list 'local n)) + (loop (list n) + (map + (lambda (p) + (if (= n (cdr p)) + (cons (car p) *temp-reg*) + p)) + g))))) + (let ((n (car s)) + (s (cdr s))) + (define g* (list.filter (lambda (p) (not (= n (car p)))) g)) + (cond + ((assv n g) => (lambda (p) + (define m (cdr p)) + (cons (list 'mov (list 'local n) (list 'local m)) + (if (list.any (lambda (p) (= m (cdr p))) g*) + (loop s g*) + (loop (cons m s) g*))))) + (else (loop s g*))))))) + + + (define (check-primop-args op args vals conts) + (unless (and (= args (length (ir.primop-args op))) + (= vals (length (ir.primop-vals op))) + (= conts (length (ir.primop-ks op)))) + (error "wrong number of arguments passed to primop" op))) + + + (define (convert-cexpr expr translate) + (define (a->b atom) + (atom->bytecode atom translate)) + (cond + ((ir.apply? expr) + (let ((args (cons (ir.apply-func expr) (ir.apply-args expr)))) + (define constants + (let loop ((args args) + (i 0)) + (if (null? args) + '() + (let ((x (car args))) + (if (const? x) + (cons (list 'mov (list 'local i) (const->bytecode x)) + (loop (cdr args) (+ 1 i))) + (loop (cdr args) (+ 1 i))))))) + (define g + (let loop ((args args) + (i 0) + (g '())) + (if (null? args) + g + (let ((x (car args))) + (define y (translate x)) + (if (and (gensym.gensym? x) (not (= y i))) + (loop (cdr args) (+ 1 i) + (cons (cons i y) g)) + (loop (cdr args) (+ 1 i) g)))))) + (append + constants + (topological-sort g) + (list (list 'jmp (list 'local 0)))))) + ((and (ir.primop? expr) (symbol=? 'exit (ir.primop-name expr))) + (unless (= 1 (length (ir.primop-args expr))) + (error "wrong number of arguments passed to primop" expr)) + (list (list 'exit (atom->bytecode (car (ir.primop-args expr)) translate)))) + ((and (ir.primop? expr) + (memq (ir.primop-name expr) + '(peek + cons))) + (check-primop-args expr 2 1 1) + (cons + (list 'peek (a->b (car (ir.primop-vals expr))) + (a->b (car (ir.primop-args expr))) + (a->b (cadr (ir.primop-args expr)))) + (convert-cexpr (car (ir.primop-ks expr)) translate))) + (else (error "unexpected form in convert-cexpr" expr)))) + + + (define (make-translate args) + (define m (map.empty -)) + (define next-local 0) + (define (translate x) + (if (gensym.gensym? x) + (let ((n (gensym.gensym->int x))) + (or (map.lookup m n #f) + (let ((l next-local)) + (set! m (map.insert m n l)) + (set! next-local (+ 1 l)) + l))) + x)) + (for-each translate args) + translate) + + + (define (cps->bytecode expr) + (apply append + (convert-cexpr (ir.letrec-body expr) (make-translate '())) + (map + (lambda (p) + (define name (car p)) + (define func (cdr p)) + (cons (const->bytecode name) + (convert-cexpr (ir.lambda-body func) (make-translate (ir.lambda-vars func))))) + (ir.letrec-funcs expr)))))) diff --git a/lib/csc/compare-test.csc b/lib/csc/compare-test.csc deleted file mode 100644 index b710115..0000000 --- a/lib/csc/compare-test.csc +++ /dev/null @@ -1,98 +0,0 @@ -(define-library (csc compare-test) - (import (scheme base) - (only (csc match) - define-match-record-type) - (only (csc testing) - assert - test) - (csc compare)) - (begin - - - (test diff-list - (assert - (string=? - " ( - 1 - - 2 - 3 - + 3.5 - 4 - ) -" - (diff '(1 2 3 4) '(1 3 3.5 4))))) - - - (define-match-record-type - (make-test-type a b) - test-type? - %test-type - (a test-type-a) - (b test-type-b)) - - - (test diff-record - (assert - (string=? - " ( - (!type . - - ) - (a . - 5 - ) - (b . - - 5 - + 6 - ) - ) -" - (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type))))) - - - (test diff-multiline-string - (assert - (string=? - " ( - (!type . - string - ) - (value . - ( - line-one - - line-two - line-three - ) - ) - ) -" - (diff "line-one\nline-two\nline-three" "line-one\nline-three")))) - - - (test diff-vector - (assert - (string=? - " ( - (!type . - vector - ) - (value . - ( - 1 - - 2 - 3 - ) - ) - ) -" - (diff #(1 2 3) #(1 3))))) - - - (test diff-symbol-list - (assert - (string=? - "- symbol -+ ( -+ ) -" - (diff 'symbol '())))))) diff --git a/lib/csc/compare.csc b/lib/csc/compare.csc deleted file mode 100644 index e8e68d3..0000000 --- a/lib/csc/compare.csc +++ /dev/null @@ -1,248 +0,0 @@ -(define-library (csc compare) - (export diff apply-transformer) - (import (scheme base) - (only (scheme write) - display - write) - (only (csc strings) - contains? - split)) - (begin - ; compare is inspired by Go's cmp.Diff. - - - (define (print w . xs) - (unless (null? xs) - (let ((x (car xs))) - (if (or (string? x) - (symbol? x)) - (display x w) - (write x w))) - (apply print w (cdr xs)))) - - - (define (apply-transformer t x) - (if (list? t) - (let loop ((transformers t) - (x x)) - (if (null? transformers) - x - (loop (cdr transformers) - (apply-transformer (car transformers) x)))) - (if ((car t) x) - ((cdr t) x) - x))) - - - (define (alist? l) - (and (list? l) - (let loop ((l l)) - (cond - ((null? l) #t) - ((not (and (pair? (car l)) - (symbol? (caar l)))) - #f) - (else (loop (cdr l))))))) - - - (define (transform x transformers) - (define x* (apply-transformer transformers x)) - (cond - ((alist? x*) - (map (lambda (elem) - (define elem* (apply-transformer transformers elem)) - (if (pair? elem*) - (cons (car elem) (transform (cdr elem) transformers)) - elem*)) - x*)) - ((list? x*) - (map (lambda (elem) (transform elem transformers)) - x*)) - (else x*))) - - - ; As always, I copied the algorithm from Wikipedia - (define (lcs x y cmp) - (define x-vals (list->vector x)) - (define y-vals (list->vector y)) - (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0)) - (define (index i j) - (+ j (* i (+ 1 (vector-length y-vals))))) - (let loop-i ((i 1)) - (when (<= i (vector-length x-vals)) - (let loop-j ((j 1)) - (when (<= j (vector-length y-vals)) - (if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) - (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) - (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) - (vector-ref table (index i (- j 1)))))) - (loop-j (+ 1 j)))) - (loop-i (+ 1 i)))) - (let loop ((i (vector-length x-vals)) - (j (vector-length y-vals)) - (lcs '())) - (cond - ((or (= 0 i) (= 0 j)) lcs) - ((cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) - (loop (- i 1) (- j 1) (cons (vector-ref x-vals (- i 1)) lcs))) - ((> (vector-ref table (index i (- j 1))) (vector-ref table (index (- i 1) j))) - (loop i (- j 1) lcs)) - (else (loop (- i 1) j lcs))))) - - - (define (pretty w x indent) - (cond - ((list? x) - (print w indent " (\n") - (let ((new-indent (string-append indent " "))) - (for-each (lambda (v) - (pretty w v new-indent)) - x)) - (print w indent " )\n")) - ((and (pair? x) - (symbol? (car x))) - (print w indent " (" (car x) " .\n") - (pretty w (cdr x) (string-append indent " ")) - (print w indent " )\n")) - (else (print w indent " " x "\n")))) - - - (define (diff* w x y indent) - (cond - ((or (and (boolean? x) (boolean? y)) - (and (char? x) (char? y)) - (and (symbol? x) (symbol? y)) - (and (number? x) (number? y)) - (and (string? x) (string? y))) - (if (equal? x y) - (begin - (print w indent " " x "\n") - #t) - (begin - (print w indent "- " x "\n" indent "+ " y "\n") - #f))) - ((and (alist? x) (alist? y)) - (print w indent " (\n") - (let ((key-lcs (lcs (map car x) (map car y) symbol=?)) - (indent* (string-append indent " ")) - (equal #t)) - (let loop () - (unless (and (null? key-lcs) - (null? x) - (null? y)) - (cond - ((and (null? key-lcs) - (null? x)) - (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f)) - ((null? key-lcs) - (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f)) - ((symbol=? (caar x) (caar y) (car key-lcs)) - (print w indent* " (" (car key-lcs) " .\n") - (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) - equal)) - (print w indent* " )\n") - (set! x (cdr x)) - (set! y (cdr y)) - (set! key-lcs (cdr key-lcs))) - ((symbol=? (caar x) (car key-lcs)) - (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f)) - (else - (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f))) - (loop))) - (print w indent " )\n") - equal)) - ((and (list? x) (list? y)) - (print w indent " (\n") - (let* ((common (lcs x y equal?)) - (indent* (string-append indent " ")) - (equal #t)) - (let loop () - (unless (and (null? common) - (null? x) - (null? y)) - (cond - ((and (null? common) - (null? x)) - (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f)) - ((and (null? common) - (null? y)) - (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f)) - ((null? common) - (diff* w (car x) (car y) indent*) - (set! x (cdr x)) - (set! y (cdr y)) - (set! equal #f)) - ((equal? (car x) (car y)) - (pretty w (car x) (string-append indent* " ")) - (set! x (cdr x)) - (set! y (cdr y)) - (set! common (cdr common))) - ((equal? (car x) (car common)) - (pretty w (car y) (string-append indent* "+")) - (set! y (cdr y)) - (set! equal #f)) - ((equal? (car y) (car common)) - (pretty w (car x) (string-append indent* "-")) - (set! x (cdr x)) - (set! equal #f)) - (else - (diff* w (car x) (car y) indent*) - (set! x (cdr x)) - (set! y (cdr y)) - (set! equal #f))) - (loop))) - (print w indent " )\n") - equal)) - (else - (pretty w x (string-append indent "-")) - (pretty w y (string-append indent "+")) - #f))) - - - (define default-transformers - (list - (cons (lambda (s) - (and (string? s) - (contains? s "\n"))) - (lambda (s) - (list (cons '!type 'string) - (cons 'value (split s "\n"))))) - (cons vector? (lambda (v) - (list (cons '!type 'vector) - (cons 'value (vector->list v))))) - (cons bytevector? (lambda (b) - (list (cons '!type 'bytevector) - (cons 'value (let loop ((i 0) - (acc '())) - (when (< i (bytevector-length b)) - (loop (+ 1 i) - (cons (string-append "0x" (number->string - (bytevector-u8-ref b i) - 16)) - acc))) - (reverse acc)))))))) - - - ; Returns a string diff between x and y. Diff knows how to compare lists, - ; alists and other primitive types. Any user-defined type needs a - ; transformer. Each transformer is a pair of type predicate that the - ; transformer matches on, and a function that transforms a value of that - ; type into an alist. - (define (diff x y . transformers) - (define d (open-output-string)) - (define t* (cons default-transformers transformers)) - (if (diff* d (transform x t*) (transform y t*) "") - "" - (get-output-string d))))) diff --git a/lib/csc/compiler.csc b/lib/csc/compiler.csc deleted file mode 100644 index ee6ca0f..0000000 --- a/lib/csc/compiler.csc +++ /dev/null @@ -1,202 +0,0 @@ -(define-library (csc compiler) - (export - add-library-search-dirs - compile) - (import (scheme base) - (only (scheme file) - call-with-input-file - file-exists?) - (only (scheme read) - read) - (only (csc codegen) - ir2->ir3) - (only (csc config) - *standard-library-dir*) - (only (csc cps) - closure-convert - ir1->ir2) - (only (csc encoding) - encode) - (only (csc format) - sprintf) - (only (csc hash-map) - compare-symbols - hash-bytevector - insert - key-not-found-error? - lookup - make-comparer - make-map - merge) - (only (csc ir1) - %define-syntax - %library-define - %library-ref - %sequence - library-ref-name) - (only (csc ir2) - *tail*) - (only (csc linker) - link) - (only (csc list) - revappend) - (only (csc loop) - loop - return) - (only (csc macros) - builtins-environment - expand-body) - (only (csc match) - match) - (only (csc strings) - join - last-index)) - (begin - - - (define (dirname f) - (define i (last-index f "/")) - (if (negative? i) - "." - (substring f 0 i))) - - - (define (read-file f) - (call-with-input-file f - (lambda (p) - (loop for expr = (read p) - until (eof-object? expr) - collect expr)))) - - - (define (normalize-library lib-file) - (define dir (dirname lib-file)) - (define lib (call-with-input-file lib-file read)) - (match lib - (('define-library name . declarations) - (define decls - (loop for decl in declarations - if (match decl (('include-library-declarations _) #t) - (_ #f)) - append (read-file (sprintf "{}/{}" dir (cadr decl))) - else collect decl)) - (loop for decl in decls - if (match decl (('export . _) #t) - (_ #f)) - append (cdr decl) into exports - else if (match decl (('import . _) #t) - (_ #f)) - append (cdr decl) into imports - else if (match decl (('begin . _) #t) - (_ #f)) - append (cdr decl) into body - else - do (error "unexpected form in normalize-library" decl) - finally (return (list 'define-library name - (cons 'export exports) - (cons 'import imports) - (cons 'begin body))))) - (_ (error "unexpected form in normalize-library" lib)))) - - - (define compare-library-names - (make-comparer - (lambda (x) - (hash-bytevector (string->utf8 (sprintf "{}" x)))) - (lambda (x y) - (cond - ((equal? x y) 0) - ((stringstring part) into path - finally (return (sprintf "{}/{}.csc" dir (join "/" path)))) - if (file-exists? file-path) - return file-path - else - collect file-path into bad-paths - finally (error "unable to find library" name bad-paths))) - - - (define (ir1->bytecode expr) - (define c (closure-convert (ir1->ir2 expr (lambda (x) *tail*)))) - (define b (ir2->ir3 c)) - b) - - - ; compile turns scheme code into bytecode. - (define (compile program) - (define library-symbols (make-map compare-library-names)) - (define (make-import-map imports) - (define env (make-map compare-symbols)) - (loop for import in imports - do (set! env - (merge env (load-library import))) - finally (return env))) - (define library-code '()) - (define (compile-library lib-file) - (define lib (normalize-library lib-file)) - (match lib - (('define-library library-name - ('export . exports) - ('import . imports) - ('begin . body)) - - (define env (make-import-map imports)) - (define expanded-body (expand-body library-name body env)) - - (let loop ((expr expanded-body)) - (match expr - ((% %library-define ref _) - (set! env (insert env (library-ref-name ref) ref))) - ((% %define-syntax name val) - (set! env (insert env name val))) - ((% %sequence head tail) - (loop head) - (loop tail)))) - - (define exported-symbols (make-map compare-symbols)) - (loop for sym in exports - do (set! exported-symbols - (insert exported-symbols sym - (guard (e ((key-not-found-error? e) (error "exported symbol was not defined in the library" sym))) - (lookup env sym))))) - - (set! library-symbols (insert library-symbols library-name exported-symbols)) - (set! library-code (cons (ir1->bytecode expanded-body) library-code)) - exported-symbols) - (_ (error "unexpected form in compile-library" lib)))) - (define (load-library lib) - (match lib - (('only lib . symbols) - (define m (load-library lib)) - (define m* (make-map compare-symbols)) - (for-each (lambda (symb) - (set! m* (insert m* symb (guard (e ((key-not-found-error? e) (error "symbol does not exist in library" symb))) - (lookup m symb))))) - symbols) - m*) - ('(csc builtins) - builtins-environment) - (_ (or (lookup library-symbols lib #f) - (compile-library (find-library lib)))))) - - (match program - ((('import . imports1) ('import . imports2) . rest) - (compile (cons (cons 'import (append imports1 imports2)) rest))) - ((('import . imports) . body) - (define compiled-body (ir1->bytecode (expand-body 'main body (make-import-map imports)))) - (encode (link (revappend library-code (list compiled-body (list (list 'exit (list 'const 0)))))))) - (_ (error "unexpected form in compile" program)))))) diff --git a/lib/csc/compiler.scheme b/lib/csc/compiler.scheme new file mode 100644 index 0000000..b687038 --- /dev/null +++ b/lib/csc/compiler.scheme @@ -0,0 +1,263 @@ +(define-library (csc compiler) + (export compile) + (import (scheme base) + (only (scheme read) read) + (only (scheme write) write) + (prefix (csc codegen) codegen.) + (prefix (csc config) config.) + (prefix (csc cps) cps.) + (prefix (csc encoding) encoding.) + (prefix (csc ir) ir.) + (prefix (csc list) list.) + (prefix (csc macros) macros.) + (prefix (csc map) map.) + (prefix (scheme file) file.)) + (begin + + + (define-record-type + (make-library name exports imports body) + library? + (name library-name) + (exports library-exports) + (imports library-imports) + (body library-body)) + + + (define (library-name? form) + (and (list? form) + (list.all + (lambda (x) + (or (symbol? x) + (and (exact-integer? x) + (not (negative? x))))) + form))) + + + (define (sprint x) + (define w (open-output-string)) + (write x w) + (get-output-string w)) + + + (define (parse-library form) + (unless (and (list? form) + (>= (length form) 2) + (symbol=? (car form) 'define-library) + (library-name? (cadr form))) + (error "unexpected form")) + (let loop ((decls (cddr form)) + (exports '()) + (imports '()) + (body '())) + (if (null? decls) + (make-library (sprint (cadr form)) (apply append exports) (apply append imports) (apply append (reverse body))) + (let ((decl (car decls))) + (cond + ((null? decl) + (error "invalid library declaration")) + ((symbol=? (car decl) 'export) + (loop (cdr decls) (cons (cdr decl) exports) imports body)) + ((symbol=? (car decl) 'import) + (loop (cdr decls) exports (cons (cdr decls) imports) body)) + ((symbol=? (car decl) 'begin) + (loop (cdr decls) exports imports (cons (cdr decls) body)))))))) + + + (define (import? form) + (and (list? form) + (not (null? form)) + (symbol=? (car form) 'import))) + + + (define (split-imports-body prog) + (if (or (null? prog) + (not (import? (car prog)))) + (values '() prog) + (let-values (((imports body) (split-imports-body (cdr prog)))) + (values (append (cdar prog) imports) body)))) + + + (define (import-name import-set) + (unless (list? import-set) + (error "invalid import set")) + (cond + ((and (not (null? import-set)) + (or (symbol=? (car import-set) 'only) + (symbol=? (car import-set) 'except) + (symbol=? (car import-set) 'prefix) + (symbol=? (car import-set) 'rename))) + (library-name (cadr import-set))) + ((library-name? import-set) + (sprint import-set)) + (else (error "invalid import form" import-set)))) + + + (define (open-library library-name search-dirs) + (define library-roots (cons config.*standard-library-dir* search-dirs)) + (or + (list.any + (lambda (dir) + (define library-path + (string-append + (apply string-append dir "/" (list.intersperse "/" (map sprint library-name))) + ".scheme")) + (guard (e ((file-error? e) #f)) + (file.call-with-input-file library-path + (lambda (f) + (parse-library (read f)))))) + library-roots) + (error "unable to find library" library-name))) + + + (define (cmp-strings x y) + (cond + ((string=? x y) 0) + ((stringstring expr))) + ((list? expr) + (map (lambda (x) (tag-library-vars x library-name)) expr)) + (else expr))) + + + (define (parse-import-set import-set exports) + (unless (list? import-set) + (error "invalid import set")) + (cond + ((library-name? import-set) + (let* ((libname (sprint import-set)) + (my-exports (map.lookup exports libname))) + (unless (list.all symbol? my-exports) + (error "invalid exports" libname my-exports)) + (list.foldl + (lambda (acc x) + (define x-str (symbol->string x)) + (map.insert acc + x-str + (ir.make-libvar libname x-str))) + *empty-string-map* + my-exports))) + ((and (>= (length import-set) 2) + (symbol=? (car import-set) 'only)) + (let ((subimports (parse-import-set (cadr import-set) exports)) + (only-these (map.list->map cmp-strings (map (lambda (x) (cons (symbol->string x) #f)) (cddr import-set))))) + (map.intersect only-these subimports))) + ((and (>= (length import-set) 2) + (symbol=? (car import-set) 'except)) + (let ((subimports (parse-import-set (cadr import-set) exports)) + (skip-these (map.list->map cmp-strings (map (lambda (x) (cons (symbol->string x) #f)) (cddr import-set))))) + (map.intersect subimports skip-these))) + ((and (= (length import-set) 3) + (symbol=? (car import-set) 'prefix)) + (let-values (((set prefix) (apply values (cdr import-set)))) + (define subimports (parse-import-set set exports)) + (unless (symbol? prefix) + (error "invalid prefix" prefix)) + (let ((prefix-str (symbol->string prefix))) + (list.foldl + (lambda (acc x) + (map.insert acc + (string-append prefix-str (car x)) + (cdr x))) + *empty-string-map* + (map.map->list subimports))))) + ((and (>= (length import-set) 2) + (symbol=? (car import-set) 'rename)) + (let ((subimports (parse-import-set (cadr import-set) exports))) + (list.foldl + (lambda (acc x) + (unless (and (list? x) + (= (length x) 2) + (list.all symbol? x)) + (error "invalid rename form")) + (let* ((in-str (symbol->string (car x))) + (prev-binding (map.lookup acc in-str #f))) + (unless prev-binding + (error "cannot rename symbol" in-str)) + (map.insert + (map.delete acc in-str) + (symbol->string (cadr x)) + prev-binding))) + subimports + (cddr import-set)))) + (else (error "invalid import set" import-set)))) + + + (define (shuffle-imports name imports exports) + (define import-map + (apply map.union + *empty-string-map* + (map (lambda (x) (parse-import-set x exports)) + imports))) + (map + (lambda (x) + (list (ir.make-libvar "(csc builtins)" "define") + (ir.make-libvar name (car x)) + (cdr x))) + (map.map->list import-map))) + + + (define (mangle-library l exports) + (append + (shuffle-imports (library-name l) (library-imports l) exports) + (map + (lambda (x) + (tag-library-vars x (library-name l))) + (library-body l)))) + + + (define (compile prog library-search-dirs) + (define-values (imports body) (split-imports-body prog)) + (define libraries (open-imports imports library-search-dirs)) + (define exports (export-map libraries)) + (define whole-prog (append (apply append (map (lambda (x) (mangle-library x exports)) libraries)) + (shuffle-imports "__main__" imports exports) + (map (lambda (x) (tag-library-vars x "__main__")) body))) + (define expanded (macros.expand-program whole-prog)) + (define cps (cps.ir->cps expanded)) + (define bytecode (codegen.cps->bytecode cps)) + (encoding.encode bytecode)))) diff --git a/lib/csc/config.csc b/lib/csc/config.csc deleted file mode 100644 index d2618a7..0000000 --- a/lib/csc/config.csc +++ /dev/null @@ -1,7 +0,0 @@ -(define-library (csc config) - (export *standard-library-dir*) - (import (scheme base)) - (begin - - - (define *standard-library-dir* "/usr/lib/csc"))) diff --git a/lib/csc/config.scheme b/lib/csc/config.scheme new file mode 100644 index 0000000..d2618a7 --- /dev/null +++ b/lib/csc/config.scheme @@ -0,0 +1,7 @@ +(define-library (csc config) + (export *standard-library-dir*) + (import (scheme base)) + (begin + + + (define *standard-library-dir* "/usr/lib/csc"))) diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc deleted file mode 100644 index 256e9e3..0000000 --- a/lib/csc/cps-test.csc +++ /dev/null @@ -1,379 +0,0 @@ -(define-library (csc cps-test) - (import (scheme base) - (only (csc gensym) - gensym - gensym?) - (only (csc ir1) - %constant - %lexical-ref - %library-ref - constant? - lexical-ref? - library-ref? - make-call - make-call-builtin - make-constant - make-define-syntax - make-if - make-lambda - make-letrec - make-lexical-ref - make-lexical-set - make-library-ref - make-sequence) - (only (csc ir2) - %apply - %branch - %closure - %fix - %globals - %label - %primitive - %variable - *globals* - apply? - branch? - closure? - fix? - globals? - label? - make-apply - make-branch - make-call-closure - make-closure - make-fix - make-label - make-primitive - make-variable - primitive? - variable?) - (only (csc testing) - assert-equal - test) - (csc cps)) - (begin - - - (define transform-ir2 - (list - (cons constant? %constant) - (cons lexical-ref? %lexical-ref) - (cons library-ref? %library-ref) - (cons variable? %variable) - (cons globals? %globals) - (cons label? %label) - (cons primitive? %primitive) - (cons branch? %branch) - (cons apply? %apply) - (cons closure? %closure) - (cons fix? %fix) - (cons gensym? (lambda (x) 'gensym)))) - - - (define (test-ref name) - (make-lexical-ref name (gensym))) - - - (define (tail x multi) - (make-apply (test-ref 'tail) (list x))) - - - (define generated-symbol (test-ref 'generated-symbol)) - - - (test atom-const - (assert-equal - (make-apply (test-ref 'tail) (list (make-constant 5))) - (ir1->ir2 (make-constant 5) tail) - transform-ir2)) - - - (test atom-lexical-ref - (assert-equal - (make-apply (test-ref 'tail) (list (test-ref 'var))) - (ir1->ir2 (test-ref 'var) tail) - transform-ir2)) - - - (test atom-library-ref - (assert-equal - (make-primitive 'peek (list *globals* (make-library-ref 'var '(csc builtins))) (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol))) - (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail) - transform-ir2)) - - - (test lexical-set - (assert-equal - (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) - transform-ir2)) - - - (test no-op-define-syntax - (assert-equal - (make-apply (test-ref 'tail) (list (make-constant #f))) - (ir1->ir2 (make-define-syntax 'name '(transformer)) - tail) - transform-ir2)) - - - (test branch - (assert-equal - (make-fix - (list - (make-closure generated-symbol (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol)))) - (make-branch (make-constant #t) - (make-primitive 'cons (list (make-constant 1) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))) - (make-primitive 'cons (list (make-constant 2) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))))) - (ir1->ir2 (make-if (make-constant #t) - (make-constant 1) - (make-constant 2)) - tail) - transform-ir2)) - - - (test call-closure - (assert-equal - (make-fix - (list - (make-closure generated-symbol (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol)))) - (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list generated-symbol) - (make-primitive 'cons (list (make-constant 10) generated-symbol) (list generated-symbol) - (make-apply (test-ref 'f) (list generated-symbol generated-symbol))))) - (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20))) - tail) - transform-ir2)) - - - (test call-builtin-alloc - (assert-equal - (make-primitive 'alloc (list (make-constant 10)) (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol))) - (ir1->ir2 (make-call-builtin 'alloc (list (make-constant 10))) tail) - transform-ir2)) - - - (test call-builtin-peek - (assert-equal - (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol) - (make-primitive 'peek (list generated-symbol (make-constant 0)) (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol)))) - (ir1->ir2 - (make-call-builtin 'peek (list (make-call-builtin 'alloc (list (make-constant 1))) (make-constant 0))) - tail) - transform-ir2)) - - - (test call-builtin-poke - (assert-equal - (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol) - (make-primitive 'poke (list (make-constant 10) generated-symbol (make-constant 0)) '() - (make-apply (test-ref 'tail) (list (make-constant #f))))) - (ir1->ir2 - (make-call-builtin 'poke (list (make-constant 10) - (make-call-builtin 'alloc (list (make-constant 1))) - (make-constant 0))) - tail) - transform-ir2)) - - - (test sequence - (assert-equal - (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) - transform-ir2)) - - - (test closure - (assert-equal - (make-fix - (list (make-closure generated-symbol (list generated-symbol (test-ref 'c)) - (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))))) - (make-apply (test-ref 'tail) (list generated-symbol))) - (ir1->ir2 (make-lambda - (test-ref 'c) - (make-constant 5)) - tail) - transform-ir2)) - - - (test letrec-functions - (define x (test-ref 'x)) - (define f (gensym)) - (assert-equal - (make-fix - (list - (make-closure (test-ref 'f) (list generated-symbol (test-ref 'x)) - (make-primitive 'cons (list (test-ref 'x) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))))) - (make-fix - (list - (make-closure generated-symbol (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol)))) - (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol) - (make-apply (test-ref 'f) (list generated-symbol generated-symbol))))) - (ir1->ir2 - (make-letrec #f '(f) (list f) - (list (make-lambda x x)) - (make-call (make-lexical-ref 'f f) (list (make-constant 10)))) - tail) - transform-ir2)) - - - (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-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 b) - (list a (gensym)) - (list (make-constant 1) - (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 generated-symbol (test-ref 'args)) - (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))))) - (make-apply (test-ref 'tail) (list (make-constant 10)))) - (ir1->ir2 - (make-letrec #t - '(f) - (list (gensym)) - (list (make-lambda (test-ref 'args) (make-constant 5))) - (make-constant 10)) - tail) - transform-ir2)) - - - ; What does the following letrec return? - ; (letrec* ((f (lambda () x)) - ; (x (f))) - ; x) - (test letrec-very-cool - (define f (gensym)) - (define x (gensym)) - (assert-equal - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) - (make-fix - (list - (make-closure (test-ref 'f) (list generated-symbol (test-ref 'args)) - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol) - (make-primitive 'cons (list generated-symbol (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol)))))) - (make-fix - (list - (make-closure generated-symbol (list generated-symbol) - (make-primitive 'assert-singleton (list generated-symbol) (list generated-symbol) - (make-primitive 'poke (list generated-symbol (test-ref 'x) (make-constant 0)) '() - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol) - (make-apply (test-ref 'tail) (list generated-symbol))))))) - (make-apply (test-ref 'f) (list generated-symbol (make-constant '())))))) - (ir1->ir2 - (make-letrec #t - '(f x) - (list f x) - (list (make-lambda (test-ref 'args) (make-lexical-ref 'x x)) - (make-call (make-lexical-ref 'f f) '())) - (make-lexical-ref 'x x)) - tail) - transform-ir2)) - - - (test set-argument - (define test-sym (gensym)) - (assert-equal - (make-fix - (list - (make-closure (test-ref 'f) (list generated-symbol generated-symbol) - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'args)) - (make-primitive 'poke (list generated-symbol (test-ref 'args) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'args) (make-constant 0)) '() - (make-primitive 'cons (list (make-constant #f) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol)))))))) - (make-apply (test-ref 'tail) (list (make-constant 5)))) - (ir1->ir2 (make-letrec - #f - '(f) - (list (gensym)) - (list (make-lambda (make-lexical-ref 'args test-sym) - (make-lexical-set (make-lexical-ref 'args test-sym) (make-constant 10)))) - (make-constant 5)) - tail) - transform-ir2)) - - (test set-function - (define test-sym (gensym)) - (assert-equal - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f)) - (make-fix - (list (make-closure generated-symbol (list generated-symbol (test-ref 'args)) - (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol) - (make-apply generated-symbol (list generated-symbol))))) - (make-primitive 'poke (list 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))))))) - (ir1->ir2 (make-letrec - #f - '(f) - (list test-sym) - (list (make-lambda (test-ref 'args) (make-constant 10))) - (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5))) - tail) - transform-ir2)) - - - (define (test-var) - (make-variable (gensym))) - - - (test closure-convert-primitive - (define a-sym (gensym)) - (define f-sym (gensym)) - (define ret-sym (gensym)) - (define x-sym (gensym)) - (assert-equal - (make-fix - (list (make-closure (make-label (gensym)) (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)) - (make-apply (test-var) (list (test-var) (make-constant #f)))))))) - (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) - (make-primitive 'alloc (list (make-constant 2)) (list (test-var)) - (make-primitive 'poke (list (make-label (gensym)) (test-var) (make-constant 0)) '() - (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '() - (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) - (make-apply (test-var) (list (test-var) (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))))) - (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)) - (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)))))) - transform-ir2)))) diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc deleted file mode 100644 index 4242681..0000000 --- a/lib/csc/cps.csc +++ /dev/null @@ -1,589 +0,0 @@ -(define-library (csc cps) - (export - closure-convert - ir1->ir2) - (import (scheme base) - (only (csc gensym) - gensym - gensym->int) - (only (csc hash-map) - insert - key-not-found-error? - lookup - make-comparer - make-map - map->alist - merge) - (only (csc ir1) - %call - %call-builtin - %define-syntax - %if - %lambda - %letrec - %lexical-ref - %lexical-set - %library-define - %library-ref - %sequence - call? - constant? - if? - lambda? - letrec-gensyms - letrec-names - letrec-values - letrec? - lexical-ref-gensym - lexical-ref? - lexical-set? - library-define? - library-ref? - make-call - make-call-builtin - make-constant - make-if - make-lambda - make-letrec - make-lexical-ref - make-lexical-set - make-library-define - make-library-ref - make-sequence - sequence?) - (only (csc ir2) - %apply - %branch - %closure - %fix - %primitive - %tail - *globals* - *tail* - branch-atom - closure-arguments - closure-body - closure-name - make-apply - make-branch - make-call-closure - make-closure - make-fix - make-label - make-primitive - make-variable - tail?) - (only (csc loop) - loop - return) - (only (csc match) - define-match-record-type - match)) - (begin - - - (define (new-ref) - (make-lexical-ref 'generated-symbol (gensym))) - - - ; Update is a CPS expression that is used internally as part of - ; CPS conversion. - ; Update expressions are then removed by box-conversion. - (define-match-record-type - (make-update ref atom continuation) - update? - %update - (ref update-ref) - (atom update-atom) - (continuation update-continuation)) - - - (define-syntax singleton-continuation - (syntax-rules () - ((singleton-continuation (val) body ...) - (lambda (x multi) - (define (b val) body ...) - (if multi - (let ((v (new-ref))) - (make-primitive 'assert-singleton (list x) (list v) - (b v))) - (b x)))))) - - - (define-syntax varargs-continuation - (syntax-rules () - ((varargs-continuation (vals) body ...) - (lambda (x multi) - (define (b vals) body ...) - (if multi - (b x) - (let ((l (new-ref))) - (make-primitive 'cons (list x (make-constant '())) (list l) - (b l)))))))) - - - (define (collect-functions-and-variables expr) - (let ((names (letrec-names expr)) - (gensyms (letrec-gensyms expr)) - (vals (letrec-values expr))) - (loop for name in names - for gensym in gensyms - for value in vals - if (lambda? value) - collect (match value - ((% %lambda args body) - (define continuation (new-ref)) - (make-closure - (make-lexical-ref name gensym) - (list continuation args) - (to-cps - body - (varargs-continuation (z) - (make-apply continuation (list z))))))) - into functions - else - collect (make-lexical-ref name gensym) into variable-names - and collect value into variable-values - finally (return (values functions variable-names variable-values))))) - - - ; Converts the given IR1 expression that has undergone argument conversion - ; into an IR2 expression in continuation passing style. - ; The resulting expression will include forms. - (define (to-cps expr continuation) - (match expr - (_ when (or (constant? expr) - (lexical-ref? expr)) - (continuation expr #f)) - ((% %library-ref . _) - (define temp (new-ref)) - (make-primitive 'peek (list *globals* expr) (list temp) - (continuation temp #f))) - ((% %lexical-set ref arg) - (to-cps - arg - (singleton-continuation (val) - (make-update ref val (continuation (make-constant #f) #f))))) - ((% %library-define ref arg) - (to-cps - arg - (singleton-continuation (val) - (make-update ref val (continuation (make-constant #f) #f))))) - ((% %define-syntax _ _) - ; no-op - (continuation (make-constant #f) #f)) - ((% %if test consequent alternate) - (to-cps - test - (singleton-continuation (val) - (define continuation-ref (new-ref)) - (define result-ref (new-ref)) - (make-fix - (list (make-closure continuation-ref (list result-ref) - (continuation result-ref #t))) - (make-branch val - (to-cps - consequent - (varargs-continuation (result) - (make-apply continuation-ref (list result)))) - (to-cps - alternate - (varargs-continuation (result) - (make-apply continuation-ref (list result))))))))) - ((% %call proc args) - (define return-address (new-ref)) - (define result (new-ref)) - (make-fix - (list (make-closure return-address (list result) (continuation result #t))) - (to-cps - proc - (singleton-continuation (f) - (to-cps - (loop for arg in (reverse args) - with arglist = (make-constant '()) - do (set! arglist (make-call-builtin 'cons (list arg arglist))) - finally (return arglist)) - (singleton-continuation (v) - (make-apply f (list return-address v)))))))) - ((% %call-builtin 'call-with-current-continuation (proc)) - (define return-address (new-ref)) - (define current-continuation (new-ref)) - (define result1 (new-ref)) - (define result2 (new-ref)) - (define arglist (new-ref)) - (make-fix - (list (make-closure return-address (list result1) - (continuation result1 #t)) - (make-closure current-continuation (list (new-ref) result2) - (make-apply return-address (list result2)))) - (make-primitive 'cons (list current-continuation (make-constant '())) (list arglist) - (to-cps proc - (singleton-continuation (f) - (make-apply f (list return-address arglist))))))) - ((% %call-builtin 'call-with-values (producer consumer)) - (define return-address (new-ref)) - (define consumer-func (new-ref)) - (define result (new-ref)) - (define results (new-ref)) - (make-fix - (list (make-closure return-address (list result) - (continuation result #t)) - (make-closure consumer-func (list results) - (to-cps consumer - (singleton-continuation (c) - (make-apply c (list return-address results)))))) - (to-cps producer - (singleton-continuation (p) - (make-apply p (list consumer-func (make-constant '()))))))) - ((% %call-builtin 'apply (proc args)) - (define return-address (new-ref)) - (define result (new-ref)) - (make-fix - (list (make-closure return-address (list result) (continuation result #t))) - (to-cps - proc - (singleton-continuation (f) - (to-cps - args - (singleton-continuation (l) - (make-apply f (list return-address l)))))))) - ((% %call-builtin op args) - (define returns-value? (not (memq op '(poke exit)))) - (loop for arg in (reverse args) - with expr = (lambda (vals) - (if returns-value? - (let ((result (new-ref))) - (make-primitive op (reverse vals) (list result) - (continuation result #f))) - (make-primitive op (reverse vals) '() - (continuation (make-constant #f) #f)))) - do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. - (arg* arg)) - (lambda (vals) - (to-cps arg* - (singleton-continuation (val) - (e* (cons val vals))))))) - finally (return (expr '())))) - ((% %sequence head tail) - (to-cps - head - (lambda (x multi) - (to-cps - tail - continuation)))) - ((% %lambda args body) - (define f (new-ref)) - (define k (new-ref)) - (make-fix - (list - (make-closure f (list k args) - (to-cps - body - (varargs-continuation (ret) - (make-apply k (list ret)))))) - (continuation f #f))) - ((% %letrec _ _ _ _ body) - (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) - (if (null? variable-names) - (make-fix functions - (to-cps body continuation)) - (let ((new-expr (loop for var in (reverse variable-names) - for val in (reverse variable-values) - with new-body = (to-cps body continuation) - do (set! new-body (to-cps val (singleton-continuation (x) - (make-update var x - new-body)))) - finally (return new-body)))) - (unless (null? functions) - (set! new-expr (make-fix functions new-expr))) - (loop for var in variable-names - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) - new-expr)) - finally (return new-expr))))) - (_ (error "unexpected type in to-cps" expr)))) - - - (define compare-refs - (make-comparer - (lambda (ref) - (gensym->int (lexical-ref-gensym ref))) - (lambda (x y) - (- (gensym->int (lexical-ref-gensym y)) (gensym->int (lexical-ref-gensym x)))))) - - - (define (make-ref-map) - (make-map compare-refs)) - - - (define (get-boxed expr) - (match expr - ((% %update ref _ continuation) - (define m (get-boxed continuation)) - (when (lexical-ref? ref) - (set! m (insert m ref #t))) - m) - ((% %primitive _ _ _ continuation) - (get-boxed continuation)) - ((% %branch _ true false) - (merge - (get-boxed true) - (get-boxed false))) - ((% %apply proc args) - (make-ref-map)) - ((% %tail) - (make-ref-map)) - ((% %fix funs body) - (loop with m = (get-boxed body) - for fun in funs - do (set! m (merge m (get-boxed - (closure-body fun)))) - finally (return m))) - (_ (error "Unexpected form in get-boxed" expr)))) - - - ; Rewrites the given expression to have no more forms. - (define (box-conversion expr) - (define boxed-refs (get-boxed expr)) - (define (boxed? ref) - (and (lexical-ref? ref) - (guard (e ((key-not-found-error? e) #f)) - (lookup boxed-refs ref)))) - (define (convert-arg-list args) - (define boxed-args (loop for arg in args - if (boxed? arg) - collect arg)) - (define vars (loop for x in boxed-args - collect (new-ref))) - (define new-args (loop with v* = vars - for arg in args - collect (if (boxed? arg) - (car v*) - arg) - if (boxed? arg) - do (set! v* (cdr v*)))) - (values new-args boxed-args vars)) - (let convert ((expr expr)) - (match expr - ((% %update ref atom continuation) when (library-ref? ref) - (make-primitive 'poke (list atom *globals* ref) '() - (convert continuation))) - ((% %update ref atom continuation) when (lexical-ref? ref) - (make-primitive 'poke (list atom ref (make-constant 0)) '() (convert continuation))) - ((% %primitive op args res continuation) - ; Note that no reference in res can be boxed. - (define-values (new-args boxed-args vars) (convert-arg-list args)) - (define new-expr (make-primitive op new-args res (convert continuation))) - (loop for arg in boxed-args - for var in vars - do (set! new-expr (make-primitive 'peek (list arg (make-constant 0)) (list var) - new-expr)) - finally (return new-expr))) - ((% %branch atom true false) when (boxed? atom) - (define temp (new-ref)) - (make-primitive 'peek (list atom (make-constant 0)) (list temp) - (make-branch temp - (convert true) - (convert false)))) - ((% %branch atom true false) - (make-branch atom - (convert true) - (convert false))) - ((% %apply proc args) - (define-values (new-params boxed-params vars) (convert-arg-list (cons proc args))) - (define new-expr (make-apply (car new-params) (cdr new-params))) - (loop for p in boxed-params - for var in vars - do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var) - new-expr)) - finally (return new-expr))) - ((% %tail) - *tail*) - ((% %fix funs body) - (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs - collect (closure-name fun)))) - (define new-funs (loop for fun in funs - for new-name in new-names - collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun)))) - (make-closure - new-name - new-args - (let ((new-expr (convert (closure-body fun)))) - (loop for arg in boxed-args - for var in temp-args - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list arg) - (make-primitive 'poke (list var arg (make-constant 0)) '() - new-expr))) - finally (return new-expr))))))) - (define new-body (convert body)) - (loop for name in boxed-names - for var in temp-names - do (set! new-body (make-primitive 'poke (list var name (make-constant 0)) '() - new-body))) - (define new-expr (make-fix new-funs new-body)) - (loop for name in boxed-names - do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name) - new-expr)) - finally (return new-expr))) - (_ (error "Unexpected form in box-conversion" expr))))) - - - (define (ir1->ir2 expr continuation) - (box-conversion - (to-cps expr continuation))) - - - (define (hoist expr) - (define functions '()) - (define body - (let hoist ((expr expr)) - (match expr - ((% %primitive op args res cont) - (make-primitive op args res (hoist cont))) - ((% %branch atom true false) - (make-branch atom (hoist true) (hoist false))) - ((% %apply . _) expr) - ((% %tail) expr) - ((% %fix funs body) - (set! functions (append (map hoist funs) functions)) - (hoist body)) - ((% %closure name args body) - (make-closure name args (hoist body))) - (_ (error "Unexpected form in hoist" expr))))) - (make-fix functions body)) - - - (define (free-vars-expr expr bound-vars) - (define (free? ref) - (and (lexical-ref? ref) - (not (guard (e ((key-not-found-error? e) #f)) - (lookup bound-vars ref))))) - (match expr - ((% %primitive _ args res continuation) - (loop for r in res - if (lexical-ref? r) - do (set! bound-vars (insert bound-vars r #t))) - (loop with m = (free-vars-expr continuation bound-vars) - for arg in args - if (free? arg) - do (set! m (insert m arg #t)) - finally (return m))) - ((% %branch atom true false) - (define m (merge (free-vars-expr true bound-vars) (free-vars-expr false bound-vars))) - (if (free? atom) - (set! m (insert m atom #t))) - m) - ((% %apply proc args) - (define m (make-ref-map)) - (if (free? proc) - (set! m (insert m proc #t))) - (loop for arg in args - if (free? arg) - do (set! m (insert m arg #t)) - finally (return m))) - ((% %tail) - (make-ref-map)) - ((% %fix funs body) - (loop for fun in funs - for name = (closure-name fun) - if (lexical-ref? name) - do (set! bound-vars (insert bound-vars name #t))) - (define m (free-vars-expr body bound-vars)) - (loop for fun in funs - do (set! m (merge m (free-vars-closure fun bound-vars))) - finally (return m))) - (_ (error "Unexpected form in free-vars-expr" expr)))) - - - (define (free-vars-closure fun bound-vars) - (define name (closure-name fun)) - (when (lexical-ref? name) - (set! bound-vars (insert bound-vars name #t))) - (loop for arg in (closure-arguments fun) - do (set! bound-vars (insert bound-vars arg #t))) - (free-vars-expr (closure-body fun) bound-vars)) - - - ; Returns a list of the free variables in a closure. - (define (free-vars expr) - (define m (free-vars-closure expr (make-ref-map))) - (map car (map->alist m))) - - - (define (translate-ref ref env) - (if (lexical-ref? ref) - (guard (e ((key-not-found-error? e) (error "Undefined symbol in closure-convert" ref))) - (lookup env ref)) - ref)) - - - ; converts a CPS expression into an equivalent expression with no - ; free variables. - (define (closure-convert expr) - (hoist - (let convert ((expr expr) - (env (make-ref-map))) - (define (translate ref) - (translate-ref ref env)) - (match expr - ((% %primitive op args res continuation) - (loop for r in res - do (set! env (insert env r (make-variable (gensym))))) - (make-primitive op (map translate args) (map translate res) (convert continuation env))) - ((% %branch atom true false) - (make-branch (translate atom) (convert true env) (convert false env))) - ((% %apply proc args) - (let ((p (translate proc)) - (fn (make-variable (gensym)))) - (make-primitive 'peek (list p (make-constant 0)) (list fn) - (make-apply fn (cons p (map translate args)))))) - ((% %tail) - *tail*) - ((% %fix functions body) - (define frees (map free-vars functions)) - (define fn-ptrs (loop for fun in functions - collect (make-label (gensym)))) - (define converted-functions (loop for fun in functions - for fn-ptr in fn-ptrs - for free-list in frees - for env* = env - for name = (closure-name fun) - for closure = (make-variable (gensym)) - if (lexical-ref? name) - do (set! env* (insert env* name closure)) - do (loop for arg in (closure-arguments fun) - do (set! env* (insert env* arg (make-variable (gensym))))) - (loop for var in free-list - do (set! env* (insert env* var (make-variable (gensym))))) - collect (let ((new-body (convert (closure-body fun) env*))) - (loop for var in free-list - for i from 0 - do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) - new-body))) - (make-closure - fn-ptr - (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) - new-body)))) - (loop for fun in functions - for name = (closure-name fun) - if (lexical-ref? name) - do (set! env (insert env name (make-variable (gensym))))) - (let ((new-body (convert body env))) - ; Build the closures. - (loop for fun in functions - for free-list in frees - for ptr in fn-ptrs - for closure = (translate (closure-name fun)) - do (loop for var in free-list - for i from 1 - do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() - new-body))) - (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() - new-body))) - ; Allocate the closures. - (loop for fun in functions - for free-list in frees - for closure = (translate (closure-name fun)) - do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) - new-body))) - (make-fix converted-functions new-body))) - (_ (error "Unexpected form in closure-convert" expr)))))))) diff --git a/lib/csc/cps.scheme b/lib/csc/cps.scheme new file mode 100644 index 0000000..074b051 --- /dev/null +++ b/lib/csc/cps.scheme @@ -0,0 +1,355 @@ +(define-library (csc cps) + (export ir->cps) + (import (scheme base) + (prefix (csc gensym) gensym.) + (prefix (csc ir) ir.) + (prefix (csc list) list.) + (prefix (csc map) map.)) + (begin + + + (define-record-type + (make-update var body k) + update? + (var update-var) + (body update-body) + (k update-k)) + + + (define (returns-value? op) (not (memq op '(poke exit)))) + + + (define (to-cps expr k) + (cond + ((or (ir.const? expr) + (ir.void? expr) + (gensym.gensym? expr)) + (k expr)) + ((ir.lambda? expr) + (unless (= (length (ir.lambda-vars expr)) 1) + (error "invalid lambda form: all lambdas at this point should take one argument")) + (let ((arg (car (ir.lambda-vars expr))) + (f (gensym.gen)) + (cont (gensym.gen))) + (ir.make-letrec + (list + (cons f + (ir.make-lambda (list cont arg) + (to-cps (ir.lambda-body expr) + (lambda (ret) + (ir.make-apply cont (list ret))))))) + (k f)))) + ((ir.letrec? expr) + (ir.make-letrec + (map + (lambda (func) + (define fname (car func)) + (define args (ir.lambda-vars (cdr func))) + (define arg (if (= (length args) 1) + (car args) + (error "invalid lambda form: blah blah blah"))) + (define body (ir.lambda-body (cdr func))) + (define cont (gensym.gen)) + (cons fname + (ir.make-lambda (list cont arg) + (to-cps body + (lambda (ret) + (ir.make-apply cont (list ret))))))) + (ir.letrec-funcs expr)) + (to-cps (ir.letrec-body expr) k))) + ((ir.apply? expr) + (unless (= (length (ir.apply-args expr)) 1) + (error "invalid apply form: all function applications at this point should have one argument")) + (let ((arg (car (ir.apply-args expr))) + (return-address (gensym.gen)) + (result (gensym.gen))) + (ir.make-letrec + (list (cons return-address (ir.make-lambda (list result) (k result)))) + (to-cps (ir.apply-func expr) + (lambda (f) + (to-cps arg + (lambda (v) + (ir.make-apply f (list return-address v))))))))) + ((ir.sequence? expr) + (to-cps (ir.sequence-head expr) + (lambda (ignored) + (to-cps (ir.sequence-tail expr) k)))) + ((ir.set? expr) + (to-cps (ir.set-body expr) + (lambda (val) + ; We're compiling to an intermediate form , + ; which will get removed later by convert-boxes. + (make-update (ir.set-var expr) val (k ir.*void*))))) + ((ir.call-builtin? expr) + (let loop ((args (ir.call-builtin-args expr)) + (args* '())) + (if (null? args) + (if (returns-value? (ir.call-builtin-name expr)) + (let ((result (gensym.gen))) + (ir.make-primop (ir.call-builtin-name expr) (reverse args*) (list result) (list (k result)))) + (ir.make-primop (ir.call-builtin-name expr) (reverse args*) '() (list (k ir.*void*)))) + (to-cps (car args) + (lambda (arg) + (loop (cdr args) (cons arg args*))))))) + (else (error "invalid form in to-cps" expr)))) + + + (define (fold-ir2 f acc expr) + (cond + ((or (ir.const? expr) + (ir.void? expr) + (gensym.gensym? expr)) + acc) + ((ir.apply? expr) + (list.foldl f acc (cons (ir.apply-func expr) (ir.apply-args expr)))) + ((ir.letrec? expr) + (f + (list.foldl + (lambda (acc x) + (list.foldl f + (f (f acc (car x)) (ir.lambda-body (cdr x))) + (ir.lambda-vars (cdr x)))) + acc + (ir.letrec-funcs expr)) + (ir.letrec-body expr))) + ((ir.primop? expr) + (list.foldl f + (list.foldl f + (list.foldl f acc (ir.primop-ks expr)) + (ir.primop-vals expr)) + (ir.primop-args expr))) + (else (error "invalid form in fold-ir2" expr)))) + + + (define (cmp-gensyms x y) + (- (gensym.gensym->int x) (gensym.gensym->int y))) + + + (define *empty-gensym-map* (map.empty cmp-gensyms)) + + + (define (get-boxed expr) + (cond + ((update? expr) + (map.insert (get-boxed (update-k expr)) + (update-var expr) #t)) + (else + (fold-ir2 + (lambda (acc x) (map.union acc (get-boxed x))) + *empty-gensym-map* + expr)))) + + + (define (unbox expr boxed-vars) + (define (boxed? var) + (and (gensym.gensym? var) + (map.lookup boxed-vars var #f))) + (cond + ((update? expr) + (ir.make-primop 'poke (list (update-var expr) (ir.make-const 0) (update-body expr)) '() + (list (unbox (update-k expr) boxed-vars)))) + ((ir.apply? expr) + (let loop ((args (ir.apply-args expr)) + (args* '())) + (if (null? args) + (if (boxed? (ir.apply-func expr)) + (let ((temp (gensym.gen))) + (ir.make-primop 'peek (list (ir.apply-func expr) (ir.make-const 0)) (list temp) + (ir.make-apply temp (reverse args*)))) + (ir.make-apply (ir.apply-func expr) (reverse args*))) + (let ((arg (car args))) + (if (boxed? arg) + (let ((temp (gensym.gen))) + (ir.make-primop 'peek (list arg (ir.make-const 0)) (list temp) + (loop (cdr args) (cons temp args*)))) + (loop (cdr args) (cons arg args*))))))) + ((ir.letrec? expr) + (let loop ((funcs (ir.letrec-funcs expr)) + (funcs* '()) + (name-translations '())) + (if (null? funcs) + (list.foldl + (lambda (acc x) + (ir.make-primop 'poke (list (car x) (ir.make-const 0) (cdr x)) '() + (list acc))) + (unbox (ir.letrec-body expr) boxed-vars) + name-translations) + (let ((name (caar funcs)) + (new-func + (let loop ((args (ir.lambda-vars (cdar funcs))) + (args* '()) + (arg-mapping '())) + (if (null? args) + (ir.make-lambda (reverse args*) + (list.foldl + (lambda (acc x) + (ir.make-primop 'alloc (list (ir.make-const 1)) (list (car x)) + (list + (ir.make-primop 'poke (list (car x) (ir.make-const 0) (cdr x)) '() + (list acc))))) + (unbox (ir.lambda-body (cdar funcs)) boxed-vars) + arg-mapping)) + (let ((arg (car args))) + (if (boxed? arg) + (let ((temp (gensym.gen))) + (loop (cdr args) + (cons temp args*) + (cons (cons arg temp) arg-mapping))) + (loop (cdr args) (cons arg args*) arg-mapping))))))) + (if (boxed? name) + (let ((new-name (gensym.gen))) + (ir.make-primop 'alloc (list (ir.make-const 1)) (list name) + (list + (loop (cdr funcs) + (cons (cons new-name new-func) funcs*) + (cons (cons name new-name) name-translations))))) + (loop (cdr funcs) + (cons (cons name new-func) funcs*) + name-translations)))))) + ((ir.primop? expr) + (let loop ((args (ir.primop-args expr)) + (args* '())) + (if (null? args) + (ir.make-primop (ir.primop-name expr) (reverse args*) (ir.primop-vals expr) + (map (lambda (x) (unbox x boxed-vars)) (ir.primop-ks expr))) + (if (boxed? (car args)) + (let ((temp (gensym.gen))) + (ir.make-primop 'peek (list (car args) (ir.make-const 0)) (list temp) + (list (loop (cdr args) (cons temp args*))))) + (loop (cdr args) (cons (car args) args*)))))) + ((or (ir.const? expr) + (ir.void? expr)) + expr))) + + + (define (convert-boxes expr) + (unbox expr (get-boxed expr))) + + + (define (free-vars expr bound-vars) + (cond + ((gensym.gensym? expr) + (if (map.lookup bound-vars expr #f) + *empty-gensym-map* + (map.singleton cmp-gensyms expr #t))) + ((ir.letrec? expr) + (map.union + (list.foldl + (lambda (acc x) + (map.union acc + (free-vars-fun x bound-vars))) + *empty-gensym-map* + (ir.letrec-funcs expr)) + (free-vars (ir.letrec-body expr) bound-vars))) + (else + (fold-ir2 + (lambda (acc x) + (map.union acc (free-vars x bound-vars))) + *empty-gensym-map* + expr)))) + + + (define (free-vars-fun fixfun bound-vars) + (define name (car fixfun)) + (define fun (cdr fixfun)) + (define bound-vars* + (list.foldl + (lambda (acc x) + (map.insert acc x #t)) + (map.singleton cmp-gensyms name #t) + (ir.lambda-vars fun))) + (free-vars (ir.lambda-body fun) bound-vars*)) + + + (define (convert-closures expr env) + (define (translate var) + (map.lookup env var var)) + (cond + ((ir.apply? expr) + (let ((p (translate (ir.apply-func expr))) + (temp (gensym.gen))) + (ir.make-primop 'peek (list p (ir.make-const 0)) (list temp) + (list + (ir.make-apply temp + (cons p (map translate (ir.apply-args expr)))))))) + ((ir.letrec? expr) + (let* ((functions (ir.letrec-funcs expr)) + (frees (map (lambda (x) (free-vars-fun x *empty-gensym-map*)) functions)) + (fn-ptrs (map (lambda (x) (ir.make-label (gensym.gen))) functions)) + (new-funcs + (map + (lambda (fixfun free-vars new-name) + (define name (car fixfun)) + (define fun (cdr fixfun)) + (define env* + (list.foldl + (lambda (acc x) (map.insert acc x (gensym.gen))) + *empty-gensym-map* + free-vars)) + (define closure (gensym.gen)) + (cons new-name + (ir.make-lambda (map (lambda (x) (map.lookup env* x x)) (ir.lambda-vars fun)) + (let loop ((free-vars free-vars) + (i 1)) + (if (null? free-vars) + (convert-closures (ir.lambda-body fun) env*) + (ir.make-primop 'peek (list closure (ir.make-const i)) (list (map.lookup env* (car free-vars) (car free-vars))) + (list (loop (cdr free-vars) (+ 1 i))))))))) + functions frees fn-ptrs)) + (new-body + (list.foldr + (lambda (func new-name free-vars acc) + (define closure (car func)) + (ir.make-primop 'alloc (list (ir.make-const (+ 1 (length free-vars)))) (list closure) + (list + (ir.make-primop 'poke (list closure (ir.make-const 0) new-name) '() + (list + (let loop ((free-vars free-vars) + (i 1)) + (if (null? free-vars) + acc + (ir.make-primop 'poke (list closure (ir.make-const i) (car free-vars)) '() + (list (loop (cdr free-vars) (+ i 1))))))))))) + (convert-closures (ir.letrec-body expr) env) + functions fn-ptrs frees))) + (ir.make-letrec new-funcs new-body))) + ((ir.primop? expr) + (ir.make-primop (ir.primop-name expr) + (map translate (ir.primop-args expr)) + (ir.primop-vals expr) + (map (lambda (x) (convert-closures x env)) (ir.primop-ks expr)))) + ((or (ir.const? expr) + (ir.void? expr)) + expr) + (else (error "unexpected form in convert-closures")))) + + + (define (hoist expr) + (define functions '()) + (define body + (let hoist ((expr expr)) + (cond + ((ir.letrec? expr) + (set! functions (append (map hoist (ir.letrec-funcs expr)) functions)) + (hoist (ir.letrec-body expr))) + ((ir.primop? expr) + (ir.make-primop (ir.primop-name expr) (ir.primop-args expr) (ir.primop-vals expr) + (map hoist (ir.primop-ks expr)))) + ((or (ir.apply? expr) + (ir.const? expr) + (ir.void? expr)) + expr) + (else (error "unexpected form in hoist"))))) + (ir.make-letrec functions body)) + + + (define (tail x) + (ir.make-primop 'exit (list (ir.make-const 0)) '() '())) + + + (define (ir->cps expr) + (hoist + (convert-closures + (convert-boxes + (to-cps expr tail)) + *empty-gensym-map*))))) diff --git a/lib/csc/encoding-test.csc b/lib/csc/encoding-test.csc deleted file mode 100644 index 6b28d8e..0000000 --- a/lib/csc/encoding-test.csc +++ /dev/null @@ -1,121 +0,0 @@ -(define-library (csc encoding-test) - (import (scheme base) - (only (csc testing) - assert-equal - test) - (csc encoding)) - (begin - - - (test encode-mov - (assert-equal - #u8(0 1 2) - (encode '((mov (local 1) (local 2)))))) - - - (test encode-int - (assert-equal - #u8(2 1 #x15 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const 10)))))) - - - (test encode-negative-int - (assert-equal - #u8(2 1 #xed #xff #xff #xff #xff #xff #xff #xff) - (encode '((mov (local 1) (const -10)))))) - - - (test encode-true - (assert-equal - #u8(2 1 #xa 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const #t)))))) - - - (test encode-false - (assert-equal - #u8(2 1 #x2 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const #f)))))) - - - (test encode-nil - (assert-equal - #u8(2 1 #x12 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const ())))))) - - - (test encode-jmpif - (assert-equal - #u8(4 1 2) - (encode '((jmpif (local 1) (local 2)))))) - - - (test encode-jmp - (assert-equal - #u8(8 1) - (encode '((jmp (local 1)))))) - - - (test encode-alloc - (assert-equal - #u8(12 1 2) - (encode '((alloc (local 1) (local 2)))))) - - - (test encode-peek - (assert-equal - #u8(17 1 2 1 0 0 0 0 0 0 0) - (encode '((peek (local 1) (local 2) (const 0)))))) - - - (test encode-poke - (assert-equal - #u8(23 #x15 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0) - (encode '((poke (const 10) (local 1) (const 0)))))) - - - (test encode-add - (assert-equal - #u8(24 1 2 3) - (encode '((add (local 1) (local 2) (local 3)))))) - - - (test encode-sub - (assert-equal - #u8(28 1 2 3) - (encode '((sub (local 1) (local 2) (local 3)))))) - - - (test encode-mul - (assert-equal - #u8(32 1 2 3) - (encode '((mul (local 1) (local 2) (local 3)))))) - - - (test encode-div - (assert-equal - #u8(36 1 2 3) - (encode '((div (local 1) (local 2) (local 3)))))) - - - (test encode-mod - (assert-equal - #u8(40 1 2 3) - (encode '((mod (local 1) (local 2) (local 3)))))) - - - (test encode-peekbyte - (assert-equal - #u8(44 1 2 3) - (encode '((peekbyte (local 1) (local 2) (local 3)))))) - - - (test encode-pokebyte - (assert-equal - #u8(48 1 2 3) - (encode '((pokebyte (local 1) (local 2) (local 3)))))) - - - (test encode-exit - (assert-equal - #u8(#x36 #x1 0 0 0 0 0 0 0) - (encode '((exit (const 0)))))))) diff --git a/lib/csc/encoding.csc b/lib/csc/encoding.csc deleted file mode 100644 index 11c0f5f..0000000 --- a/lib/csc/encoding.csc +++ /dev/null @@ -1,208 +0,0 @@ -(define-library (csc encoding) - (export encode) - (import (scheme base) - (csc format) - (only (csc loop) - loop - return) - (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, pairs have code 2, and 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 (low-byte w n) - (write-u8 (remainder n #x100) w)) - - - (define (64->le-bytes w n) - (low-byte w n) - (low-byte w (quotient n #x100)) - (low-byte w (quotient n #x10000)) - (low-byte w (quotient n #x1000000)) - (low-byte w (quotient n #x100000000)) - (low-byte w (quotient n #x10000000000)) - (low-byte w (quotient n #x1000000000000)) - (low-byte w (quotient n #x100000000000000))) - - - ; Bitwise-negates a 63-bit unsigned integer. - (define (bitwise-not n) - (loop with n* = 0 - for i from 1 to 63 - for n = n then (quotient n 2) - for digit = 1 then (* 2 digit) - if (even? n) - do (set! n* (+ n* digit)) - finally (return n*))) - - - (define (int->le-bytes w n) - (when (or (>= n #x4000000000000000) - (< n #x-4000000000000000)) - (error "int constant too large" n)) - (when (negative? n) - (set! n (remainder - (+ 1 (bitwise-not (- n))) - #x8000000000000000))) - (64->le-bytes w (+ 1 (* 2 n)))) - - - (define (bool->le-bytes w b) - (if b - (64->le-bytes w #xa) - (64->le-bytes w #x2))) - - - (define (const->le-bytes w x) - (cond - ((integer? x) - (int->le-bytes w x)) - ((boolean? x) - (bool->le-bytes w x)) - ((null? x) - (64->le-bytes w #x12)) - (else (error "unexpected type in const->le-bytes" x)))) - - - (define (make-opcode w code arg1-const arg2-const) - (when (>= code #x40) - (error "code is more than 6 bits" code)) - (define arg1-bit (if arg1-const - 2 - 0)) - (define arg2-bit (if arg2-const - 1 - 0)) - (write-u8 (+ (* 4 code) arg1-bit arg2-bit) w)) - - - (define (arg->le-bytes w atom) - (match atom - (('const val) (const->le-bytes w val)) - (('local i) - (when (>= i #x100) - (error "local index is out of range" i)) - (write-u8 i w)) - (_ (error "unexpected form in arg->le-bytes" atom)))) - - - (define (is-const? atom) - (match atom - (('const _) #t) - (_ #f))) - - - (define (opcode-switch w opcode) - (match opcode - (('mov dest src) - (make-opcode w 0 (is-const? src) #f) - (arg->le-bytes w dest) - (arg->le-bytes w src)) - (('jmpif test dest) - (make-opcode w 1 (is-const? test) (is-const? dest)) - (arg->le-bytes w test) - (arg->le-bytes w dest)) - (('jmp dest) - (make-opcode w 2 (is-const? dest) #f) - (arg->le-bytes w dest)) - (('alloc dest size) - (make-opcode w 3 (is-const? size) #f) - (arg->le-bytes w dest) - (arg->le-bytes w size)) - (('peek dest ptr offset) - (make-opcode w 4 (is-const? ptr) (is-const? offset)) ; ptr will likely never be constant. - (arg->le-bytes w dest) - (arg->le-bytes w ptr) - (arg->le-bytes w offset)) - (('poke word ('local ptr) offset) - ; We only have 2 bits to store whether the arguments are const, but - ; it's actually true that a pointer can never be a constant. So we - ; only track whether the word and offset arguments are constant, and - ; assume ptr will always be a one-byte register name. - (make-opcode w 5 (is-const? word) (is-const? offset)) - (arg->le-bytes w word) - (arg->le-bytes w (list 'local ptr)) - (arg->le-bytes w offset)) - (('add dest x y) - (make-opcode w 6 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('sub dest x y) - (make-opcode w 7 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('mul dest x y) - (make-opcode w 8 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('div dest x y) - (make-opcode w 9 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('mod dest x y) - (make-opcode w 10 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('peekbyte dest ptr offset) - (make-opcode w 11 (is-const? ptr) (is-const? offset)) - (arg->le-bytes w dest) - (arg->le-bytes w ptr) - (arg->le-bytes w offset)) - (('pokebyte word ('local ptr) offset) - (make-opcode w 12 (is-const? word) (is-const? offset)) - (arg->le-bytes w word) - (arg->le-bytes w (list 'local ptr)) - (arg->le-bytes w offset)) - (('exit code) - (make-opcode w 13 (is-const? code) #f) - (arg->le-bytes w code)) - (('alloc-bytevector dest size) - (make-opcode w 14 (is-const? size) #f) - (arg->le-bytes w dest) - (arg->le-bytes w size)) - (('typeof dest x) - (make-opcode w 15 (is-const? x) #f) - (arg->le-bytes w dest) - (arg->le-bytes w x)) - (('lt dest x y) - (make-opcode w 16 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('eq dest x y) - (make-opcode w 17 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('cons dest x y) - (make-opcode w 18 (is-const? x) (is-const? y)) - (arg->le-bytes w dest) - (arg->le-bytes w x) - (arg->le-bytes w y)) - (('len dest l) - (make-opcode w 19 (is-const? l) #f) - (arg->le-bytes w dest) - (arg->le-bytes w l)) - (('assert-singleton dest l) - (make-opcode w 20 (is-const? l) #f) - (arg->le-bytes w dest) - (arg->le-bytes w l)) - (_ (error "invalid opcode" opcode)))) - - - (define (encode program) - (define out (open-output-bytevector)) - (map (lambda (op) (opcode-switch out op)) program) - (get-output-bytevector out)))) diff --git a/lib/csc/encoding.scheme b/lib/csc/encoding.scheme new file mode 100644 index 0000000..dfe6fb7 --- /dev/null +++ b/lib/csc/encoding.scheme @@ -0,0 +1,246 @@ +(define-library (csc encoding) + (export encode translate-labels) + (import (scheme base) + (prefix (csc list) list.) + (prefix (csc map) map.)) + (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, pairs have code 2, and 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-syntax mlength + (syntax-rules () + ((mlength ()) 0) + ((mlength (_ l ...)) (+ 1 (mlength (l ...)))))) + + + (define-syntax match-clause + (syntax-rules () + ((match-clause op n ((code arg1 arg2 ...) body ...) clause* ...) + (if (and (= n (mlength (code arg1 arg2 ...))) + (symbol=? (car op) code)) + (let-values (((arg1 arg2 ...) (apply values (cdr op)))) + body ...) + (match-clause op n clause* ...))) + ((match-clause _ _ (else body ...)) + (begin body ...)))) + + + (define-syntax match + (syntax-rules () + ((match op clause* ...) + (let ((n (length op))) + (match-clause op n clause* ...))))) + + + (define (make-label-map program) + (let loop ((program program) + (i 0) + (m (map.empty -))) + (if (null? program) + m + (match (car program) + (('label id) + (loop (cdr program) + i + (map.insert m id i))) + (else (loop (cdr program) + (+ 1 i) + m)))))) + + + ; Rewrites each (label x) form into a integer constant. + (define (translate-labels program) + (define label-map (make-label-map program)) + (list.map-maybe + (lambda (opcode) + (match opcode + (('label x) #f) + (else + (let ((op (car opcode)) + (args (cdr opcode))) + (cons op + (map + (lambda (arg) + (match arg + (('label x) + (list 'const (map.lookup label-map x))) + (else arg))) + args)))))) + program)) + + + (define (low-byte w n) + (write-u8 (remainder n #x100) w)) + + + (define (64->le-bytes w n) + (low-byte w n) + (low-byte w (quotient n #x100)) + (low-byte w (quotient n #x10000)) + (low-byte w (quotient n #x1000000)) + (low-byte w (quotient n #x100000000)) + (low-byte w (quotient n #x10000000000)) + (low-byte w (quotient n #x1000000000000)) + (low-byte w (quotient n #x100000000000000))) + + + (define (int->le-bytes w n) + (when (or (>= n #x4000000000000000) + (< n #x-4000000000000000)) + (error "int constant too large" n)) + (when (negative? n) + (set! n (- #x10000000000000000 n))) + (64->le-bytes w (+ 1 (* 2 n)))) + + + (define (bool->le-bytes w b) + (if b + (64->le-bytes w #xa) + (64->le-bytes w #x2))) + + + (define (const->le-bytes w x) + (cond + ((integer? x) + (int->le-bytes w x)) + ((boolean? x) + (bool->le-bytes w x)) + ((null? x) + (64->le-bytes w #x12)) + (else (error "unexpected type in const->le-bytes" x)))) + + + (define (make-opcode w code arg1-const arg2-const) + (when (>= code #x40) + (error "code is more than 6 bits" code)) + (define arg1-bit (if arg1-const + 2 + 0)) + (define arg2-bit (if arg2-const + 1 + 0)) + (write-u8 (+ (* 4 code) arg1-bit arg2-bit) w)) + + + (define (arg->le-bytes w atom) + (match atom + (('const val) (const->le-bytes w val)) + (('local i) + (when (>= i #x100) + (error "local index is out of range" i)) + (write-u8 i w)) + (else (error "unexpected form in arg->le-bytes" atom)))) + + + (define (is-const? atom) + (match atom + (('const x) #t) + (else #f))) + + + (define (opcode-switch w opcode) + (match opcode + (('mov dest src) + (make-opcode w 0 (is-const? src) #f) + (arg->le-bytes w dest) + (arg->le-bytes w src)) + (('jmpif test dest) + (make-opcode w 1 (is-const? test) (is-const? dest)) + (arg->le-bytes w test) + (arg->le-bytes w dest)) + (('jmp dest) + (make-opcode w 2 (is-const? dest) #f) + (arg->le-bytes w dest)) + (('alloc dest size) + (make-opcode w 3 (is-const? size) #f) + (arg->le-bytes w dest) + (arg->le-bytes w size)) + (('peek dest ptr offset) + (make-opcode w 4 (is-const? ptr) (is-const? offset)) ; ptr will likely never be constant. + (arg->le-bytes w dest) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('poke word ptr offset) + ; We only have 2 bits to store whether the arguments are const, but + ; it's actually true that a pointer can never be a constant. So we + ; only track whether the word and offset arguments are constant, and + ; assume ptr will always be a one-byte register name. + (make-opcode w 5 (is-const? word) (is-const? offset)) + (arg->le-bytes w word) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('add dest x y) + (make-opcode w 6 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('sub dest x y) + (make-opcode w 7 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('mul dest x y) + (make-opcode w 8 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('div dest x y) + (make-opcode w 9 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('mod dest x y) + (make-opcode w 10 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('peekbyte dest ptr offset) + (make-opcode w 11 (is-const? ptr) (is-const? offset)) + (arg->le-bytes w dest) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('pokebyte word ptr offset) + (make-opcode w 12 (is-const? word) (is-const? offset)) + (arg->le-bytes w word) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('exit code) + (make-opcode w 13 (is-const? code) #f) + (arg->le-bytes w code)) + (('alloc-bytevector dest size) + (make-opcode w 14 (is-const? size) #f) + (arg->le-bytes w dest) + (arg->le-bytes w size)) + (('typeof dest x) + (make-opcode w 15 (is-const? x) #f) + (arg->le-bytes w dest) + (arg->le-bytes w x)) + (('lt dest x y) + (make-opcode w 16 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('eq dest x y) + (make-opcode w 17 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('cons dest x y) + (make-opcode w 18 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (else (error "invalid opcode" opcode)))) + + + (define (encode program) + (define out (open-output-bytevector)) + (map (lambda (op) (opcode-switch out op)) (translate-labels program)) + (get-output-bytevector out)))) diff --git a/lib/csc/flag.csc b/lib/csc/flag.csc deleted file mode 100644 index c26fa90..0000000 --- a/lib/csc/flag.csc +++ /dev/null @@ -1,120 +0,0 @@ -(define-library (csc flag) - (export - *args* - bool-flag - define-bool-flag - define-flag - parse-error-flag - parse-error-msg - parse-error? - parse-flags) - (import (scheme base) - (only (scheme process-context) - command-line) - (only (csc hash-map) - compare-strings - insert - key-not-found-error? - lookup - make-map) - (only (csc loop) - loop) - (only (csc match) - match) - (only (csc strings) - contains? - has-prefix? - split)) - (begin - - - (define (bool-flag s) - (cond - ((member s '("1" "t" "T" "true" "TRUE" "True")) - #t) - ((member s '("0" "f" "F" "false" "FALSE" "False")) - #f) - (else (error "Argument could not be parsed as a boolean" s)))) - - - (define *parsers* (make-map compare-strings)) - - - (define (add-parser flag bool? setter) - (set! *parsers* (insert *parsers* flag - (make-flag bool? setter)))) - - - (define-record-type - (make-flag bool? setter) - flag? - (bool? flag-bool?) - (setter flag-setter)) - - - (define-syntax define-flag - (syntax-rules () - ((define-flag name flag type default) - (begin - (define name default) - (add-parser flag (eq? type bool-flag) - (lambda (x) (set! name (type x)))))))) - - - (define *args* '()) - - - (define-record-type - (make-parse-error msg flag) - parse-error? - (msg parse-error-msg) - (flag parse-error-flag)) - - - (define (parse-flags) - (define args (cdr (command-line))) - ; Is this legal? - (define (parse-one) - (match args - ('() #f) - ((s . _) when (or (not (has-prefix? s "-")) - (string=? "-" s)) - #f) - ((s . rest) when (string=? "--" s) - (set! args rest) - #f) - ((s . rest) - (define name (if (has-prefix? s "--") - (string-copy s 2) - (string-copy s 1))) - (when (or (string=? "" name) - (has-prefix? name "-") - (has-prefix? name "=")) - (raise (make-parse-error "bad flag syntax" s))) - ; It's a flag. Does it have an argument? - (set! args rest) - (define value (match (split name "=" 2) - ((a b) - (set! name a) - b) - (_ #f))) - (define flag (guard (e ((key-not-found-error? e) - (raise (make-parse-error "flag provided but not defined" s)))) - (lookup *parsers* name))) - (if (flag-bool? flag) ; Special case: doesn't need an arg. - (if value - ((flag-setter flag) value) - ((flag-setter flag) "true")) - (begin - ; It must have a value, which might be the next argument. - (when (and (not value) - (not (null? args))) - ; value is the next arg - (set! value (car args)) - (set! args (cdr args))) - (unless value - (raise (make-parse-error "flag needs an argument" s))) - ((flag-setter flag) value))) - #t))) - (loop while (parse-one)) - (set! *args* args)))) diff --git a/lib/csc/format-test.csc b/lib/csc/format-test.csc deleted file mode 100644 index 1906af6..0000000 --- a/lib/csc/format-test.csc +++ /dev/null @@ -1,26 +0,0 @@ -(define-library (csc format-test) - (import (scheme base) - (only (csc strings) str-quote) - (only (csc testing) assert-equal test) - (csc format)) - (begin - - - (test sprintf-single-string - (assert-equal "test-string" (sprintf "test-string"))) - - - (test sprintf-list - (assert-equal "(1 2 3)" (sprintf "{}" '(1 2 3)))) - - - (test sprintf-complex - (assert-equal "this (1 2 3) is 1 a bbb test" (sprintf "this {} is {} a {} test" '(1 2 3) 1 "bbb"))) - - - (test sprintf-escape-open - (assert-equal "{" (sprintf "{{"))) - - - (test sprintf-escape-close - (assert-equal "}" (sprintf "}}"))))) diff --git a/lib/csc/format.csc b/lib/csc/format.csc deleted file mode 100644 index 6ffd736..0000000 --- a/lib/csc/format.csc +++ /dev/null @@ -1,50 +0,0 @@ -(define-library (csc format) - (export - fprintf - printf - sprintf) - (import (scheme base) - (only (scheme write) - display) - (only (csc loop) - loop) - (only (csc strings) - index - has-prefix?)) - (begin - - - (define (fprintf port format-string . args) - (loop with s = format-string - until (string=? "" s) - if (has-prefix? s "{{") - do (write-string "{" port) - (set! s (string-copy s 2)) - else if (has-prefix? s "}}") - do (write-string "}" port) - (set! s (string-copy s 2)) - else if (has-prefix? s "{}") - do (display (car args) port) - (set! args (cdr args)) - (set! s (string-copy s 2)) - else if (or (has-prefix? s "{") - (has-prefix? s "}")) - do (error "invalid format string" format-string) - else - do (let* ((open-brace-pos (index s "{")) - (close-brace-pos (index s "}")) - (format-pos (min open-brace-pos close-brace-pos))) - (when (negative? format-pos) - (set! format-pos (string-length s))) - (write-string s port 0 format-pos) - (set! s (string-copy s format-pos))))) - - - (define (printf format-string . format-args) - (apply fprintf (current-output-port) format-string format-args)) - - - (define (sprintf format-string . format-args) - (let ((string-builder (open-output-string))) - (apply fprintf string-builder format-string format-args) - (get-output-string string-builder))))) diff --git a/lib/csc/gensym.csc b/lib/csc/gensym.csc deleted file mode 100644 index 480cbc2..0000000 --- a/lib/csc/gensym.csc +++ /dev/null @@ -1,27 +0,0 @@ -(define-library (csc gensym) - (export - gensym - gensym->int - gensym=? - gensym?) - (import (scheme base)) - (begin - - - (define-record-type - (make-gensym id) - gensym? - (id gensym->int)) - - - (define (gensym=? s1 s2) - (= (gensym->int s1) (gensym->int s2))) - - - (define *next-id* 0) - - - (define (gensym) - (let ((sym (make-gensym *next-id*))) - (set! *next-id* (+ 1 *next-id*)) - sym)))) diff --git a/lib/csc/gensym.scheme b/lib/csc/gensym.scheme new file mode 100644 index 0000000..8e340e4 --- /dev/null +++ b/lib/csc/gensym.scheme @@ -0,0 +1,21 @@ +(define-library (csc gensym) + (export + gen + gensym->int + gensym?) + (import (scheme base)) + (begin + + + (define-record-type + (make-gensym id) + gensym? + (id gensym->int)) + + + (define *next-id* 0) + + + (define (gen) + (set! *next-id* (+ 1 *next-id*)) + (make-gensym *next-id*)))) diff --git a/lib/csc/hash-map-test.csc b/lib/csc/hash-map-test.csc deleted file mode 100644 index 6f83c30..0000000 --- a/lib/csc/hash-map-test.csc +++ /dev/null @@ -1,155 +0,0 @@ -(define-library (csc hash-map-test) - (import (scheme base) - (only (csc format) - sprintf) - (only (csc loop) - loop - return) - (only (csc sort) sort) - (only (csc testing) - assert-equal - assert-raises - test) - (csc hash-map)) - (begin - - - (define transform-map - (list - (cons map? map->alist) - (cons list? (lambda (l) (sort (lambda (x y) (stringstring (car x)) (symbol->string (car y)))) l))))) - - - (test alist->map-singleton - (assert-equal - '((a . 1)) - (alist->map compare-symbols '((a . 1))) - transform-map)) - - - (test alist->map-two - (assert-equal - '((a . 1) (b . 2)) - (alist->map compare-symbols '((a . 1) (b . 2))) - transform-map)) - - - (test alist->map-longer - (assert-equal - '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)) - (alist->map compare-symbols '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) - transform-map)) - - - (test alist->map-larger - (assert-equal - '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8)) - (alist->map compare-symbols '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))) - transform-map)) - - - (test alist->map-in-order - (assert-equal - '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())) - (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - transform-map)) - - - (test alist->map-reversed - (assert-equal - '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())) - (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - transform-map)) - - - (test alist->map-overwrite - (assert-equal - '((a . 2)) - (alist->map compare-symbols '((a . 1) (a . 2))) - transform-map)) - - - (test alist->map-alternating - (assert-equal - '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())) - (alist->map compare-symbols '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ()))) - transform-map)) - - - (define (test-map . bindings) - (alist->map compare-symbols bindings)) - - - (test lookup - (assert-equal - 2 - (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'b))) - - - (test lookup-notfound - (assert-raises key-not-found-error? - (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'd))) - - - (test lookup-default - (assert-equal - #f - (lookup (test-map '(a . #t) '(b . #t)) 'c #f))) - - - (test merge - (assert-equal - '((a . 1) (b . 2) (c . 3) (d . 4)) - (merge - (test-map '(a . 1) '(b . 2)) - (test-map '(c . 3) '(d . 4))) - transform-map)) - - - (test delete - (assert-equal - '((a . 1) (b . 2) (d . 4)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'c) - transform-map)) - - - (test delete-only - (assert-equal - '() - (delete - (test-map '(a . 1)) - 'a) - transform-map)) - - - (test delete-first - (assert-equal - '((b . 2) (c . 3) (d . 4)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'a) - transform-map)) - - - (test delete-last - (assert-equal - '((a . 1) (b . 2) (c . 3)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'd) - transform-map)) - - - (test delete-many - (assert-equal - '() - (loop with m = (loop with m = (test-map) - for i from 1 to 100 - do (set! m (insert m (string->symbol (sprintf "key{}" i)) i)) - finally (return m)) - for i from 1 to 100 - do (set! m (delete m (string->symbol (sprintf "key{}" i)))) - finally (return m)) - transform-map)))) diff --git a/lib/csc/hash-map.csc b/lib/csc/hash-map.csc deleted file mode 100644 index 682fa30..0000000 --- a/lib/csc/hash-map.csc +++ /dev/null @@ -1,492 +0,0 @@ -(define-library (csc hash-map) - (export - alist->map - compare-numbers - compare-strings - compare-symbols - delete - hash-bytevector - insert - key-not-found-error? - lookup - make-comparer - make-map - map->alist - map-for-each - map? - merge) - (import (scheme base) - (only (csc loop) - loop - return) - (only (csc match) - define-match-record-type - match) - (only (scheme case-lambda) - case-lambda)) - (begin - - - (define-record-type - (make-key-hash k hash) - key-hash? - (k key-hash-value) - (hash key-hash-hash)) - - - (define (cmp-key-hash k1 k2 cmp) - (define d (- (key-hash-hash k2) (key-hash-hash k1))) - (if (zero? d) - (cmp (key-hash-value k1) (key-hash-value k2)) - d)) - - - (define-match-record-type - (make-node color key-hash val left right) - node? - %node - (color node-color) - (key-hash node-key) - (val node-value) - (left node-left) - (right node-right)) - - - (define (red? n) - (and (not (null? n)) - (eq? 'red (node-color n)))) - - - (define (black? n) - (or (null? n) - (eq? 'black (node-color n)))) - - - (define (node-kv n) - (cons (node-key n) (node-value n))) - - - (define (node-colored color kv left right) - (make-node color (car kv) (cdr kv) left right)) - - - (define (red-node kv left right) - (node-colored 'red kv left right)) - - (define (black-node kv left right) - (node-colored 'black kv left right)) - - - (define (rebalance-left m) - (define p (node-left m)) - (define u (node-right m)) - (cond - ((or (and (red? p) - (red? (node-left p)) - (red? u)) - (and (red? p) - (red? (node-right p)) - (red? u))) - ; b r - ; / \ / \ - ; r r => b b - ; / / - ; r r - - ; b r - ; / \ / \ - ; r r => b b - ; \ \ - ; r r - (red-node (node-kv m) - (black-node (node-kv p) (node-left p) (node-right p)) - (black-node (node-kv u) (node-left u) (node-right u)))) - ((and (red? p) - (red? (node-right p)) - (black? u)) - ; b b - ; / \ / \ - ; r b => r r - ; \ \ - ; r b - (let ((n (node-right p))) - (make-node 'black (node-key n) (node-value n) - (make-node 'red (node-key p) (node-value p) (node-left p) (node-left n)) - (make-node 'red (node-key m) (node-value m) (node-right n) u)))) - ((and (red? p) - (red? (node-left p)) - (black? u)) - ; b b - ; / \ / \ - ; r b => r r - ; / \ - ; r b - (make-node 'black (node-key p) (node-value p) - (node-left p) - (make-node 'red (node-key m) (node-value m) (node-right p) u))) - (else m))) - - - (define (rebalance-right m) - (define u (node-left m)) - (define p (node-right m)) - (cond - ((or (and (red? u) - (red? p) - (red? (node-left p))) - (and (red? u) - (red? p) - (red? (node-right p)))) - ; b r - ; / \ / \ - ; r r => b b - ; \ \ - ; r r - - ; b r - ; / \ / \ - ; r r => b b - ; / / - ; r r - (make-node 'red (node-key m) (node-value m) - (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)) - (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)))) - ((and (black? u) - (red? p) - (red? (node-left p))) - ; b b - ; / \ / \ - ; b r => r r - ; / / - ; r b - (let ((n (node-left p))) - (make-node 'black (node-key n) (node-value n) - (make-node 'red (node-key m) (node-value m) u (node-left n)) - (make-node 'red (node-key p) (node-value p) (node-right n) (node-right p))))) - ((and (black? u) - (red? p) - (red? (node-right p))) - ; b b - ; / \ / \ - ; b r => r r - ; \ / - ; r b - (make-node 'black (node-key p) (node-value p) - (make-node 'red (node-key m) (node-value m) u (node-left p)) - (node-right p))) - (else m))) - - - (define (insert-node n k v cmp) - (match n - ('() (make-node 'red k v '() '())) - ((% %node color node-key node-val left right) - (define ord (cmp-key-hash k node-key cmp)) - (cond - ((negative? ord) - (rebalance-left - (make-node color node-key node-val - (insert-node left k v cmp) - right))) - ((zero? ord) - (make-node color k v left right)) - (else - (rebalance-right - (make-node color node-key node-val - left - (insert-node right k v cmp)))))))) - - - (define-record-type - (construct-map hash cmp root) - map? - (hash map-raw-hash) - (cmp map-cmp) - (root map-root)) - - - (define-record-type - (make-comparer hash cmp) - comparer? - (hash comparer-hash) - (cmp comparer-cmp)) - - - (define (make-map comparer) - (construct-map (comparer-hash comparer) (comparer-cmp comparer) '())) - - - (define (shuffle n) - (remainder - (* #x9e3779b97f4a7c55 n) - #x10000000000000000)) - - - (define (map-hash m) - (lambda (k) - (shuffle ((map-raw-hash m) k)))) - - - (define (insert m k v) - (define res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m))) - (construct-map - (map-raw-hash m) - (map-cmp m) - (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))) - - - (define-record-type - (make-key-not-found-error) - key-not-found-error?) - - - (define *key-not-found-error* (make-key-not-found-error)) - - - (define lookup - (case-lambda - ((m k) - (define cmp (map-cmp m)) - (define k* (make-key-hash k ((map-hash m) k))) - (let loop ((n (map-root m))) - (match n - ('() (raise *key-not-found-error*)) - ((% %node _ node-key node-val left right) - (define ord (cmp-key-hash k* node-key cmp)) - (cond - ((negative? ord) - (loop left)) - ((zero? ord) - node-val) - (else - (loop right))))))) - ((m k def) - (guard (e ((key-not-found-error? e) def)) - (lookup m k))))) - - - (define (map-for-each f m) - (let loop ((n (map-root m))) - (match n - ((% %node _ node-key node-val left right) - (loop left) - (f (key-hash-value node-key) node-val) - (loop right))))) - - - (define (map->alist m) - (let ((alist '())) - (map-for-each - (lambda (k v) - (set! alist (cons (cons k v) alist))) - m) - alist)) - - - (define (alist->map comparer alist) - (loop with m = (make-map comparer) - for elem in alist - do (set! m (insert m (car elem) (cdr elem))) - finally (return m))) - - - (define (hash-bytevector b) - (loop for i from 0 below (bytevector-length b) - with hash = 0 - do (set! hash (remainder - (+ (* hash #x100) (bytevector-u8-ref b i)) - #x10000000000000000)) - finally (return hash))) - - - (define compare-symbols - (make-comparer - (lambda (s) (hash-bytevector (string->utf8 (symbol->string s)))) - (lambda (s1 s2) - (cond - ((symbol=? s1 s2) 0) - ((stringstring s1) (symbol->string s2)) -1) - (else 1))))) - - - (define compare-numbers - (make-comparer - (lambda (x) x) - (lambda (y x) (- y x)))) - - - (define compare-strings - (make-comparer - (lambda (s) (hash-bytevector (string->utf8 s))) - (lambda (s1 s2) - (cond - ((string=? s1 s2) 0) - ((stringstring s1) (symbol->string s2)) -1) - (else 1))))) - - - (define (merge2 m1 m2) - (let ((m1 m1)) - (map-for-each - (lambda (k v) - (set! m1 (insert m1 k v))) - m2) - m1)) - - - (define (merge m . m*) - (let loop ((m* m*) - (m m)) - (match m* - ('() m) - ((head . tail) (loop tail (merge2 m head)))))) - - - ; Jinkies! - (define (delete m k) - (define cmp (map-cmp m)) - (define k* (make-key-hash k ((map-hash m) k))) - ; local variables - (define need-fix #f) - (define replacement-node #f) - - (define (fix-black-height-left p) - ; n.b.: s must not be nil, because we deleted a black node and so - ; there must be at least one node in s to balance out the - ; black height. - (define s (node-right p)) - (define n (node-left p)) - (define c (node-left s)) - (define d (node-right s)) - (set! need-fix #f) - (cond - ((red? s) - ; p s - ; / \ / \ - ; n s => p d - ; / \ / \ - ; c d n c - (black-node (node-kv s) - (fix-black-height-left - (red-node (node-kv p) n c)) - d)) - ((red? d) - (node-colored (node-color p) (node-kv s) - (black-node (node-kv p) n c) - (black-node (node-kv d) (node-left d) (node-right d)))) - ((red? c) - (fix-black-height-left - (node-colored (node-color p) (node-kv p) - n - (black-node (node-kv c) - (node-left c) - (red-node (node-kv s) - (node-right c) - d))))) - ((red? p) - (black-node (node-kv p) - n - (red-node (node-kv s) c d))) - (else - (set! need-fix #t) ; This is the only recursive case. - (black-node (node-kv p) - n - (red-node (node-kv s) c d))))) - (define (fix-black-height-right p) - (define s (node-left p)) - (define n (node-right p)) - (define c (node-right s)) - (define d (node-left s)) - (set! need-fix #f) - (cond - ((red? s) - (black-node (node-kv s) - d - (fix-black-height-right - (red-node (node-kv p) c n)))) - ((red? d) - (node-colored (node-color p) (node-kv s) - (black-node (node-kv d) (node-left d) (node-right d)) - (black-node (node-kv p) c n))) - ((red? c) - ; p p - ; / \ / \ - ; s n => c n - ; / \ / - ; d c s - ; / - ; d - (fix-black-height-right - (node-colored (node-color p) (node-kv p) - (black-node (node-kv c) - (red-node (node-kv s) - d - (node-left c)) - (node-right c)) - n))) - ((red? p) - (black-node (node-kv p) - (red-node (node-kv s) d c) - n)) - (else - (set! need-fix #t) - (black-node (node-kv p) - (red-node (node-kv s) d c) - n)))) - (construct-map (map-raw-hash m) cmp - (let loop ((n (map-root m))) - (match n - ('() '()) - ((% %node color nk nv left right) - (define ord (cmp-key-hash k* nk cmp)) - (cond - ((negative? ord) - (let* ((left* (loop left)) - (n* (make-node color nk nv left* right))) - (if need-fix - (fix-black-height-left n*) - n*))) - ((positive? ord) - (let* ((right* (loop right)) - (n* (make-node color nk nv left right*))) - (if need-fix - (fix-black-height-right n*) - n*))) - ((and (not (null? left)) - (not (null? right))) - (let* ((left* (let find-max ((r left)) - (match r - ((% %node _ _ _ r-left '()) - (set! replacement-node r) - (cond - ((red? r) '()) - ((null? r-left) - (set! need-fix #t) - '()) - (else - (black-node (node-kv r-left) - (node-left r-left) - (node-right r-left))))) - ((% %node r-color r-k r-v r-left r-right) - (define n* (make-node r-color r-k r-v - r-left - (find-max r-right))) - (if need-fix - (fix-black-height-right n*) - n*))))) - (n* (node-colored color (node-kv replacement-node) left* right))) - (if need-fix - (fix-black-height-left n*) - n*))) - ((red? n) '()) - ((and (null? left) - (null? right)) - (set! need-fix #t) - '()) - (else - (let ((child (if (null? left) - right - left))) - (black-node (node-kv child) - (node-left child) - (node-right child)))))))))))) diff --git a/lib/csc/ir.scheme b/lib/csc/ir.scheme new file mode 100644 index 0000000..94c1d32 --- /dev/null +++ b/lib/csc/ir.scheme @@ -0,0 +1,131 @@ +(define-library (csc ir) + (export + *void* + apply-args + apply-func + apply? + call-builtin-args + call-builtin-name + call-builtin? + const-val + const? + label-var + label? + lambda-body + lambda-vars + lambda? + letrec-body + letrec-funcs + letrec? + libvar-lib + libvar-var + libvar? + make-apply + make-call-builtin + make-const + make-label + make-lambda + make-letrec + make-libvar + make-primop + make-sequence + make-set + primop-args + primop-ks + primop-name + primop-vals + primop? + sequence-head + sequence-tail + sequence? + set-body + set-var + set? + void?) + (import (scheme base)) + (begin + + + (define-record-type + (make-libvar library var) + libvar? + (library libvar-lib) + (var libvar-var)) + + + ;; ---------- IR1 + + (define-record-type + (make-lambda vars body) + lambda? + (vars lambda-vars) + (body lambda-body)) + + + (define-record-type + (make-letrec funcs body) + letrec? + (funcs letrec-funcs) + (body letrec-body)) + + + (define-record-type + (make-apply func args) + apply? + (func apply-func) + (args apply-args)) + + + (define-record-type + (make-sequence head tail) + sequence? + (head sequence-head) + (tail sequence-tail)) + + + (define-record-type + (make-set var body) + set? + (var set-var) + (body set-body)) + + + (define-record-type + (make-call-builtin name args) + call-builtin? + (name call-builtin-name) + (args call-builtin-args)) + + + (define-record-type + (make-const val) + const? + (val const-val)) + + + (define-record-type + (make-void) + void?) + + + (define *void* (make-void)) + + + ;; ------------- CPS + + ; , , , and are also IR2 forms. + + + (define-record-type