diff options
Diffstat (limited to 'lib/csc/encoding.scheme')
| -rw-r--r-- | lib/csc/encoding.scheme | 246 |
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)))) |