mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

Add jtable instruction

Browse source 
* doc/ref/vm.texi (Instruction Set): Document new v32-x8-l24 instruction
  kind.
  (Branch Instructions): Document jtable.
* libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add
  V32_X8_L24.
* libguile/jit.c (compile_jtable, compile_jtable_slow):
  (COMPILE_X8_S24__V32_X8_L24, analyze): Add stub JIT compiler
  implementation.
* libguile/vm-engine.c (jtable): New instruction.
* module/language/bytecode.scm (instruction-arity): Deprecate.
* module/system/vm/assembler.scm (encoder, assembler): Add V32_X8_L24
  case.
* module/system/vm/disassembler.scm (u32-ref, s32-ref): Move definitions
  to expansion-time only.
  (define-op-handlers): New definition, replacing visit-opcodes.
  (disassemblers, jump-parsers, stack-effect-parsers, clobber-parsers):
  Rework in terms of define-op-handlers.  Default case becomes #f, and
  add support for jtable.
  (disassemble-one, instruction-relative-jump-targets)
  (instruction-stack-size-after, instruction-slot-clobbers): Inline
  default case in the lookup procedure, not copied in the handler
  vector.
  (compute-labels): Add jtable case.
  (instruction-lengths-vector, instruction-length): Rework to allow
  variable-length instructions, and mark jtable as being
  variable-length.
  (instruction-has-fallthrough?): Add jtable to the no-fallthrough
  set.
