diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/codegen-test.csc | 38 | ||||
| -rw-r--r-- | csc/codegen.csc | 234 | ||||
| -rw-r--r-- | csc/cps-test.csc | 12 | ||||
| -rw-r--r-- | csc/cps.csc | 8 | ||||
| -rw-r--r-- | csc/ir2.csc | 35 |
5 files changed, 300 insertions, 27 deletions
diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc new file mode 100644 index 0000000..9c47661 --- /dev/null +++ b/csc/codegen-test.csc @@ -0,0 +1,38 @@ +(import (scheme base) + (only (csc gensym) + gensym) + (only (csc ir2) + *globals* + make-apply + make-constant + make-fix + make-primitive + make-variable) + (only (csc match) + match) + (only (csc testing) + assert-equal) + (csc codegen)) + + +(define transform-bytecode + (list + (cons (lambda (expr) + (match expr + (('label _) #t) + (_ #f))) + (lambda (expr) 'label)))) + + +(define (test-var) + (make-variable (gensym))) + + +(test codegen-apply + (assert-equal + 'something + (ir2->ir3 + (make-fix '() + (make-primitive 'peek (list *globals* (make-constant 5)) (list (test-var)) + (make-apply (test-var) (list (make-constant 10)))))) + transform-bytecode)) diff --git a/csc/codegen.csc b/csc/codegen.csc new file mode 100644 index 0000000..c51420e --- /dev/null +++ b/csc/codegen.csc @@ -0,0 +1,234 @@ +(define-library (csc codegen) + (export + ir2->ir3) + (import (scheme base) + (only (csc format) + sprintf) + (only (csc 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 + %variable + closure-arguments + closure-body + closure-name + constant? + fix-body + fix-functions + globals? + label-gensym + label? + library-ref-library + library-ref-name + library-ref? + make-apply + make-constant + make-primitive + variable-gensym + variable?) + (only (csc loop) + loop) + (only (csc match) + match)) + (begin + + + (define *next-label-id* 0) + + + (define (new-label) + (define id *next-label-id*) + (set! *next-label-id* (+ 1 *next-label-id*)) + id) + + + (define *label-map* (make-map (make-comparer + (lambda (x) (gensym->int (label-gensym x))) + (lambda (x y) (- (gensym->int (label-gensym y)) (gensym->int (label-gensym x))))))) + + + (define (translate-label x) + (define new-id (new-label)) + (set! *label-map* (insert *label-map* x new-id)) + new-id) + + + (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")) + ((integer? x) + (list 'const x)) + (else (error "Only integer 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-label atom))) + (_ (error "Unexpected form in atom->bytecode" atom)))) + + + (define-record-type <not-empty> + (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 (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 + for easy-result = (get-satisfying results (lambda (x) (not (lookup in->out x #f)))) + until (empty? results) + if easy-result + collect (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result))) + and do (set! results (delete out->in easy-result)) + else if currently-in-temp + collect (list 'mov (list 'local (lookup in->out currently-in-temp)) (list 'local currently-in-temp)) + and do (set! currently-in-temp #f) + else + append (let ((any-result (get-satisfying results (lambda (x) #t)))) + (set! currently-in-temp any-result) + (list + (list 'mov (list 'local *temp-reg*) (list 'local any-result)) + (list 'mov (list 'local any-result) (list 'local (lookup out->in any-result))))) + and do (set! results (delete out->in any-result)))) + + + (define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + + (define (cmp-symbols s1 s2) + (cond + ((symbol=? s1 s2) 0) + ((string<? (symbol->string 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 temp1 (new-label)) + (define temp2 (new-label)) + (append + (list + (list 'jmpif (a->b atom) temp1)) + (ir2->bytecode false translate-local) + (list + (list 'jmp (list 'label temp2)) + (list 'label temp1)) + (ir2->bytecode true translate-local) + (list + (list 'label temp2)))) + ((% %apply proc args) + (define in->out (make-map compare-numbers)) + (define constants + (loop for arg in args + for i from 1 + if (variable? arg) + do (set! in->out (insert in->out (translate-local arg) i)) + 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 arg)) + else if (label? arg) + collect (list 'mov (list 'local i) (list 'label (translate-label 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))) + (append (chains in->out) + constants + (list + (if (label? proc) + (list 'jmp (list 'label (translate-label proc))) + (list 'jmp (a->b proc)))))) + (_ (error "Unexpected form in ir2->bytecode expr")))) + + + (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 (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) + (define res (lookup locals-map x #f)) + (if res + res + (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)))))))) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 5283c2b..98823f0 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -26,6 +26,7 @@ %closure %fix %globals + %label %primitive %variable *globals* @@ -34,15 +35,13 @@ closure? fix? globals? + label? make-apply - make-atom make-branch make-call-closure make-closure make-fix - make-kargs - make-klabel - make-ktail + make-label make-primitive make-variable primitive? @@ -60,6 +59,7 @@ (cons library-ref? %library-ref) (cons variable? %variable) (cons globals? %globals) + (cons label? %label) (cons primitive? %primitive) (cons branch? %branch) (cons apply? %apply) @@ -478,13 +478,13 @@ (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) (make-fix (list - (make-closure (test-var) (list (test-var) (test-var) (test-var)) + (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 2)) (list (test-var)) - (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() + (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))))))))) diff --git a/csc/cps.csc b/csc/cps.csc index 81ba933..9e1721c 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -62,14 +62,12 @@ closure-body closure-name make-apply - make-atom make-branch make-call-closure make-closure make-fix - make-kargs - make-klabel - make-ktail + make-label + make-label make-primitive make-variable) (only (csc loop) @@ -526,7 +524,7 @@ ((% %fix functions body) (define frees (map free-vars functions)) (define fn-ptrs (loop for fun in functions - collect (make-variable (gensym)))) + collect (make-label (gensym)))) (define converted-functions (loop for fun in functions for fn-ptr in fn-ptrs for free-list in frees diff --git a/csc/ir2.csc b/csc/ir2.csc index 30fb5a3..642b86c 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -5,15 +5,13 @@ %closure %fix %globals + %label %primitive %variable *globals* apply-arguments apply-procedure apply? - atom-continuation - atom-expression - atom? branch-atom branch-false branch-true @@ -30,21 +28,14 @@ fix-functions fix? globals? - kargs-expression - kargs-refs - kargs? - klabel-expression - klabel? - ktail? + label-gensym + label? make-apply - make-atom make-branch make-call-closure make-closure make-fix - make-kargs - make-klabel - make-ktail + make-label make-primitive make-variable primitive-arguments @@ -56,23 +47,27 @@ 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 - lexical-set-expression - lexical-set-ref - lexical-set? make-lexical-set make-library-ref) (import (scheme base) (only (csc ir1) + %constant + %library-ref constant? lexical-ref-gensym lexical-ref-name @@ -130,6 +125,14 @@ (define *globals* (make-globals)) + ; A label, used for function names and will compile to a constant. + (define-match-record-type <label> + (make-label gensym) + label? + %label + (gensym label-gensym)) + + ; CPS expressions: ; CPS expressions are similar to IR1 expressions, ; but constrained not to have any subexpressions except atoms. |