diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/language/bytecode.scm | 42 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 135 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 68 |
3 files changed, 140 insertions, 105 deletions
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index 2ef98675a..089bf9e7e 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -34,34 +34,40 @@ (define (compute-instruction-arity name args) (define (first-word-arity word) (case word - ((U8_X24) 0) - ((U8_U24) 1) - ((U8_L24) 1) - ((U8_U8_I16) 2) - ((U8_U12_U12) 2) - ((U8_U8_U8_U8) 3))) + ((X32) 0) + ((X8_S24) 1) + ((X8_F24) 1) + ((X8_C24) 1) + ((X8_L24) 1) + ((X8_S8_I16) 2) + ((X8_S12_S12) 2) + ((X8_S12_C12) 2) + ((X8_C12_C12) 2) + ((X8_F12_F12) 2) + ((X8_S8_S8_S8) 3) + ((X8_S8_S8_C8) 3) + ((X8_S8_C8_S8) 3))) (define (tail-word-arity word) (case word - ((U8_U24) 2) - ((U8_L24) 2) - ((U8_U8_I16) 3) - ((U8_U12_U12) 3) - ((U8_U8_U8_U8) 4) - ((U32) 1) + ((C32) 1) ((I32) 1) ((A32) 1) ((B32) 0) ((N32) 1) - ((S32) 1) + ((R32) 1) ((L32) 1) ((LO32) 1) - ((X8_U24) 1) - ((X8_U12_U12) 2) - ((X8_L24) 1) + ((C8_C24) 2) + ((B1_C7_L24) 3) + ((B1_X7_S24) 2) + ((B1_X7_F24) 2) + ((B1_X7_C24) 2) ((B1_X7_L24) 2) - ((B1_U7_L24) 3) ((B1_X31) 1) - ((B1_X7_U24) 2))) + ((X8_S24) 1) + ((X8_F24) 1) + ((X8_C24) 1) + ((X8_L24) 1))) (match args ((arg0 . args) (fold (lambda (arg arity) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 6bc2bcf84..f29105108 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -89,13 +89,13 @@ emit-br-if-struct emit-br-if-char emit-br-if-tc7 - (emit-br-if-eq* . emit-br-if-eq) - (emit-br-if-eqv* . emit-br-if-eqv) - (emit-br-if-equal* . emit-br-if-equal) - (emit-br-if-=* . emit-br-if-=) - (emit-br-if-<* . emit-br-if-<) - (emit-br-if-<=* . emit-br-if-<=) - (emit-br-if-logtest* . emit-br-if-logtest) + emit-br-if-eq + emit-br-if-eqv + emit-br-if-equal + emit-br-if-= + emit-br-if-< + emit-br-if-<= + emit-br-if-logtest (emit-mov* . emit-mov) (emit-box* . emit-box) (emit-box-ref* . emit-box-ref) @@ -153,7 +153,7 @@ (emit-struct-ref* . emit-struct-ref) (emit-struct-set!* . emit-struct-set!) (emit-class-of* . emit-class-of) - (emit-make-array* . emit-make-array) + emit-make-array (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-u16-ref* . emit-bv-u16-ref) @@ -510,29 +510,38 @@ later by the linker." (with-syntax ((opcode opcode)) (op-case asm type - ((U8_X24) + ((X32) (emit asm opcode)) - ((U8_U24 arg) + ((X8_S24 arg) (emit asm (pack-u8-u24 opcode arg))) - ((U8_L24 label) + ((X8_F24 arg) + (emit asm (pack-u8-u24 opcode arg))) + ((X8_C24 arg) + (emit asm (pack-u8-u24 opcode arg))) + ((X8_L24 label) (record-label-reference asm label) (emit asm opcode)) - ((U8_U8_I16 a imm) + ((X8_S8_I16 a imm) (emit asm (pack-u8-u8-u16 opcode a (object-address imm)))) - ((U8_U12_U12 a b) + ((X8_S12_S12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_S12_C12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_C12_C12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) - ((U8_U8_U8_U8 a b c) + ((X8_F12_F12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_S8_S8_S8 a b c) + (emit asm (pack-u8-u8-u8-u8 opcode a b c))) + ((X8_S8_S8_C8 a b c) + (emit asm (pack-u8-u8-u8-u8 opcode a b c))) + ((X8_S8_C8_S8 a b c) (emit asm (pack-u8-u8-u8-u8 opcode a b c)))))) (define (pack-tail-word asm type) (op-case asm type - ((U8_U24 a b) - (emit asm (pack-u8-u24 a b))) - ((U8_L24 a label) - (record-label-reference asm label) - (emit asm a)) - ((U32 a) + ((C32 a) (emit asm a)) ((I32 imm) (let ((val (object-address imm))) @@ -548,7 +557,7 @@ later by the linker." ((N32 label) (record-far-label-reference asm label) (emit asm 0)) - ((S32 label) + ((R32 label) (record-far-label-reference asm label) (emit asm 0)) ((L32 label) @@ -558,21 +567,31 @@ later by the linker." (record-far-label-reference asm label (* offset (/ (asm-word-size asm) 4))) (emit asm 0)) - ((X8_U24 a) - (emit asm (pack-u8-u24 0 a))) - ((X8_L24 label) - (record-label-reference asm label) - (emit asm 0)) + ((C8_C24 a b) + (emit asm (pack-u8-u24 a b))) ((B1_X7_L24 a label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) - ((B1_U7_L24 a b label) + ((B1_C7_L24 a b label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) b 0))) ((B1_X31 a) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) - ((B1_X7_U24 a b) - (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))))) + ((B1_X7_S24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((B1_X7_F24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((B1_X7_C24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((X8_S24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_F24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_C24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_L24 label) + (record-label-reference asm label) + (emit asm 0)))) (syntax-case x () ((_ name opcode word0 word* ...) @@ -651,25 +670,44 @@ later by the linker." #f))) (op-case word0 - ((U8_U8_I16 ! a imm) - (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) - imm)) - ((U8_U8_I16 <- a imm) + ((X8_S8_I16 <- a imm) (values (if (< a (ash 1 8)) a 253) imm)) - ((U8_U12_U12 ! a b) + ((X8_S12_S12 ! a b) (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253)) (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((U8_U12_U12 <- a b) + ((X8_S12_S12 <- a b) (values (if (< a (ash 1 12)) a 253) (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((U8_U8_U8_U8 ! a b c) + ((X8_S12_C12 <- a b) + (values (if (< a (ash 1 12)) a 253) + b)) + + ((X8_S8_S8_S8 ! a b c) (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) - ((U8_U8_U8_U8 <- a b c) + ((X8_S8_S8_S8 <- a b c) + (values (if (< a (ash 1 8)) a 253) + (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) + + ((X8_S8_S8_C8 ! a b c) + (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) + (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + c)) + ((X8_S8_S8_C8 <- a b c) (values (if (< a (ash 1 8)) a 253) (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + c)) + + ((X8_S8_C8_S8 ! a b c) + (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) + b + (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) + ((X8_S8_C8_S8 <- a b c) + (values (if (< a (ash 1 8)) a 253) + b (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))))) (define (tail-formals type) @@ -682,22 +720,25 @@ later by the linker." ((op-case type) (error "unmatched type" type)))) (op-case type - (U8_U24 a b) - (U8_L24 a label) - (U32 a) + (C32 a) (I32 imm) (A32 imm) (B32) (N32 label) - (S32 label) + (R32 label) (L32 label) (LO32 label offset) - (X8_U24 a) - (X8_L24 label) + (C8_C24 a b) + (B1_C7_L24 a b label) + (B1_X7_S24 a b) + (B1_X7_F24 a b) + (B1_X7_C24 a b) (B1_X7_L24 a label) - (B1_U7_L24 a b label) (B1_X31 a) - (B1_X7_U24 a b))) + (X8_S24 a) + (X8_F24 a) + (X8_C24 a) + (X8_L24 label))) (define (shuffle-up dst) (define-syntax op-case @@ -711,10 +752,10 @@ later by the linker." (with-syntax ((dst dst)) (op-case word0 - ((U8_U8_I16 U8_U8_U8_U8) + ((X8_S8_I16 X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) (unless (< dst (ash 1 8)) (emit-mov* asm dst 253))) - ((U8_U12_U12) + ((X8_S12_S12 X8_S12_C12) (unless (< dst (ash 1 12)) (emit-mov* asm dst 253)))))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 08aa057a2..c1a8ce700 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -80,70 +80,58 @@ (define (parse-first-word word type) (with-syntax ((word word)) (case type - ((U8_X24) + ((X32) #'()) - ((U8_U24) + ((X8_S24 X8_F24 X8_C24) #'((ash word -8))) - ((U8_L24) + ((X8_L24) #'((unpack-s24 (ash word -8)))) - ((U8_U8_I16) + ((X8_S8_I16) #'((logand (ash word -8) #xff) (ash word -16))) - ((U8_U12_U12) + ((X8_S12_S12 + X8_S12_C12 + X8_C12_C12 + X8_F12_F12) #'((logand (ash word -8) #xfff) (ash word -20))) - ((U8_U8_U8_U8) + ((X8_S8_S8_S8 + X8_S8_S8_C8 + X8_S8_C8_S8) #'((logand (ash word -8) #xff) (logand (ash word -16) #xff) (ash word -24))) (else - (error "bad kind" type))))) + (error "bad head kind" type))))) (define (parse-tail-word word type) (with-syntax ((word word)) (case type - ((U8_X24) - #'((logand word #ff))) - ((U8_U24) - #'((logand word #xff) - (ash word -8))) - ((U8_L24) - #'((logand word #xff) - (unpack-s24 (ash word -8)))) - ((U32) - #'(word)) - ((I32) - #'(word)) - ((A32) + ((C32 I32 A32 B32) #'(word)) - ((B32) - #'(word)) - ((N32) - #'((unpack-s32 word))) - ((S32) - #'((unpack-s32 word))) - ((L32) - #'((unpack-s32 word))) - ((LO32) + ((N32 R32 L32 LO32) #'((unpack-s32 word))) - ((X8_U24) - #'((ash word -8))) - ((X8_L24) - #'((unpack-s24 (ash word -8)))) - ((B1_X7_L24) + ((C8_C24) + #'((logand word #xff) + (ash word -8))) + ((B1_C7_L24) #'((not (zero? (logand word #x1))) + (logand (ash word -1) #x7f) (unpack-s24 (ash word -8)))) - ((B1_U7_L24) + ((B1_X7_S24 B1_X7_F24 B1_X7_C24) + #'((not (zero? (logand word #x1))) + (ash word -8))) + ((B1_X7_L24) #'((not (zero? (logand word #x1))) - (logand (ash word -1) #x7f) (unpack-s24 (ash word -8)))) ((B1_X31) #'((not (zero? (logand word #x1))))) - ((B1_X7_U24) - #'((not (zero? (logand word #x1))) - (ash word -8))) + ((X8_S24 X8_F24 X8_C24) + #'((ash word -8))) + ((X8_L24) + #'((unpack-s24 (ash word -8)))) (else - (error "bad kind" type))))) + (error "bad tail kind" type))))) (syntax-case x () ((_ name opcode word0 word* ...) |