Rewrite most of the compiler.

This represents a major step back in terms of functionality, and amount
of code. The latter I think constitutes a major win. Next steps are to
reimplement syntax-rules, call/cc, and call-with-values.

1 files changed, 246 insertions, 0 deletions

diff --git a/lib/csc/encoding.scheme b/lib/csc/encoding.scheme
new file mode 100644
index 0000000..dfe6fb7
--- /dev/null
+++ b/lib/csc/encoding.scheme
@@ -0,0 +1,246 @@
+(define-library (csc encoding)
+  (export encode translate-labels)
+  (import (scheme base)
+          (prefix (csc list) list.)
+          (prefix (csc map) map.))
+  (begin
+    ; I'm only going to say this once, so pay attention.
+    ; The format of unboxed constants is described in bytecocde/src/data.rs.
+    ; Boxed values are represented by a pointer to an array on the heap. The
+    ; first position in the array is an integer code indicating what type the
+    ; object is. Vectors have code 0, pairs have code 2, and codes for other
+    ; types are not stable. Vectors are represented as an array, the first
+    ; element of which is the integer 0 (the type code), the second element is
+    ; the vector length, and the remaining slots hold the array values.
+
+
+    (define-syntax mlength
+      (syntax-rules ()
+        ((mlength ()) 0)
+        ((mlength (_ l ...)) (+ 1 (mlength (l ...))))))
+
+
+    (define-syntax match-clause
+      (syntax-rules ()
+        ((match-clause op n ((code arg1 arg2 ...) body ...) clause* ...)
+          (if (and (= n (mlength (code arg1 arg2 ...)))
+                   (symbol=? (car op) code))
+            (let-values (((arg1 arg2 ...) (apply values (cdr op))))
+              body ...)
+            (match-clause op n clause* ...)))
+        ((match-clause _ _ (else body ...))
+          (begin body ...))))
+
+
+    (define-syntax match
+      (syntax-rules ()
+        ((match op clause* ...)
+          (let ((n (length op)))
+            (match-clause op n clause* ...)))))
+
+
+    (define (make-label-map program)
+      (let loop ((program program)
+                 (i 0)
+                 (m (map.empty -)))
+        (if (null? program)
+          m
+          (match (car program)
+            (('label id)
+              (loop (cdr program)
+                    i
+                    (map.insert m id i)))
+            (else (loop (cdr program)
+                        (+ 1 i)
+                        m))))))
+
+
+    ; Rewrites each (label x) form into a integer constant.
+    (define (translate-labels program)
+      (define label-map (make-label-map program))
+      (list.map-maybe
+        (lambda (opcode)
+          (match opcode
+            (('label x) #f)
+            (else
+              (let ((op (car opcode))
+                    (args (cdr opcode)))
+                (cons op
+                  (map
+                    (lambda (arg)
+                      (match arg
+                        (('label x)
+                          (list 'const (map.lookup label-map x)))
+                        (else arg)))
+                    args))))))
+        program))
+
+
+    (define (low-byte w n)
+      (write-u8 (remainder n #x100) w))
+
+
+    (define (64->le-bytes w n)
+      (low-byte w n)
+      (low-byte w (quotient n #x100))
+      (low-byte w (quotient n #x10000))
+      (low-byte w (quotient n #x1000000))
+      (low-byte w (quotient n #x100000000))
+      (low-byte w (quotient n #x10000000000))
+      (low-byte w (quotient n #x1000000000000))
+      (low-byte w (quotient n #x100000000000000)))
+
+
+    (define (int->le-bytes w n)
+      (when (or (>= n #x4000000000000000)
+                (< n #x-4000000000000000))
+        (error "int constant too large" n))
+      (when (negative? n)
+        (set! n (- #x10000000000000000 n)))
+      (64->le-bytes w (+ 1 (* 2 n))))
+
+
+    (define (bool->le-bytes w b)
+      (if b
+        (64->le-bytes w #xa)
+        (64->le-bytes w #x2)))
+
+
+    (define (const->le-bytes w x)
+      (cond
+        ((integer? x)
+          (int->le-bytes w x))
+        ((boolean? x)
+          (bool->le-bytes w x))
+        ((null? x)
+          (64->le-bytes w #x12))
+        (else (error "unexpected type in const->le-bytes" x))))
+
+
+    (define (make-opcode w code arg1-const arg2-const)
+      (when (>= code #x40)
+        (error "code is more than 6 bits" code))
+      (define arg1-bit (if arg1-const
+                         2
+                         0))
+      (define arg2-bit (if arg2-const
+                         1
+                         0))
+      (write-u8 (+ (* 4 code) arg1-bit arg2-bit) w))
+
+
+    (define (arg->le-bytes w atom)
+      (match atom 
+        (('const val) (const->le-bytes w val))
+        (('local i)
+          (when (>= i #x100)
+            (error "local index is out of range" i))
+          (write-u8 i w))
+        (else (error "unexpected form in arg->le-bytes" atom))))
+
+
+    (define (is-const? atom)
+      (match atom
+        (('const x) #t)
+        (else #f)))
+
+
+    (define (opcode-switch w opcode)
+      (match opcode
+        (('mov dest src)
+          (make-opcode w 0 (is-const? src) #f)
+          (arg->le-bytes w dest)
+          (arg->le-bytes w src))
+        (('jmpif test dest)
+          (make-opcode w 1 (is-const? test) (is-const? dest))
+          (arg->le-bytes w test)
+          (arg->le-bytes w dest))
+        (('jmp dest)
+          (make-opcode w 2 (is-const? dest) #f)
+          (arg->le-bytes w dest))
+        (('alloc dest size)
+          (make-opcode w 3 (is-const? size) #f)
+          (arg->le-bytes w dest)
+          (arg->le-bytes w size))
+        (('peek dest ptr offset)
+          (make-opcode w 4 (is-const? ptr) (is-const? offset))  ; ptr will likely never be constant.
+          (arg->le-bytes w dest)
+          (arg->le-bytes w ptr)
+          (arg->le-bytes w offset))
+        (('poke word ptr offset)
+          ; We only have 2 bits to store whether the arguments are const, but
+          ; it's actually true that a pointer can never be a constant. So we
+          ; only track whether the word and offset arguments are constant, and
+          ; assume ptr will always be a one-byte register name.
+          (make-opcode w 5 (is-const? word) (is-const? offset))
+          (arg->le-bytes w word)
+          (arg->le-bytes w ptr)
+          (arg->le-bytes w offset))
+        (('add dest x y)
+          (make-opcode w 6 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('sub dest x y)
+          (make-opcode w 7 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('mul dest x y)
+          (make-opcode w 8 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('div dest x y)
+          (make-opcode w 9 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('mod dest x y)
+          (make-opcode w 10 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('peekbyte dest ptr offset)
+          (make-opcode w 11 (is-const? ptr) (is-const? offset))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w ptr)
+          (arg->le-bytes w offset))
+        (('pokebyte word ptr offset)
+          (make-opcode w 12 (is-const? word) (is-const? offset))
+          (arg->le-bytes w word)
+          (arg->le-bytes w ptr)
+          (arg->le-bytes w offset))
+        (('exit code)
+          (make-opcode w 13 (is-const? code) #f)
+          (arg->le-bytes w code))
+        (('alloc-bytevector dest size)
+          (make-opcode w 14 (is-const? size) #f)
+          (arg->le-bytes w dest)
+          (arg->le-bytes w size))
+        (('typeof dest x)
+          (make-opcode w 15 (is-const? x) #f)
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x))
+        (('lt dest x y)
+          (make-opcode w 16 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('eq dest x y)
+          (make-opcode w 17 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (('cons dest x y)
+          (make-opcode w 18 (is-const? x) (is-const? y))
+          (arg->le-bytes w dest)
+          (arg->le-bytes w x)
+          (arg->le-bytes w y))
+        (else (error "invalid opcode" opcode))))
+
+
+    (define (encode program)
+      (define out (open-output-bytevector))
+      (map (lambda (op) (opcode-switch out op)) (translate-labels program))
+      (get-output-bytevector out))))