From 63a7c0103c47e3735f7d21e9666124924be9e18e Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Mon, 25 Jul 2022 20:54:54 -0700
Subject: Re-write the encoding library.

I greatly improved the library, and changed it to expect register
bytecode instead of stack-based.
---
 csc/encoding.csc | 184 ++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 149 insertions(+), 35 deletions(-)

(limited to 'csc/encoding.csc')

diff --git a/csc/encoding.csc b/csc/encoding.csc
index 8dbd89c..7da5370 100644
--- a/csc/encoding.csc
+++ b/csc/encoding.csc
@@ -1,6 +1,9 @@
 (define-library (csc encoding)
   (export encode)
   (import (scheme base)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match) match))
   (begin
     ; I'm only going to say this once, so pay attention.
@@ -13,49 +16,160 @@
     ; the remaining slots hold the array values.
 
 
-    (define (right-shift n1 n2)
-      (floor-quotient n1 (expt 2 n2)))  ; Yikes.
+    (define (low-byte w n)
+      (write-u8 (remainder n #x100) w))
 
 
-    (define (low-byte n)
-      (modulo n #x100))
+    (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 (64->le-bytes n)
-      (list
-        (low-byte n)
-        (low-byte (right-shift n 8))
-        (low-byte (right-shift n 16))
-        (low-byte (right-shift n 24))
-        (low-byte (right-shift n 32))
-        (low-byte (right-shift n 40))
-        (low-byte (right-shift n 48))
-        (low-byte (right-shift n 56))))
+    ; 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 (opcode-switch opcode)
+    (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
-        (('const n) (append (64->le-bytes 1010) (64->le-bytes n)))
-        ('add (64->le-bytes 1020))
-        ('sub (64->le-bytes 1030))
-        ('mul (64->le-bytes 1040))
-        ('div (64->le-bytes 1050))
-        ('mod (64->le-bytes 1060))
-        ('alloc (64->le-bytes 2010))
-        (('peek n) (append (64->le-bytes 2020) (list n)))
-        (('poke n) (append (64->le-bytes 2030) (list n)))
-        ('peekbyte (64->le-bytes 2040))
-        ('pokebyte (64->le-bytes 2050))
-        ('pop (64->le-bytes 3010))
-        (('local n) (append (64->le-bytes 3020) (list n)))
-        (('if n) (append (64->le-bytes 4010) (64->le-bytes n)))
-        (('call n) (append (64->le-bytes 4020) (list n)))
-        ('ret (64->le-bytes 4030))
-        ('exit (64->le-bytes 4040))
-        ('putc (64->le-bytes 5010))
-        ('getc (64->le-bytes 5020))
+        (('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)
+          (make-opcode w 13 #f #f))
         (_ (error "invalid opcode" opcode))))
 
 
     (define (encode program)
-      (apply append (map opcode-switch program)))))
+      (define out (open-output-bytevector))
+      (map (lambda (op) (opcode-switch out op)) program)
+      (get-output-bytevector out))))
-- 
cgit v1.3.1