This commit is contained in:
Andy Wingo 2020-07-23 12:05:14 +02:00
parent 5e1748f751
commit bb7fa5bdc2
8 changed files with 381 additions and 264 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -6,6 +6,7 @@
(indent-tabs-mode . nil)))
(scheme-mode
. ((indent-tabs-mode . nil)
(eval . (put 'with-syntax 'scheme-indent-function 1))
(eval . (put 'let/ec 'scheme-indent-function 1))
(eval . (put 'pass-if 'scheme-indent-function 1))
(eval . (put 'pass-if-exception 'scheme-indent-function 2))

18
doc/ref/vm.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2008-2011, 2013, 2015, 2018, 2019
@c Copyright (C) 2008-2011, 2013, 2015, 2018, 2019, 2020
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -607,6 +607,12 @@ virtual machine. The difference is that an assembler might want to
allow an @code{lo32} address to be specified as a label and then some
number of words offset from that label, for example when patching a
field of a statically allocated object.
@item v32:x8-l24
Almost all VM instructions have a fixed size. The @code{jtable}
instruction used to perform optimized @code{case} branches is an
exception, which uses a @code{v32} trailing word to indicate the number
of additional words in the instruction, which themselves are encoded as
@code{x8-l24} values.
@item b1
A boolean value: 1 for true, otherwise 0.
@item x@var{n}
@ -1855,6 +1861,16 @@ from @code{jl} in the way it handles not-a-number (NaN) values:
a NaN. For exact numbers, @code{jnge} is the same as @code{jl}.
@end deftypefn
@deftypefn Instruction {} jtable s24:@var{idx} v32:@var{length} [x8:_ l24:@var{offset}]...
Branch to an entry in a table, as in C's @code{switch} statement.
@var{idx} is a @code{u64} local indicating which entry to branch to.
The immediate @var{len} indicates the number of entries in the table,
and should be greater than or equal to 1. The last entry in the table
is the "catch-all" entry. The @var{offset}... values are signed 24-bit
immediates (@code{l24} encoding), indicating a memory address as a
number of 32-bit words away from the current instruction pointer.
@end deftypefn
@node Raw Memory Access Instructions
@subsubsection Raw Memory Access Instructions

6
libguile/instructions.c
View file

@ -1,4 +1,4 @@
/* Copyright 2001,2009-2013,2017-2018
/* Copyright 2001,2009-2013,2017-2018,2020
Free Software Foundation, Inc.
This file is part of Guile.
@ -74,7 +74,9 @@ SCM_SYMBOL (sym_bang, "!");
M(B1_X7_S24) \
M(B1_X7_F24) \
M(B1_X31) \
M(C16_C16)
M(C16_C16) \
M(V32_X8_L24) /* Length-prefixed array of X8_L24. */ \
/**/
#define TYPE_WIDTH 6

41
libguile/jit.c
View file

@ -4339,6 +4339,22 @@ compile_jnge_slow (scm_jit_state *j, const uint32_t *vcode)
{
}
static void
compile_jtable (scm_jit_state *j, uint32_t idx, uint32_t len,
const uint32_t *offsets)
{
// Not yet implemented.
UNREACHABLE ();
//jit_reloc_t jmp;
//jmp = jit_jmp (j->jit);
//add_inter_instruction_patch (j, jmp, vcode);
}
static void
compile_jtable_slow (scm_jit_state *j, uint32_t idx, uint32_t len,
const uint32_t *offsets)
{
}
static void
compile_heap_numbers_equal (scm_jit_state *j, uint16_t a, uint16_t b)
{
@ -5338,6 +5354,15 @@ compile_s64_to_f64_slow (scm_jit_state *j, uint16_t dst, uint16_t src)
#define COMPILE_X8_S8_C8_S8__C32(j, comp) \
COMPILE_X8_S8_S8_C8__C32(j, comp)
#define COMPILE_X8_S24__V32_X8_L24(j, comp) \
{ \
uint32_t a, len; \
UNPACK_24 (j->ip[0], a); \
len = j->ip[1]; \
j->next_ip += len; \
comp (j, a, len, j->ip + 2); \
}
#define COMPILE_X32__LO32__L32(j, comp) \
{ \
int32_t a = j->ip[1], b = j->ip[2]; \
@ -5559,6 +5584,22 @@ analyze (scm_jit_state *j)
j->op_attrs[target - j->start] |= OP_ATTR_BLOCK;
break;
case scm_op_jtable:
{
uint32_t len = j->ip[1];
const uint32_t *offsets = j->ip + 2;
for (uint32_t i = 0; i < len; i++)
{
int32_t offset = offsets[i];
offset >>= 8; /* Sign-extending shift. */
target = j->ip + offset;
ASSERT(j->start <= target && target < j->end);
j->op_attrs[target - j->start] |= OP_ATTR_BLOCK;
}
j->next_ip += len;
break;
}
case scm_op_call:
case scm_op_call_label:
attrs = OP_ATTR_BLOCK;

26
libguile/vm-engine.c
View file

@ -3376,7 +3376,31 @@ VM_NAME (scm_thread *thread)
NEXT (2);
}
VM_DEFINE_OP (163, unused_163, NULL, NOP)
/* jtable idx:24 len:32 (_:8 offset:24)...
*
* Branch to an entry in a table, as in C's switch statement. IDX is
* a u64 local, and the immediate LEN indicates the number of entries
* in the table, and should be greater than or equal to 1. The last
* entry in the table is the "catch-all" entry. The OFFSET... values
* are in the usual L24 encoding, indicating a memory address as a
* number of 32-bit words away from the current instruction pointer.
*/
VM_DEFINE_OP (163, jtable, "jtable", OP2 (X8_S24, V32_X8_L24))
{
uint32_t idx, len;
const uint32_t *offsets;
UNPACK_24 (op, idx);
len = ip[1];
offsets = ip + 2;
uint64_t i = SP_REF_U64 (idx);
VM_ASSERT (len > 0, abort());
int32_t offset = offsets[i < len ? i : len - 1];
offset >>= 8; /* Sign-extending shift. */
NEXT (offset);
}
VM_DEFINE_OP (164, unused_164, NULL, NOP)
VM_DEFINE_OP (165, unused_165, NULL, NOP)
VM_DEFINE_OP (166, unused_166, NULL, NOP)

22
module/language/bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Bytecode
;; Copyright (C) 2013, 2017, 2018 Free Software Foundation, Inc.
;; Copyright (C) 2013, 2017, 2018, 2020 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -22,7 +22,6 @@
#:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (instruction-list
instruction-arity
builtin-name->index
builtin-index->name
intrinsic-name->index
@ -35,7 +34,8 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_intrinsics")
(define (compute-instruction-arity name args)
(begin-deprecated
(define (compute-instruction-arity name args)
(define (first-word-arity word)
(case word
((X32) 0)
@ -82,16 +82,22 @@
(first-word-arity arg0)
args))))
(define *macro-instruction-arities*
(define *macro-instruction-arities*
'((cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 0))))
(define (compute-instruction-arities)
(define (compute-instruction-arities)
(issue-deprecation-warning
"`instruction-arity' is deprecated. Instead, use instruction-list directly
if needed.")
(let ((table (make-hash-table)))
(for-each
(match-lambda
;; Put special cases here.
(('jtable . _)
;; No macro-instruction.
#f)
((name op '! . args)
(hashq-set! table name
(cons 0 (compute-instruction-arity name args))))
@ -105,10 +111,10 @@
*macro-instruction-arities*)
table))
(define *instruction-arities* (delay (compute-instruction-arities)))
(define *instruction-arities* (delay (compute-instruction-arities)))
(define (instruction-arity name)
(hashq-ref (force *instruction-arities*) name))
(define-public (instruction-arity name)
(hashq-ref (force *instruction-arities*) name)))
(define *intrinsic-codes*
(delay (let ((tab (make-hash-table)))

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

@ -89,6 +89,7 @@
emit-jne
emit-jge
emit-jnge
emit-jtable
emit-fixnum?
emit-heap-object?
@ -746,6 +747,19 @@ later by the linker."
(emit asm (pack-u8-u24 a b)))
((C16_C16 a b)
(emit asm (pack-u16-u16 a b)))
((V32_X8_L24 labels)
(let ((len (vector-length labels)))
(emit asm len)
(let lp ()
(unless (<= (+ (asm-pos asm) (* 4 len))
(bytevector-length (asm-buf asm)))
(grow-buffer! asm)
(lp)))
(let lp ((n 0))
(when (< n len)
(record-label-reference asm (vector-ref labels n))
(emit asm 0)
(lp (1+ n))))))
((B1_X7_L24 a label)
(record-label-reference asm label)
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
@ -1050,6 +1064,7 @@ later by the linker."
('C8_C24 #'(a b))
('C8_S24 #'(a b))
('C16_C16 #'(a b))
('V32_X8_L24 #'(labels))
('B1_X7_L24 #'(a label))
('B1_C7_L24 #'(a b label))
('B1_X31 #'(a))

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

@ -1,6 +1,6 @@
;;; Guile bytecode disassembler
;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2019 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2020 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -43,27 +43,6 @@
instruction-stack-size-after
instruction-slot-clobbers))
(define-syntax-rule (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
(define-syntax-rule (s32-ref buf n)
(bytevector-s32-native-ref buf (* n 4)))
(define-syntax visit-opcodes
(lambda (x)
(syntax-case x ()
((visit-opcodes macro arg ...)
(with-syntax (((inst ...)
(map (lambda (x) (datum->syntax #'macro x))
(instruction-list))))
#'(begin
(macro arg ... . inst)
...))))))
(eval-when (expand compile load eval)
(define (id-append ctx a b)
(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
(define (unpack-scm n)
(pointer->scm (make-pointer n)))
@ -82,8 +61,31 @@
s
(- s (ash 1 32))))
(define-syntax disassembler
(lambda (x)
(eval-when (expand)
(define-syntax-rule (u32-ref buf n)
(bytevector-u32-native-ref buf (* n 4)))
(define-syntax-rule (s32-ref buf n)
(bytevector-s32-native-ref buf (* n 4)))
(define-syntax-rule (define-op-handlers handlers make-handler)
(define handlers
(let ((handlers (make-vector 256 #f)))
(define-syntax init-handlers
(lambda (stx)
#`(begin
#,@(filter-map
(match-lambda
((name opcode kind . word-types)
(match (make-handler name kind word-types)
(#f #f)
(init #`(vector-set! handlers #,opcode #,init)))))
(instruction-list)))))
(init-handlers)
handlers))))
(define-op-handlers disassemblers
(lambda (name kind word-types)
(define (parse-first-word word type)
(with-syntax ((word word))
(case type
@ -114,75 +116,76 @@
(else
(error "bad head kind" type)))))
(define (parse-tail-word word type)
(with-syntax ((word word))
(define (parse-tail-word word type n)
(with-syntax ((word word) (n n))
(case type
((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
#'(word))
#'(1 word))
((N32 R32 L32 LO32)
#'((unpack-s32 word)))
#'(1 (unpack-s32 word)))
((C8_C24 C8_S24)
#'((logand word #xff)
#'(1
(logand word #xff)
(ash word -8)))
((C16_C16)
#'((logand word #xffff)
#'(1
(logand word #xffff)
(ash word -16)))
((B1_C7_L24)
#'((not (zero? (logand word #x1)))
#'(1
(not (zero? (logand word #x1)))
(logand (ash word -1) #x7f)
(unpack-s24 (ash word -8))))
((B1_X7_S24 B1_X7_F24 B1_X7_C24)
#'((not (zero? (logand word #x1)))
#'(1
(not (zero? (logand word #x1)))
(ash word -8)))
((B1_X7_L24)
#'((not (zero? (logand word #x1)))
#'(1
(not (zero? (logand word #x1)))
(unpack-s24 (ash word -8))))
((B1_X31)
#'((not (zero? (logand word #x1)))))
#'(1 (not (zero? (logand word #x1)))))
((X8_S24 X8_F24 X8_C24)
#'((ash word -8)))
#'(1 (ash word -8)))
((X8_L24)
#'((unpack-s24 (ash word -8))))
#'(1 (unpack-s24 (ash word -8))))
((V32_X8_L24)
#'((+ 1 word)
(let ((v (make-vector word))
(base (+ offset n 1)))
(let lp ((i 0))
(when (< i word)
(vector-set! v i
(unpack-s24 (ash (u32-ref buf (+ base i)) -8)))
(lp (1+ i))))
v)))
(else
(error "bad tail kind" type)))))
(syntax-case x ()
((_ name opcode word0 word* ...)
(let ((vars (generate-temporaries #'(word* ...))))
(with-syntax (((word* ...) vars)
((n ...) (map 1+ (iota (length #'(word* ...)))))
(match word-types
((first-word . tail-words)
(let ((vars (generate-temporaries tail-words))
(word-offsets (map 1+ (iota (length tail-words)))))
(with-syntax ((name (datum->syntax #'nowhere name))
((word* ...) vars)
((n ...) word-offsets)
((asm ...)
(parse-first-word #'first (syntax->datum #'word0)))
(((asm* ...) ...)
(map (lambda (word type)
(parse-tail-word word type))
vars
(syntax->datum #'(word* ...)))))
(parse-first-word #'first first-word))
(((len asm* ...) ...)
(map parse-tail-word vars tail-words word-offsets)))
#'(lambda (buf offset first)
(let ((word* (u32-ref buf (+ offset n)))
...)
(values (+ 1 (length '(word* ...)))
(values (+ 1 len ...)
(list 'name asm ... asm* ... ...))))))))))
(define (disasm-invalid buf offset first)
(error "bad instruction" (logand first #xff) first buf offset))
(define disassemblers (make-vector 256 disasm-invalid))
(define-syntax define-disassembler
(lambda (x)
(syntax-case x ()
((_ name opcode kind arg ...)
(with-syntax ((parse (id-append #'name #'parse- #'name)))
#'(let ((parse (disassembler name opcode arg ...)))
(vector-set! disassemblers opcode parse)))))))
(visit-opcodes define-disassembler)
;; -> len list
(define (disassemble-one buf offset)
(let ((first (u32-ref buf offset)))
((vector-ref disassemblers (logand first #xff)) buf offset first)))
(match (vector-ref disassemblers (logand first #xff))
(#f (error "bad instruction" (logand first #xff) first buf offset))
(disassemble (disassemble buf offset first)))))
(define (u32-offset->addr offset context)
"Given an offset into an image in 32-bit units, return the absolute
@ -305,7 +308,15 @@ address of that offset."
((prompt)
(match arg
((_ ... target)
(add-label! (+ offset target) "H")))))))
(add-label! (+ offset target) "H"))))
((jtable)
(match arg
((_ ... targets)
(let ((len (vector-length targets)))
(let lp ((i 0))
(when (< i len)
(add-label! (+ offset (vector-ref targets i)) "L")
(lp (1+ i)))))))))))
(lp (+ offset len))))))
(let lp ((offset start) (n 1))
(when (< offset end)
@ -473,15 +484,27 @@ address of that offset."
((_)
(let ((lengths (make-vector 256 #f)))
(for-each (match-lambda
((name opcode kind word ... 'V32_X8_L24)
;; Indicate variable-length instruction by setting
;; statically known length to 0.
(vector-set! lengths opcode 0))
((name opcode kind words ...)
(vector-set! lengths opcode (* 4 (length words)))))
(instruction-list))
(datum->syntax x lengths))))))
(define (instruction-length code pos)
(unless (zero? (modulo pos 4))
(error "invalid pos"))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(or (vector-ref (instruction-lengths-vector) opcode)
(error "Unknown opcode" opcode))))
(match (vector-ref (instruction-lengths-vector) opcode)
(#f (error "Unknown opcode" opcode))
(0 (call-with-values (lambda ()
(let ((offset (/ pos 4)))
(disassemble-one code offset)))
(lambda (u32-len disasm)
(* u32-len 4))))
(len len))))
(define-syntax static-opcode-set
(lambda (x)
@ -507,38 +530,43 @@ address of that offset."
tail-call tail-call-label
return-values
subr-call foreign-call continuation-call
j))
j jtable))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(bitvector-bit-clear? non-fallthrough-set opcode)))
(define-syntax define-jump-parser
(lambda (x)
(syntax-case x ()
((_ name opcode kind word0 word* ...)
(let ((symname (syntax->datum #'name)))
(if (memq symname '(prompt j je jl jge jne jnl jnge))
(let ((offset (* 4 (length #'(word* ...)))))
#`(vector-set!
jump-parsers
opcode
(lambda (code pos)
(let ((target
(bytevector-s32-native-ref code (+ pos #,offset))))
;; Assume that the target is in the last word, as
;; an L24 in the high bits.
(list (* 4 (ash target -8)))))))
#'(begin)))))))
(define (word-offset->byte-offset n)
(* n 4))
(define jump-parsers (make-vector 256 (lambda (code pos) '())))
(visit-opcodes define-jump-parser)
(define-op-handlers jump-parsers
(lambda (op kind word-types)
(case op
((prompt j je jl jge jne jnl jnge)
#'(lambda (code pos)
(call-with-values (lambda () (disassemble-one code (/ pos 4)))
(lambda (len disasm)
(match disasm
;; Assume that the target is in the last word, as a
;; word offset.
((_ ___ target) (list (word-offset->byte-offset target))))))))
((jtable)
#'(lambda (code pos)
(call-with-values (lambda () (disassemble-one code (/ pos 4)))
(lambda (len disasm)
(match disasm
;; Assume that the target is in the last word, as a
;; vector of word offsets.
((_ ___ targets)
(map word-offset->byte-offset (vector->list targets))))))))
(else #f))))
(define (instruction-relative-jump-targets code pos)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
((vector-ref jump-parsers opcode) code pos)))
(match (vector-ref jump-parsers opcode)
(#f '())
(proc (proc code pos)))))
(define-syntax define-stack-effect-parser
(lambda (x)
(define (stack-effect-parser name)
(define-op-handlers stack-effect-parsers
(lambda (name kind word-types)
(case name
((push)
#'(lambda (code pos size) (and size (+ size 1))))
@ -580,30 +608,21 @@ address of that offset."
(to (ash (bytevector-u32-native-ref code pos) -20)))
(and size (- size (- from to))))))
(else
#f)))
(syntax-case x ()
((_ name opcode kind word0 word* ...)
(let ((parser (stack-effect-parser (syntax->datum #'name))))
(if parser
#`(vector-set! stack-effect-parsers opcode #,parser)
#'(begin)))))))
(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size)))
(visit-opcodes define-stack-effect-parser)
#f))))
(define (instruction-stack-size-after code pos size)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
((vector-ref stack-effect-parsers opcode) code pos size)))
(match (vector-ref stack-effect-parsers opcode)
(#f size)
(proc (proc code pos size)))))
(define-syntax define-clobber-parser
(lambda (x)
(syntax-case x ()
((_ name opcode kind arg0 arg* ...)
(case (syntax->datum #'kind)
((!)
(case (syntax->datum #'name)
(define-op-handlers clobber-parsers
(lambda (name kind word-types)
(match kind
('!
(case name
((call call-label)
#'(let ((parse (lambda (code pos nslots-in nslots-out)
#'(lambda (code pos nslots-in nslots-out)
(call-with-values
(lambda ()
(disassemble-one code (/ pos 4)))
@ -614,32 +633,25 @@ address of that offset."
(let lp ((slot (- proc frame-size)))
(if (and nslots-in (< slot nslots-in))
(cons slot (lp (1+ slot)))
'())))))))))
(vector-set! clobber-parsers opcode parse)))
(else
#'(begin))))
((<-)
#`(let ((parse (lambda (code pos nslots-in nslots-out)
(call-with-values
(lambda ()
'()))))))))
(else #f)))
('<-
#`(lambda (code pos nslots-in nslots-out)
(call-with-values (lambda ()
(disassemble-one code (/ pos 4)))
(lambda (len elt)
(match elt
((_ dst . _)
#,(case (syntax->datum #'arg0)
((X8_F24 X8_F12_F12)
#,(match word-types
(((or 'X8_F24 'X8_F12_F12) . _)
#'(list dst))
(else
#'(if nslots-out
(list (- nslots-out 1 dst))
'()))))))))))
(vector-set! clobber-parsers opcode parse)))
(else (error "unexpected instruction kind" #'kind)))))))
(define clobber-parsers
(make-vector 256 (lambda (code pos nslots-in nslots-out) '())))
(visit-opcodes define-clobber-parser)
'()))))))))))))
(define (instruction-slot-clobbers code pos nslots-in nslots-out)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))
(match (vector-ref clobber-parsers opcode)
(#f '())
(proc (proc code pos nslots-in nslots-out)))))