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-test.csc | 116 ++++++++++++++++++++++++++++++++++++++-------- csc/codegen.csc | 127 +++++++++++++++++++++++++++++---------------------- 2 files changed, 169 insertions(+), 74 deletions(-) (limited to 'csc') diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc index b85ebc3..01eda04 100644 --- a/csc/codegen-test.csc +++ b/csc/codegen-test.csc @@ -4,8 +4,12 @@ (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) @@ -19,31 +23,103 @@ (csc codegen)) -(define transform-bytecode - (list - (cons (lambda (expr) - (match expr - (('label _) #t) - (_ #f))) - (lambda (expr) 'label)) - (cons (lambda (expr) - (match expr - (('local _) #t) - (_ #f))) - (lambda (expr) 'local)))) - - (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))) + (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))) + (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 0)) + (jmp (label 0)) + (label 0) + (mov (local 2) (local 1)) + (jmp (local 2))) + (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 0)) + (label 0) + (mov (local 127) (local 1)) + (mov (local 1) (local 2)) + (mov (local 2) (local 127)) + (mov (local 3) (const 0)) + (jmp (label 1)) + (label 1) + (mov (local 2) (local 1)) + (mov (local 1) (local 3)) + (jmp (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 #f) (local #f) (const 5)) - (mov (local #f) (const 10)) - (jmp (local #f))) + '((peek (local 1) (local 0) (const 1)) + (jmpif (const #t) (label 0)) + (mov (local 2) (local 1)) + (mov (local 1) (const 10)) + (jmp (local 2)) + (label 0) + (mov (local 2) (local 1)) + (mov (local 1) (const 5)) + (jmp (local 2))) (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)) + (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/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