aboutsummaryrefslogtreecommitdiffstats
path: root/csc/codegen.csc
diff options
context:
space:
mode:
Diffstat (limited to 'csc/codegen.csc')
-rw-r--r--csc/codegen.csc127
1 files changed, 73 insertions, 54 deletions
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)
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 13:52:10 +0000