From acc561366f3fe6ec0377103f52ef0f7e923711c9 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 1 Aug 2022 19:35:19 -0700 Subject: Modify the project structure. Now the lib directory contains what will eventually end up on the user's /usr/lib/csc. When I write make install, it will copy all of the .csc files from lib into the destination lib directory. This means I can start working on the standard library in lib/scheme. --- lib/csc/assert-test.csc | 14 + lib/csc/assert.csc | 11 + lib/csc/codegen-test.csc | 132 ++++++++ lib/csc/codegen.csc | 260 +++++++++++++++ lib/csc/compare-test.csc | 98 ++++++ lib/csc/compare.csc | 248 ++++++++++++++ lib/csc/compiler.csc | 164 ++++++++++ lib/csc/config.csc | 7 + lib/csc/cps-test.csc | 499 +++++++++++++++++++++++++++++ lib/csc/cps.csc | 602 ++++++++++++++++++++++++++++++++++ lib/csc/encoding-test.csc | 121 +++++++ lib/csc/encoding.csc | 184 +++++++++++ lib/csc/flag.csc | 119 +++++++ lib/csc/format-test.csc | 26 ++ lib/csc/format.csc | 50 +++ lib/csc/gensym.csc | 27 ++ lib/csc/hash-map-test.csc | 155 +++++++++ lib/csc/hash-map.csc | 492 ++++++++++++++++++++++++++++ lib/csc/ir1.csc | 215 +++++++++++++ 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/loop-test.csc | 294 +++++++++++++++++ lib/csc/loop.csc | 419 ++++++++++++++++++++++++ lib/csc/macros-test.csc | 294 +++++++++++++++++ lib/csc/macros.csc | 801 ++++++++++++++++++++++++++++++++++++++++++++++ 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 | 103 ++++++ lib/csc/strings.csc | 64 ++++ lib/csc/testing.csc | 91 ++++++ lib/csc/vec-test.csc | 35 ++ lib/csc/vec.csc | 65 ++++ 37 files changed, 6441 insertions(+) create mode 100644 lib/csc/assert-test.csc create mode 100644 lib/csc/assert.csc create mode 100644 lib/csc/codegen-test.csc create mode 100644 lib/csc/codegen.csc create mode 100644 lib/csc/compare-test.csc create mode 100644 lib/csc/compare.csc create mode 100644 lib/csc/compiler.csc create mode 100644 lib/csc/config.csc create mode 100644 lib/csc/cps-test.csc create mode 100644 lib/csc/cps.csc create mode 100644 lib/csc/encoding-test.csc create mode 100644 lib/csc/encoding.csc create mode 100644 lib/csc/flag.csc create mode 100644 lib/csc/format-test.csc create mode 100644 lib/csc/format.csc create mode 100644 lib/csc/gensym.csc create mode 100644 lib/csc/hash-map-test.csc create mode 100644 lib/csc/hash-map.csc create mode 100644 lib/csc/ir1.csc create mode 100644 lib/csc/ir2.csc create mode 100644 lib/csc/linker-test.csc create mode 100644 lib/csc/linker.csc create mode 100644 lib/csc/list-test.csc create mode 100644 lib/csc/list.csc create mode 100644 lib/csc/loop-test.csc create mode 100644 lib/csc/loop.csc create mode 100644 lib/csc/macros-test.csc create mode 100644 lib/csc/macros.csc create mode 100644 lib/csc/match-test.csc create mode 100644 lib/csc/match.csc create mode 100644 lib/csc/sort-test.csc create mode 100644 lib/csc/sort.csc create mode 100644 lib/csc/strings-test.csc create mode 100644 lib/csc/strings.csc create mode 100644 lib/csc/testing.csc create mode 100644 lib/csc/vec-test.csc create mode 100644 lib/csc/vec.csc (limited to 'lib/csc') diff --git a/lib/csc/assert-test.csc b/lib/csc/assert-test.csc new file mode 100644 index 0000000..4e8d2d3 --- /dev/null +++ b/lib/csc/assert-test.csc @@ -0,0 +1,14 @@ +(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 new file mode 100644 index 0000000..84d2096 --- /dev/null +++ b/lib/csc/assert.csc @@ -0,0 +1,11 @@ +(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 new file mode 100644 index 0000000..29d1da5 --- /dev/null +++ b/lib/csc/codegen-test.csc @@ -0,0 +1,132 @@ +(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 127) (local 1)) + (mov (local 1) (local 2)) + (mov (local 2) (local 127)) + (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 new file mode 100644 index 0000000..ac5b313 --- /dev/null +++ b/lib/csc/codegen.csc @@ -0,0 +1,260 @@ +(define-library (csc codegen) + (export + ir2->ir3) + (import (scheme base) + (only (csc format) + sprintf) + (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)) + (list 'const x)) + (else (error "Only small ints and bool constants are supported for now")))) + ((% %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* 127) + + + (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/compare-test.csc b/lib/csc/compare-test.csc new file mode 100644 index 0000000..b710115 --- /dev/null +++ b/lib/csc/compare-test.csc @@ -0,0 +1,98 @@ +(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 new file mode 100644 index 0000000..e8e68d3 --- /dev/null +++ b/lib/csc/compare.csc @@ -0,0 +1,248 @@ +(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 new file mode 100644 index 0000000..20d5d37 --- /dev/null +++ b/lib/csc/compiler.csc @@ -0,0 +1,164 @@ +(define-library (csc compiler) + (export + *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) + (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)) + (begin + + + (define (normalize-library lib) + (match lib + (('define-library name . declarations) + (loop for decl in declarations + if (match decl (('export . _) #t) + (_ #f)) + collect (cdr decl) into exports + else if (match decl (('import . _) #t) + (_ #f)) + collect (cdr decl) into imports + else if (match decl (('begin . _) #t) + (_ #f)) + collect (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) + (ir2->ir3 (closure-convert (ir1->ir2 expr (lambda (x) *tail*))))) + + + ; 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) + (match (normalize-library lib) + (('define-library library-name + ('export . exports) + ('import . imports) + ('begin . body)) + + (define expanded-body (expand-body library-name body env)) + + (define env (make-import-map imports)) + (let loop ((expr expanded-body)) + (match expr + ((% %library-define (% %library-ref name _) val) + (set! env (insert env name val))) + ((% %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 + ('(csc builtins) + builtins-environment) + (_ (or (lookup library-symbols lib #f) + (call-with-input-file (find-library lib) + (lambda (f) + (compile-library (read f)))))))) + + (match program + ((('import . imports1) ('import . imports2) . rest) + (compile (cons (list '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/config.csc b/lib/csc/config.csc new file mode 100644 index 0000000..d2618a7 --- /dev/null +++ b/lib/csc/config.csc @@ -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 new file mode 100644 index 0000000..156ba60 --- /dev/null +++ b/lib/csc/cps-test.csc @@ -0,0 +1,499 @@ +(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) + (make-apply (test-ref 'tail) (list x))) + + + (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 (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-branch (make-constant #t) + (make-apply (test-ref 'generated-symbol) (list (make-constant 1))) + (make-apply (test-ref 'generated-symbol) (list (make-constant 2))))) + (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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20))) + tail) + transform-ir2)) + + + (test call-builtin-alloc + (assert-equal + (make-primitive 'alloc (list (make-constant 10)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 10) (test-ref '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)) + + + ; It's pretty bad + (test closure-rest + (assert-equal + (make-fix + (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'intlist '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))))) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) + (ir1->ir2 (make-lambda + '() + (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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))) + (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))) + (ir1->ir2 + (make-letrec #f '(f) (list f) + (list (make-lambda (list x) #f x)) + (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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-apply (test-ref 'tail) (list (make-constant 10)))) + (ir1->ir2 + (make-letrec #t + '(f) + (list (gensym)) + (list (make-lambda '() #f (make-constant 5))) + (make-constant 10)) + tail) + transform-ir2)) + + + ; 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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (ir1->ir2 + (make-letrec #t + '(f x) + (list f x) + (list (make-lambda '() #f (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 (test-ref 'generated-symbol) + (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'x) (make-constant 0)) '() + (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-apply (test-ref 'tail) (list (make-constant 5)))) + (ir1->ir2 (make-letrec + #f + '(f) + (list (gensym)) + (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f + (make-lexical-set (make-lexical-ref 'x 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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant #f))))))) + (ir1->ir2 (make-letrec + #f + '(f) + (list test-sym) + (list (make-lambda '() #f (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 new file mode 100644 index 0000000..f2a9c90 --- /dev/null +++ b/lib/csc/cps.csc @@ -0,0 +1,602 @@ +(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 + %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-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))) + + + ; Converts an IR1 expression to an equivalent expression where every + ; procedure takes exactly one argument. + (define (argument-conversion expr) + (match expr + (_ when (or (constant? expr) + (lexical-ref? expr) + (library-ref? expr)) + expr) + ((% %lexical-set ref arg) + (make-lexical-set ref (argument-conversion arg))) + ((% %library-define ref arg) + (make-library-define ref (argument-conversion arg))) + ((% %define-syntax _ _) expr) + ((% %if test consequent alternate) + (make-if + (argument-conversion test) + (argument-conversion consequent) + (argument-conversion alternate))) + ((% %call proc args) + (define argvec (new-ref)) + (define nargs (length args)) + (make-call + (make-lambda (list argvec) #f + (make-sequence + (loop for arg in args + for i from 2 + with expr = (make-sequence + (make-call-builtin 'poke (list (make-constant 0) argvec (make-constant 0))) + (make-call-builtin 'poke (list (make-constant nargs) argvec (make-constant 1)))) + do (set! expr (make-sequence + expr + (make-call-builtin 'poke (list (argument-conversion arg) argvec (make-constant i))))) + finally (return expr)) + (make-call (argument-conversion proc) (list argvec)))) + (list (make-call-builtin 'alloc (list (make-constant (+ 2 nargs))))))) + ((% %call-builtin op args) + (make-call-builtin op (map argument-conversion args))) + ((% %sequence head tail) + (make-sequence + (argument-conversion head) + (argument-conversion tail))) + ((% %lambda args rest body) when rest + (define argvec (new-ref)) + (define nargs (length args)) + (make-lambda (list argvec) #f + (make-if (make-call-builtin 'intlist '(csc based)) + (list argvec (make-constant nargs)))))) + ; I'm relying on beta reduction here. + do (set! expr (make-call (make-lambda (list arg) #f + expr) + (list (make-call-builtin 'peek (list argvec (make-constant i)))))) + finally (return expr))))) + ((% %lambda args _ body) + (define argvec (new-ref)) + (define nargs (length args)) + (make-lambda (list argvec) #f + (make-if (make-call-builtin 'int=? (list (make-call-builtin 'peek (list argvec (make-constant 1))) + (make-constant nargs))) + (loop for arg in (reverse args) + for i downfrom (+ 1 nargs) + with expr = (argument-conversion body) + do (set! expr (make-call (make-lambda (list arg) #f + expr) + (list + (make-call-builtin 'peek (list argvec (make-constant i)))))) + finally (return expr)) + (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec))))) + ((% %letrec in-order? names gensyms exprs body) + (make-letrec in-order? names gensyms (map argument-conversion exprs) (argument-conversion body))) + (_ (error "Unexpected form in argument-conversion" expr)))) + + + ; Update is a CPS expression that is used internally as part of + ; CPS conversion. + ; Update expressions are then removed by box-conversion. + (define-match-record-type + (make-update ref atom continuation) + update? + %update + (ref update-ref) + (atom update-atom) + (continuation update-continuation)) + + + (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) + (cons continuation args) + (to-cps + body + (lambda (z) + (make-apply continuation (list z))))))) + into functions + else + collect (make-lexical-ref name gensym) into variable-names + and collect value into variable-values + finally (return (values functions variable-names variable-values))))) + + + ; 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)) + ((% %library-ref . _) + (unless (library-ref? expr) + (error "wtf")) + (define temp (new-ref)) + (make-primitive 'peek (list *globals* expr) (list temp) + (continuation temp))) + ((% %lexical-set ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %library-define ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %define-syntax _ _) + ; no-op + (continuation (make-constant #f))) + ((% %if test consequent alternate) + (to-cps + test + (lambda (val) + (define continuation-ref (new-ref)) + (define result-ref (new-ref)) + (make-fix + (list (make-closure continuation-ref (list result-ref) + (continuation result-ref))) + (make-branch val + (to-cps + consequent + (lambda (result) + (make-apply continuation-ref (list result)))) + (to-cps + alternate + (lambda (result) + (make-apply continuation-ref (list result))))))))) + ((% %call proc (arg)) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) (continuation result))) + (to-cps + proc + (lambda (f) + (to-cps + arg + (lambda (v) + (make-apply f (list return-address v)))))))) + ((% %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))) + (make-primitive op (reverse vals) '() + (continuation (make-constant #f))))) + do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. + (arg* arg)) + (lambda (vals) + (to-cps arg* + (lambda (val) + (e* (cons val vals))))))) + finally (return (expr '())))) + ((% %sequence head tail) + (to-cps + head + (lambda (x) + (to-cps + tail + continuation)))) + ((% %lambda (arg) _ body) + (define f (new-ref)) + (define k (new-ref)) + (make-fix + (list + (make-closure f (list k arg) + (to-cps + body + (lambda (ret) + (make-apply k (list ret)))))) + (continuation 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 (lambda (x) + (make-update var x + new-body)))) + finally (return new-body)))) + (unless (null? functions) + (set! new-expr (make-fix functions new-expr))) + (loop for var in variable-names + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) + new-expr)) + finally (return new-expr))))) + (_ (error "unexpected type in to-cps" expr)))) + + + (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 + (argument-conversion 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 funs functions)) + (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/encoding-test.csc b/lib/csc/encoding-test.csc new file mode 100644 index 0000000..6b28d8e --- /dev/null +++ b/lib/csc/encoding-test.csc @@ -0,0 +1,121 @@ +(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 new file mode 100644 index 0000000..9afa40f --- /dev/null +++ b/lib/csc/encoding.csc @@ -0,0 +1,184 @@ +(define-library (csc encoding) + (export encode) + (import (scheme base) + (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, 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)) + (_ (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/flag.csc b/lib/csc/flag.csc new file mode 100644 index 0000000..c0a28a8 --- /dev/null +++ b/lib/csc/flag.csc @@ -0,0 +1,119 @@ +(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)) + ; I'm working around a Guile bug, which wrongly concludes + ; that *parsers* is immutable. + (set! *parsers* *parsers*) + + + (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) + (set! *parsers* (insert *parsers* flag + (make-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 new file mode 100644 index 0000000..1906af6 --- /dev/null +++ b/lib/csc/format-test.csc @@ -0,0 +1,26 @@ +(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 new file mode 100644 index 0000000..6ffd736 --- /dev/null +++ b/lib/csc/format.csc @@ -0,0 +1,50 @@ +(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 new file mode 100644 index 0000000..480cbc2 --- /dev/null +++ b/lib/csc/gensym.csc @@ -0,0 +1,27 @@ +(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/hash-map-test.csc b/lib/csc/hash-map-test.csc new file mode 100644 index 0000000..6f83c30 --- /dev/null +++ b/lib/csc/hash-map-test.csc @@ -0,0 +1,155 @@ +(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 new file mode 100644 index 0000000..682fa30 --- /dev/null +++ b/lib/csc/hash-map.csc @@ -0,0 +1,492 @@ +(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/ir1.csc b/lib/csc/ir1.csc new file mode 100644 index 0000000..b91e8ab --- /dev/null +++ b/lib/csc/ir1.csc @@ -0,0 +1,215 @@ +(define-library (csc ir1) + (export + %call + %call-builtin + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence + call-arguments + call-builtin-arguments + call-builtin-operation + call-builtin? + call-procedure + call? + constant-expression + constant? + define-syntax-name + define-syntax-transformer + define-syntax? + if-alternate + if-consequent + if-test + if? + lambda-arguments + lambda-body + lambda-rest + lambda? + letrec-expression + letrec-gensyms + letrec-in-order? + letrec-names + letrec-values + letrec? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-define-expression + library-define-ref + library-define? + library-ref-library + library-ref-name + 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-define + make-library-ref + make-sequence + sequence-head + sequence-tail + sequence?) + (import (scheme base) + (only (csc list) + all) + (only (csc loop) loop return) + (only (csc match) + define-match-record-type)) + (begin + ; This library defines the intermediate representation IR1. An expression + ; in IR1 has one of the following forms (plagiarized from Guile's + ; Tree-IL). + + + ; expression + ; Constant is used to include literal constants in scheme code. + (define-match-record-type + (make-constant expression) + constant? + %constant + (expression constant-expression)) + + + ; name gensym + ; A reference to a lexically-bound variable. The name is the original name + ; of the variable in the source program. gensym is a unique identifier for + ; this variable. + (define-match-record-type + (make-lexical-ref name gensym) + lexical-ref? + %lexical-ref + (name lexical-ref-name) + (gensym lexical-ref-gensym)) + + + ; name + ; A free reference to a variable in a library. If the library is 'main, + ; then it is a top-level global variable. + (define-match-record-type + (make-library-ref name library) + library-ref? + %library-ref + (name library-ref-name) + (library library-ref-library)) + + + ; name gensym expression + ; Sets a lexically-bound variable. + (define-match-record-type + (make-lexical-set ref expression) + lexical-set? + %lexical-set + (ref lexical-set-ref) + (expression lexical-set-expression)) + + + ; name expression + ; Defines a new variable in the current library. + (define-match-record-type + (make-library-define ref expression) + library-define? + %library-define + (ref library-define-ref) + (expression library-define-expression)) + + + ; name transformer + ; Defines a new macro in the current environment. name is the name of the + ; macro. transformer is a macro transformer. + (define-match-record-type + (make-define-syntax name transformer) + define-syntax? + %define-syntax + (name define-syntax-name) + (transformer define-syntax-transformer)) + + + ; test consequent alternate + ; A conditional. + (define-match-record-type + (make-if test consequent alternate) + if? + %if + (test if-test) + (consequent if-consequent) + (alternate if-alternate)) + + + ; procedure arguments + ; A procedure call. The procedure and arguments are evaluated in an + ; unspecified order, and the resulting procedure is passed the + ; resulting arguments. + (define-match-record-type + (make-call procedure arguments) + call? + %call + (procedure call-procedure) + (arguments call-arguments)) + + + ; operation arguments + ; Executes the given builtin operation on the arguments. The known builtin + ; operations are listed below. Each operation can return a value, or not. + ; - alloc: size -> result + ; - peek: pointer * offset -> result + ; - poke: word * pointer * offset -> () + ; - int bool + (define-match-record-type + (make-call-builtin operation arguments) + call-builtin? + %call-builtin + (operation call-builtin-operation) + (arguments call-builtin-arguments)) + + + ; head tail + ; Evaluate head, ignoring any result. Then tail is evaluated. + (define-match-record-type + (make-sequence head tail) + sequence? + %sequence + (head sequence-head) + (tail sequence-tail)) + + + ; body + ; A closure. Arguments is a list of lexical-refs. + ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter. + (define-match-record-type + (make-lambda arguments rest body) + lambda? + %lambda + (arguments lambda-arguments) + (rest lambda-rest) + (body lambda-body)) + + + ; in-order? names gensyms values expression + ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true. + ; names are the original binding names, gensyms are gensyms corresponding + ; to the names, and values are IR1 expressions for the values. expression + ; is a single IR1 expression. + (define-match-record-type + (make-letrec in-order? names gensyms values expression) + letrec? + %letrec + (in-order? letrec-in-order?) + (names letrec-names) + (gensyms letrec-gensyms) + (values letrec-values) + (expression letrec-expression)))) diff --git a/lib/csc/ir2.csc b/lib/csc/ir2.csc new file mode 100644 index 0000000..888437f --- /dev/null +++ b/lib/csc/ir2.csc @@ -0,0 +1,217 @@ +(define-library (csc ir2) + (export + %apply + %branch + %closure + %fix + %globals + %label + %primitive + %tail + %variable + *globals* + *tail* + apply-arguments + apply-procedure + apply? + branch-atom + branch-false + branch-true + branch? + call-closure-args + call-closure-closure + call-closure? + closure-arguments + closure-body + closure-name + closure-rest + closure? + fix-body + fix-functions + fix? + globals? + label-gensym + label? + make-apply + make-branch + make-call-closure + make-closure + make-fix + make-label + make-primitive + make-variable + primitive-arguments + primitive-continuation + primitive-operation + primitive-results + primitive? + tail? + variable-gensym + variable? + + ; Re-exports from IR1. + %constant + %library-ref + constant-expression + constant? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) + (import (scheme base) + (only (csc ir1) + %constant + %library-ref + constant-expression + constant? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) + (only (csc list) all) + (only (csc loop) + loop + return) + (only (csc match) + define-match-record-type + match)) + (begin + ; This library defines the intermediate representation IR2. + ; It's CPS time bitch. + + ; CPS atom: + ; An atom is a value that can be computed immediately without + ; any subexpressions. + ; Atoms consist of + ; - constant, + ; - lexical-ref, + ; - library-ref, + ; - or globals. + ; After closure conversion, there are no more lexical refs. + ; Each lexical ref will be converted to a . + + + ; A function argument or local variable. + (define-match-record-type + (make-variable gensym) + variable? + %variable + (gensym variable-gensym)) + + + ; The globals array. This will eventually be stored in register 0. + (define-match-record-type + (make-globals) + globals? + %globals) + + + ; A global instance of . + ; Considered equal to calling (make-globals). + (define *globals* (make-globals)) + + + ; A label, used for function names and will compile to a constant. + (define-match-record-type