diff options
| -rw-r--r-- | csc/encoding-test.csc | 118 | ||||
| -rw-r--r-- | csc/encoding.csc | 184 |
2 files changed, 209 insertions, 93 deletions
diff --git a/csc/encoding-test.csc b/csc/encoding-test.csc index a7f4ace..fb9fe21 100644 --- a/csc/encoding-test.csc +++ b/csc/encoding-test.csc @@ -1,117 +1,119 @@ (import (scheme base) - (only (csc testing) test assert-equal) + (only (csc testing) + assert-equal + test) (csc encoding)) -(test encode-const +(test encode-mov (assert-equal - '(#xf2 #x3 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) - (encode '((const -10))))) + #u8(0 1 2) + (encode '((mov (local 1) (local 2)))))) -(test encode-add +(test encode-int (assert-equal - '(#xfc #x3 0 0 0 0 0 0) - (encode '(add)))) + #u8(2 1 #x15 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const 10)))))) -(test encode-sub +(test encode-negative-int (assert-equal - '(#x6 #x4 0 0 0 0 0 0) - (encode '(sub)))) + #u8(2 1 #xed #xff #xff #xff #xff #xff #xff #xff) + (encode '((mov (local 1) (const -10)))))) -(test encode-mul +(test encode-true (assert-equal - '(#x10 #x4 0 0 0 0 0 0) - (encode '(mul)))) + #u8(2 1 #xa 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const #t)))))) -(test encode-div +(test encode-false (assert-equal - '(#x1a #x4 0 0 0 0 0 0) - (encode '(div)))) + #u8(2 1 #x2 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const #f)))))) -(test encode-mod +(test encode-nil (assert-equal - '(#x24 #x4 0 0 0 0 0 0) - (encode '(mod)))) + #u8(2 1 #x12 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const ())))))) -(test encode-alloc +(test encode-jmpif (assert-equal - '(#xda #x7 0 0 0 0 0 0) - (encode '(alloc)))) + #u8(4 1 2) + (encode '((jmpif (local 1) (local 2)))))) -(test encode-peek +(test encode-jmp (assert-equal - '(#xe4 #x7 0 0 0 0 0 0 #xa) - (encode '((peek 10))))) + #u8(8 1) + (encode '((jmp (local 1)))))) -(test encode-poke +(test encode-alloc (assert-equal - '(#xee #x7 0 0 0 0 0 0 #xa) - (encode '((poke 10))))) + #u8(12 1 2) + (encode '((alloc (local 1) (local 2)))))) -(test encode-peekbyte +(test encode-peek (assert-equal - '(#xf8 #x7 0 0 0 0 0 0) - (encode '(peekbyte)))) + #u8(17 1 2 1 0 0 0 0 0 0 0) + (encode '((peek (local 1) (local 2) (const 0)))))) -(test encode-pokebyte +(test encode-poke (assert-equal - '(#x2 #x8 0 0 0 0 0 0) - (encode '(pokebyte)))) + #u8(23 #x15 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0) + (encode '((poke (const 10) (local 1) (const 0)))))) -(test encode-pop +(test encode-add (assert-equal - '(#xc2 #xb 0 0 0 0 0 0) - (encode '(pop)))) + #u8(24 1 2 3) + (encode '((add (local 1) (local 2) (local 3)))))) -(test encode-local +(test encode-sub (assert-equal - '(#xcc #xb 0 0 0 0 0 0 #xa) - (encode '((local 10))))) + #u8(28 1 2 3) + (encode '((sub (local 1) (local 2) (local 3)))))) -(test encode-if +(test encode-mul (assert-equal - '(#xaa #xf 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) - (encode '((if -10))))) + #u8(32 1 2 3) + (encode '((mul (local 1) (local 2) (local 3)))))) -(test encode-call +(test encode-div (assert-equal - '(#xb4 #xf 0 0 0 0 0 0 #xa) - (encode '((call 10))))) + #u8(36 1 2 3) + (encode '((div (local 1) (local 2) (local 3)))))) -(test encode-ret +(test encode-mod (assert-equal - '(#xbe #xf 0 0 0 0 0 0) - (encode '(ret)))) + #u8(40 1 2 3) + (encode '((mod (local 1) (local 2) (local 3)))))) -(test encode-exit +(test encode-peekbyte (assert-equal - '(#xc8 #xf 0 0 0 0 0 0) - (encode '(exit)))) + #u8(44 1 2 3) + (encode '((peekbyte (local 1) (local 2) (local 3)))))) -(test encode-putc +(test encode-pokebyte (assert-equal - '(#x92 #x13 0 0 0 0 0 0) - (encode '(putc)))) + #u8(48 1 2 3) + (encode '((pokebyte (local 1) (local 2) (local 3)))))) -(test encode-getc +(test encode-exit (assert-equal - '(#x9c #x13 0 0 0 0 0 0) - (encode '(getc)))) + #u8(52) + (encode '((exit))))) 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)))) |