mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Prepare for SP-addressed locals

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2015-10-20 20:06:40 +02:00
parent 72353de77d
commit 0da0308b84
5 changed files with 494 additions and 386 deletions
Download patch file Download diff file Expand all files Collapse all files

52
libguile/instructions.c
View file

@ -31,30 +31,34 @@ SCM_SYMBOL (sym_left_arrow, "<-");
SCM_SYMBOL (sym_bang, "!"); SCM_SYMBOL (sym_bang, "!");
#define OP_HAS_ARITY (1U << 0)
#define FOR_EACH_INSTRUCTION_WORD_TYPE(M) \ #define FOR_EACH_INSTRUCTION_WORD_TYPE(M) \
M(X32) \ M(X32) \
M(U8_X24) \ M(X8_S24) \
M(U8_U24) \ M(X8_F24) \
M(U8_L24) \ M(X8_L24) \
M(U8_U8_I16) \ M(X8_C24) \
M(U8_U8_U8_U8) \ M(X8_S8_I16) \
M(U8_U12_U12) \ M(X8_S12_S12) \
M(U32) /* Unsigned. */ \ M(X8_S12_C12) \
M(X8_C12_C12) \
M(X8_F12_F12) \
M(X8_S8_S8_S8) \
M(X8_S8_C8_S8) \
M(X8_S8_S8_C8) \
M(C8_C24) \
M(C32) /* Unsigned. */ \
M(I32) /* Immediate. */ \ M(I32) /* Immediate. */ \
M(A32) /* Immediate, high bits. */ \ M(A32) /* Immediate, high bits. */ \
M(B32) /* Immediate, low bits. */ \ M(B32) /* Immediate, low bits. */ \
M(N32) /* Non-immediate. */ \ M(N32) /* Non-immediate. */ \
M(S32) /* Scheme value (indirected). */ \ M(R32) /* Scheme value (indirected). */ \
M(L32) /* Label. */ \ M(L32) /* Label. */ \
M(LO32) /* Label with offset. */ \ M(LO32) /* Label with offset. */ \
M(X8_U24) \ M(B1_C7_L24) \
M(X8_U12_U12) \
M(X8_L24) \
M(B1_X7_L24) \ M(B1_X7_L24) \
M(B1_U7_L24) \ M(B1_X7_C24) \
M(B1_X7_U24) \ M(B1_X7_S24) \
M(B1_X7_F24) \
M(B1_X31) M(B1_X31)
#define TYPE_WIDTH 5 #define TYPE_WIDTH 5
@ -73,7 +77,7 @@ static SCM word_type_symbols[] =
#undef FALSE #undef FALSE
}; };
#define OP(n,type) ((type) << (n*TYPE_WIDTH)) #define OP(n,type) (((type) + 1) << (n*TYPE_WIDTH))
/* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
arguments each instruction takes. This piece of code is the only arguments each instruction takes. This piece of code is the only
@ -99,8 +103,12 @@ static SCM word_type_symbols[] =
#define OP_DST (1 << (TYPE_WIDTH * 5)) #define OP_DST (1 << (TYPE_WIDTH * 5))
#define WORD_TYPE(n, word) \ #define WORD_TYPE_AND_FLAG(n, word) \
(((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1)) (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1))
#define WORD_TYPE(n, word) \
(WORD_TYPE_AND_FLAG (n, word) - 1)
#define HAS_WORD(n, word) \
(WORD_TYPE_AND_FLAG (n, word) != 0)
/* Scheme interface */ /* Scheme interface */
@ -112,15 +120,15 @@ parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta)
/* Format: (name opcode word0 word1 ...) */ /* Format: (name opcode word0 word1 ...) */
if (WORD_TYPE (4, meta)) if (HAS_WORD (4, meta))
len = 5; len = 5;
else if (WORD_TYPE (3, meta)) else if (HAS_WORD (3, meta))
len = 4; len = 4;
else if (WORD_TYPE (2, meta)) else if (HAS_WORD (2, meta))
len = 3; len = 3;
else if (WORD_TYPE (1, meta)) else if (HAS_WORD (1, meta))
len = 2; len = 2;
else if (WORD_TYPE (0, meta)) else if (HAS_WORD (0, meta))
len = 1; len = 1;
else else
abort (); abort ();

579
libguile/vm-engine.c
View file

File diff suppressed because it is too large Load diff

42
module/language/bytecode.scm
View file

