summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-10-20 20:06:40 +0200
committerAndy Wingo <wingo@pobox.com>2015-10-21 11:49:20 +0200
commit0da0308b8479aab335230675c94e0773985f06d6 (patch)
tree6f593368f7db3462b933554a17e6d926d8e6b2cd /module
parent72353de77d0a06f158d8af66a2540015658e2574 (diff)
downloadguile-0da0308b8479aab335230675c94e0773985f06d6.tar.gz
Prepare for SP-addressed locals
* libguile/vm-engine.c: Renumber opcodes, and take the opportunity to fold recent additions into more logical places. Be more precise when describing the encoding of operands, to shuffle local references only and not constants, immediates, or other such values. (SP_REF, SP_SET): New helpers. (BR_BINARY, BR_ARITHMETIC): Take full 24-bit operands. Our shuffle strategy is to emit push when needed to bring far locals near, then pop afterwards, shuffling away far destination values as needed; but that doesn't work for conditionals, unless we introduce a trampoline. Let's just do the simple thing for now. Native compilation will use condition codes. (push, pop, drop): Back from the dead! We'll only use these for temporary shuffling though, when an opcode can't address the full 24-bit range. (long-fmov): New instruction, like long-mov but relative to the frame pointer. (load-typed-array, make-array): Don't use a compressed encoding so that we can avoid the shuffling case. It would be a pain, given that they have so many operands already. * module/language/bytecode.scm (compute-instruction-arity): Update for new instrution word encodings. * module/system/vm/assembler.scm: Update to expose some opcodes directly, without the need for shuffling wrappers. Adapt to instruction word encodings change. * module/system/vm/disassembler.scm (disassembler): Adapt to instruction coding change.
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* ...)