summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/language/bytecode.scm42
-rw-r--r--module/system/vm/assembler.scm135
-rw-r--r--module/system/vm/disassembler.scm68
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* ...)