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, 0 insertions, 208 deletions

diff --git a/lib/csc/encoding.csc b/lib/csc/encoding.csc
deleted file mode 100644
index 11c0f5f..0000000
--- a/lib/csc/encoding.csc
+++ /dev/null
@@ -1,208 +0,0 @@
-(define-library (csc encoding)
-  (export encode)
-  (import (scheme base)
-          (csc format)
-          (only (csc loop)
-            loop
-            return)
-          (only (csc match) match))
-  (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 (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)))
-
-
-    ; Bitwise-negates a 63-bit unsigned integer.
-    (define (bitwise-not n)
-      (loop with n* = 0
-            for i from 1 to 63
-            for n = n then (quotient n 2)
-            for digit = 1 then (* 2 digit)
-            if (even? n)
-              do (set! n* (+ n* digit))
-            finally (return n*)))
-
-
-    (define (int->le-bytes w n)
-      (when (or (>= n #x4000000000000000)
-                (< n #x-4000000000000000))
-        (error "int constant too large" n))
-      (when (negative? n)
-        (set! n (remainder
-                  (+ 1 (bitwise-not (- n)))
-                  #x8000000000000000)))
-      (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))
-        (_ (error "unexpected form in arg->le-bytes" atom))))
-
-
-    (define (is-const? atom)
-      (match atom
-        (('const _) #t)
-        (_ #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 ('local 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 (list 'local 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 ('local ptr) offset)
-          (make-opcode w 12 (is-const? word) (is-const? offset))
-          (arg->le-bytes w word)
-          (arg->le-bytes w (list 'local 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))
-        (('len dest l)
-          (make-opcode w 19 (is-const? l) #f)
-          (arg->le-bytes w dest)
-          (arg->le-bytes w l))
-        (('assert-singleton dest l)
-          (make-opcode w 20 (is-const? l) #f)
-          (arg->le-bytes w dest)
-          (arg->le-bytes w l))
-        (_ (error "invalid opcode" opcode))))
-
-
-    (define (encode program)
-      (define out (open-output-bytevector))
-      (map (lambda (op) (opcode-switch out op)) program)
-      (get-output-bytevector out))))