From dd48a415840db45c03c3b625820f29fdf915214d Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 25 Jul 2022 16:59:48 -0700 Subject: Write unit tests for codegen. --- csc/codegen.csc | 127 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 73 insertions(+), 54 deletions(-) (limited to 'csc/codegen.csc') diff --git a/csc/codegen.csc b/csc/codegen.csc index aab8e23..f97beec 100644 --- a/csc/codegen.csc +++ b/csc/codegen.csc @@ -5,6 +5,7 @@ (only (csc format) sprintf) (only (csc gensym) + gensym gensym->int) (only (csc hash-map) compare-numbers @@ -39,6 +40,7 @@ library-ref? make-apply make-constant + make-label make-primitive variable-gensym variable?) @@ -49,26 +51,6 @@ (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) @@ -76,9 +58,10 @@ ((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) + ((or (integer? x) + (boolean? x)) (list 'const x)) - (else (error "Only integer constants are supported for now")))) + (else (error "Only small ints and bool constants are supported for now")))) ((% %library-ref x lib) (list 'global x lib)) ((% %variable sym) @@ -87,7 +70,7 @@ ; The globals array is stored in register 0. (list 'local 0)) ((% %label sym) - (list 'label (translate-label atom))) + (list 'label (translate-local atom))) (_ (error "Unexpected form in atom->bytecode" atom)))) @@ -121,6 +104,16 @@ #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) @@ -128,21 +121,28 @@ 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)))) + 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 (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result))) - and do (set! results (delete out->in 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 (list 'mov (list 'local (lookup in->out currently-in-temp)) (list 'local 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-satisfying results (lambda (x) #t)))) + 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 (lookup out->in any-result))))) - and do (set! results (delete out->in any-result)))) + (list 'mov (list 'local any-result) (list 'local in)))))) (define (hash-symbol s) @@ -165,46 +165,57 @@ (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)) + (define temp (translate-local (make-label (gensym)))) (append (list - (list 'jmpif (a->b atom) temp1)) + (list 'jmpif (a->b atom) (list 'label temp))) (ir2->bytecode false translate-local) (list - (list 'jmp (list 'label temp2)) - (list 'label temp1)) - (ir2->bytecode true translate-local) - (list - (list 'label temp2)))) + (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) - do (set! in->out (insert in->out (translate-local arg) i)) + 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-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))) - (append (chains in->out) - constants - (list - (if (label? proc) - (list 'jmp (list 'label (translate-label proc))) - (list 'jmp (a->b proc)))))) + (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)))))) (_ (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))) @@ -213,6 +224,14 @@ ; Converts an IR2 program into bytecode. (define (ir2->ir3 expr) + (define label-map (make-map compare-labels)) + (define next-label-id 0) + (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 @@ -220,14 +239,14 @@ 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)))) + (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) -- cgit v1.3.1