aboutsummaryrefslogtreecommitdiffstats
path: root/csc/encoding.csc
diff options
context:
space:
mode:
authorRose Hogenson <rhogenson@posteo.net>2022-08-01 19:35:19 -0700
committerRose Hogenson <rhogenson@posteo.net>2022-08-01 19:35:19 -0700
commitacc561366f3fe6ec0377103f52ef0f7e923711c9 (patch)
treed7a19cfbad78a69ebea71b27302e708c0655863d /csc/encoding.csc
parent99ce19a8053a93457885f32ec54c1c5b7c1961c1 (diff)
downloadchromatopelma-acc561366f3fe6ec0377103f52ef0f7e923711c9.tar.zst
Modify the project structure.
Now the lib directory contains what will eventually end up on the user's /usr/lib/csc. When I write make install, it will copy all of the .csc files from lib into the destination lib directory. This means I can start working on the standard library in lib/scheme.
Diffstat (limited to 'csc/encoding.csc')
-rw-r--r--csc/encoding.csc184
1 files changed, 0 insertions, 184 deletions
diff --git a/csc/encoding.csc b/csc/encoding.csc
deleted file mode 100644
index 9afa40f..0000000
--- a/csc/encoding.csc
+++ /dev/null
@@ -1,184 +0,0 @@
-(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.
- ; 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, 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))
- (_ (error "invalid opcode" opcode))))
-
-
- (define (encode program)
- (define out (open-output-bytevector))
- (map (lambda (op) (opcode-switch out op)) program)
- (get-output-bytevector out))))