From 745d6b8e16c7f276f479c18d97200e44d16aafc9 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sun, 24 Jul 2022 19:08:49 -0700
Subject: Start codegen.

---
 csc/codegen-test.csc |  38 +++++++++
 csc/codegen.csc      | 234 +++++++++++++++++++++++++++++++++++++++++++++++++++
 csc/cps-test.csc     |  12 +--
 csc/cps.csc          |   8 +-
 csc/ir2.csc          |  35 ++++----
 5 files changed, 300 insertions(+), 27 deletions(-)
 create mode 100644 csc/codegen-test.csc
 create mode 100644 csc/codegen.csc

(limited to 'csc')

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.
-- 
cgit v1.3.1