@ -34,34 +34,40 @@
(define (compute-instruction-arity name args) (define (compute-instruction-arity name args)
(define (first-word-arity word) (define (first-word-arity word)
(case word (case word
((U8_X24) 0) ((X32) 0)
((U8_U24) 1) ((X8_S24) 1)
((U8_L24) 1) ((X8_F24) 1)
((U8_U8_I16) 2) ((X8_C24) 1)
((U8_U12_U12) 2) ((X8_L24) 1)
((U8_U8_U8_U8) 3))) ((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) (define (tail-word-arity word)
(case word (case word
((U8_U24) 2) ((C32) 1)
((U8_L24) 2)
((U8_U8_I16) 3)
((U8_U12_U12) 3)
((U8_U8_U8_U8) 4)
((U32) 1)
((I32) 1) ((I32) 1)
((A32) 1) ((A32) 1)
((B32) 0) ((B32) 0)
((N32) 1) ((N32) 1)
((S32) 1) ((R32) 1)
((L32) 1) ((L32) 1)
((LO32) 1) ((LO32) 1)
((X8_U24) 1) ((C8_C24) 2)
((X8_U12_U12) 2) ((B1_C7_L24) 3)
((X8_L24) 1) ((B1_X7_S24) 2)
((B1_X7_F24) 2)
((B1_X7_C24) 2)
((B1_X7_L24) 2) ((B1_X7_L24) 2)
((B1_U7_L24) 3)
((B1_X31) 1) ((B1_X31) 1)
((B1_X7_U24) 2))) ((X8_S24) 1)
((X8_F24) 1)
((X8_C24) 1)
((X8_L24) 1)))
(match args (match args
((arg0 . args) ((arg0 . args)
(fold (lambda (arg arity) (fold (lambda (arg arity)

135
module/system/vm/assembler.scm
View file

@ -89,13 +89,13 @@
emit-br-if-struct emit-br-if-struct
emit-br-if-char emit-br-if-char
emit-br-if-tc7 emit-br-if-tc7
(emit-br-if-eq* . emit-br-if-eq) emit-br-if-eq
(emit-br-if-eqv* . emit-br-if-eqv) emit-br-if-eqv
(emit-br-if-equal* . 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-<=* . emit-br-if-<=) emit-br-if-<=
(emit-br-if-logtest* . emit-br-if-logtest) emit-br-if-logtest
(emit-mov* . emit-mov) (emit-mov* . emit-mov)
(emit-box* . emit-box) (emit-box* . emit-box)
(emit-box-ref* . emit-box-ref) (emit-box-ref* . emit-box-ref)
@ -153,7 +153,7 @@
(emit-struct-ref* . emit-struct-ref) (emit-struct-ref* . emit-struct-ref)
(emit-struct-set!* . emit-struct-set!) (emit-struct-set!* . emit-struct-set!)
(emit-class-of* . emit-class-of) (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-u8-ref* . emit-bv-u8-ref)
(emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref)
(emit-bv-u16-ref* . emit-bv-u16-ref) (emit-bv-u16-ref* . emit-bv-u16-ref)
@ -510,29 +510,38 @@ later by the linker."
(with-syntax ((opcode opcode)) (with-syntax ((opcode opcode))
(op-case (op-case
asm type asm type
((U8_X24) ((X32)
(emit asm opcode)) (emit asm opcode))
((U8_U24 arg) ((X8_S24 arg)
(emit asm (pack-u8-u24 opcode 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) (record-label-reference asm label)
(emit asm opcode)) (emit asm opcode))
((U8_U8_I16 a imm) ((X8_S8_I16 a imm)
(emit asm (pack-u8-u8-u16 opcode a (object-address 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))) (emit asm (pack-u8-u12-u12 opcode a b)))
((U8_U8_U8_U8 a b c) ((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)))
((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)))))) (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
(define (pack-tail-word asm type) (define (pack-tail-word asm type)
(op-case (op-case
asm type asm type
((U8_U24 a b) ((C32 a)
(emit asm (pack-u8-u24 a b)))
((U8_L24 a label)
(record-label-reference asm label)
(emit asm a))
((U32 a)
(emit asm a)) (emit asm a))
((I32 imm) ((I32 imm)
(let ((val (object-address imm))) (let ((val (object-address imm)))
@ -548,7 +557,7 @@ later by the linker."
((N32 label) ((N32 label)
(record-far-label-reference asm label) (record-far-label-reference asm label)
(emit asm 0)) (emit asm 0))
((S32 label) ((R32 label)
(record-far-label-reference asm label) (record-far-label-reference asm label)
(emit asm 0)) (emit asm 0))
((L32 label) ((L32 label)
@ -558,21 +567,31 @@ later by the linker."
(record-far-label-reference asm label (record-far-label-reference asm label
(* offset (/ (asm-word-size asm) 4))) (* offset (/ (asm-word-size asm) 4)))
(emit asm 0)) (emit asm 0))
((X8_U24 a) ((C8_C24 a b)
(emit asm (pack-u8-u24 0 a))) (emit asm (pack-u8-u24 a b)))
((X8_L24 label)
(record-label-reference asm label)
(emit asm 0))
((B1_X7_L24 a label) ((B1_X7_L24 a label)
(record-label-reference asm label) (record-label-reference asm label)
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) (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) (record-label-reference asm label)
(emit asm (pack-u1-u7-u24 (if a 1 0) b 0))) (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
((B1_X31 a) ((B1_X31 a)
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
((B1_X7_U24 a b) ((B1_X7_S24 a b)
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 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 () (syntax-case x ()
((_ name opcode word0 word* ...) ((_ name opcode word0 word* ...)
@ -651,25 +670,44 @@ later by the linker."
#f))) #f)))
(op-case (op-case
word0 word0
((U8_U8_I16 ! a imm) ((X8_S8_I16 <- a imm)
(values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
imm))
((U8_U8_I16 <- a imm)
(values (if (< a (ash 1 8)) a 253) (values (if (< a (ash 1 8)) a 253)
imm)) 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)) (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)))) (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) (values (if (< a (ash 1 12)) a 253)
(if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) (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)) (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 (< 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)))) (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) (values (if (< a (ash 1 8)) a 253)
(if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (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)))))) (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))))
(define (tail-formals type) (define (tail-formals type)
@ -682,22 +720,25 @@ later by the linker."
((op-case type) ((op-case type)
(error "unmatched type" type)))) (error "unmatched type" type))))
(op-case type (op-case type
(U8_U24 a b) (C32 a)
(U8_L24 a label)
(U32 a)
(I32 imm) (I32 imm)
(A32 imm) (A32 imm)
(B32) (B32)
(N32 label) (N32 label)
(S32 label) (R32 label)
(L32 label) (L32 label)
(LO32 label offset) (LO32 label offset)
(X8_U24 a) (C8_C24 a b)
(X8_L24 label) (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_X7_L24 a label)
(B1_U7_L24 a b label)
(B1_X31 a) (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 (shuffle-up dst)
(define-syntax op-case (define-syntax op-case
@ -711,10 +752,10 @@ later by the linker."
(with-syntax ((dst dst)) (with-syntax ((dst dst))
(op-case (op-case
word0 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)) (unless (< dst (ash 1 8))
(emit-mov* asm dst 253))) (emit-mov* asm dst 253)))
((U8_U12_U12) ((X8_S12_S12 X8_S12_C12)
(unless (< dst (ash 1 12)) (unless (< dst (ash 1 12))
(emit-mov* asm dst 253)))))) (emit-mov* asm dst 253))))))

70
module/system/vm/disassembler.scm
View file

@ -80,70 +80,58 @@
(define (parse-first-word word type) (define (parse-first-word word type)
(with-syntax ((word word)) (with-syntax ((word word))
(case type (case type
((U8_X24) ((X32)
#'()) #'())
((U8_U24) ((X8_S24 X8_F24 X8_C24)
#'((ash word -8))) #'((ash word -8)))
((U8_L24) ((X8_L24)
#'((unpack-s24 (ash word -8)))) #'((unpack-s24 (ash word -8))))
((U8_U8_I16) ((X8_S8_I16)
#'((logand (ash word -8) #xff) #'((logand (ash word -8) #xff)
(ash word -16))) (ash word -16)))
((U8_U12_U12) ((X8_S12_S12
X8_S12_C12
X8_C12_C12
X8_F12_F12)
#'((logand (ash word -8) #xfff) #'((logand (ash word -8) #xfff)
(ash word -20))) (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 -8) #xff)
(logand (ash word -16) #xff) (logand (ash word -16) #xff)
(ash word -24))) (ash word -24)))
(else (else
(error "bad kind" type))))) (error "bad head kind" type)))))
(define (parse-tail-word word type) (define (parse-tail-word word type)
(with-syntax ((word word)) (with-syntax ((word word))
(case type (case type
((U8_X24) ((C32 I32 A32 B32)
#'((logand word #ff))) #'(word))
((U8_U24) ((N32 R32 L32 LO32)
#'((unpack-s32 word)))
((C8_C24)
#'((logand word #xff) #'((logand word #xff)
(ash word -8))) (ash word -8)))
((U8_L24) ((B1_C7_L24)
#'((logand word #xff)
(unpack-s24 (ash word -8))))
((U32)
#'(word))
((I32)
#'(word))
((A32)
#'(word))
((B32)
#'(word))
((N32)
#'((unpack-s32 word)))
((S32)
#'((unpack-s32 word)))
((L32)
#'((unpack-s32 word)))
((LO32)
#'((unpack-s32 word)))
((X8_U24)
#'((ash word -8)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
((B1_X7_L24)
#'((not (zero? (logand word #x1)))
(unpack-s24 (ash word -8))))
((B1_U7_L24)
#'((not (zero? (logand word #x1))) #'((not (zero? (logand word #x1)))
(logand (ash word -1) #x7f) (logand (ash word -1) #x7f)
(unpack-s24 (ash word -8)))) (unpack-s24 (ash word -8))))
((B1_X31) ((B1_X7_S24 B1_X7_F24 B1_X7_C24)
#'((not (zero? (logand word #x1)))))
((B1_X7_U24)
#'((not (zero? (logand word #x1))) #'((not (zero? (logand word #x1)))
(ash word -8))) (ash word -8)))
((B1_X7_L24)
#'((not (zero? (logand word #x1)))
(unpack-s24 (ash word -8))))
((B1_X31)
#'((not (zero? (logand word #x1)))))
((X8_S24 X8_F24 X8_C24)
#'((ash word -8)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
(else (else
(error "bad kind" type))))) (error "bad tail kind" type)))))
(syntax-case x () (syntax-case x ()
((_ name opcode word0 word* ...) ((_ name opcode word0 word* ...)