[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/09: Add jtable instruction
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/09: Add jtable instruction |
|
Date: |
Thu, 30 Jul 2020 07:26:43 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit bb7fa5bdc24e35927d3450343ee23879dc556745
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jul 23 12:05:14 2020 +0200
Add jtable instruction
* 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.
---
.dir-locals.el | 1 +
doc/ref/vm.texi | 18 +-
libguile/instructions.c | 6 +-
libguile/jit.c | 41 ++++
libguile/vm-engine.c | 26 ++-
module/language/bytecode.scm | 150 ++++++++-------
module/system/vm/assembler.scm | 15 ++
module/system/vm/disassembler.scm | 394 ++++++++++++++++++++------------------
8 files changed, 384 insertions(+), 267 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 26e4ff9..ba48961 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -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))
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index d45a3ad..a94c605 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -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
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ddd88b3..f0db433 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -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
diff --git a/libguile/jit.c b/libguile/jit.c
index e32b859..0299b43 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -4340,6 +4340,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)
{
jit_reloc_t k;
@@ -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;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 19d35f1..7482581 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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)
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index ec0392b..f10bc68 100644
--- a/module/language/bytecode.scm
+++ b/module/language/bytecode.scm
@@ -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,80 +34,87 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_intrinsics")
-(define (compute-instruction-arity name args)
- (define (first-word-arity word)
- (case word
- ((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_S12_Z12) 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
- ((C32) 1)
- ((I32) 1)
- ((A32 AU32 AS32 AF32) 1)
- ((B32 BF32 BS32 BU32) 0)
- ((N32) 1)
- ((R32) 1)
- ((L32) 1)
- ((LO32) 1)
- ((C8_C24) 2)
- ((C8_S24) 2)
- ((C16_C16) 2)
- ((B1_C7_L24) 3)
- ((B1_X7_S24) 2)
- ((B1_X7_F24) 2)
- ((B1_X7_C24) 2)
- ((B1_X7_L24) 2)
- ((B1_X31) 1)
- ((X8_S24) 1)
- ((X8_F24) 1)
- ((X8_C24) 1)
- ((X8_L24) 1)))
- (match args
- ((arg0 . args)
- (fold (lambda (arg arity)
- (+ (tail-word-arity arg) arity))
- (first-word-arity arg0)
- args))))
+(begin-deprecated
+ (define (compute-instruction-arity name args)
+ (define (first-word-arity word)
+ (case word
+ ((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_S12_Z12) 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
+ ((C32) 1)
+ ((I32) 1)
+ ((A32 AU32 AS32 AF32) 1)
+ ((B32 BF32 BS32 BU32) 0)
+ ((N32) 1)
+ ((R32) 1)
+ ((L32) 1)
+ ((LO32) 1)
+ ((C8_C24) 2)
+ ((C8_S24) 2)
+ ((C16_C16) 2)
+ ((B1_C7_L24) 3)
+ ((B1_X7_S24) 2)
+ ((B1_X7_F24) 2)
+ ((B1_X7_C24) 2)
+ ((B1_X7_L24) 2)
+ ((B1_X31) 1)
+ ((X8_S24) 1)
+ ((X8_F24) 1)
+ ((X8_C24) 1)
+ ((X8_L24) 1)))
+ (match args
+ ((arg0 . args)
+ (fold (lambda (arg arity)
+ (+ (tail-word-arity arg) arity))
+ (first-word-arity arg0)
+ args))))
-(define *macro-instruction-arities*
- '((cache-current-module! . (0 . 1))
- (cached-toplevel-box . (1 . 0))
- (cached-module-box . (1 . 0))))
+ (define *macro-instruction-arities*
+ '((cache-current-module! . (0 . 1))
+ (cached-toplevel-box . (1 . 0))
+ (cached-module-box . (1 . 0))))
-(define (compute-instruction-arities)
- (let ((table (make-hash-table)))
- (for-each
- (match-lambda
- ;; Put special cases here.
- ((name op '! . args)
- (hashq-set! table name
- (cons 0 (compute-instruction-arity name args))))
- ((name op '<- . args)
- (hashq-set! table name
- (cons 1 (1- (compute-instruction-arity name args))))))
- (instruction-list))
- (for-each (match-lambda
- ((name . arity)
- (hashq-set! table name arity)))
- *macro-instruction-arities*)
- table))
+ (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))))
+ ((name op '<- . args)
+ (hashq-set! table name
+ (cons 1 (1- (compute-instruction-arity name args))))))
+ (instruction-list))
+ (for-each (match-lambda
+ ((name . arity)
+ (hashq-set! table name arity)))
+ *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)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index ff883d3..e0a39d3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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))
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index 7107977..d51c14d 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -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,139 +530,128 @@ 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 jump-parsers (make-vector 256 (lambda (code pos) '())))
-(visit-opcodes define-jump-parser)
+(define (word-offset->byte-offset n)
+ (* n 4))
+
+(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)))
-
-(define-syntax define-stack-effect-parser
- (lambda (x)
- (define (stack-effect-parser name)
- (case name
- ((push)
- #'(lambda (code pos size) (and size (+ size 1))))
- ((pop)
- #'(lambda (code pos size) (and size (- size 1))))
- ((drop)
- #'(lambda (code pos size)
- (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
- (and size (- size count)))))
- ((alloc-frame reset-frame bind-optionals)
- #'(lambda (code pos size)
- (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
- nlocals)))
- ((receive)
- #'(lambda (code pos size)
- (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
- -8)))
- nlocals)))
- ((bind-kwargs)
- #'(lambda (code pos size)
- (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8))
-8)))
- ntotal)))
- ((bind-rest)
- #'(lambda (code pos size)
- (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
- (+ dst 1))))
- ((assert-nargs-ee/locals)
- #'(lambda (code pos size)
- (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
- #xfff))
- (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
- (+ nargs nlocals))))
- ((call call-label tail-call tail-call-label expand-apply-argument)
- #'(lambda (code pos size) #f))
- ((shuffle-down)
- #'(lambda (code pos size)
- (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
- #xfff))
- (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)
+ (match (vector-ref jump-parsers opcode)
+ (#f '())
+ (proc (proc code pos)))))
+
+(define-op-handlers stack-effect-parsers
+ (lambda (name kind word-types)
+ (case name
+ ((push)
+ #'(lambda (code pos size) (and size (+ size 1))))
+ ((pop)
+ #'(lambda (code pos size) (and size (- size 1))))
+ ((drop)
+ #'(lambda (code pos size)
+ (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
+ (and size (- size count)))))
+ ((alloc-frame reset-frame bind-optionals)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
+ nlocals)))
+ ((receive)
+ #'(lambda (code pos size)
+ (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
+ -8)))
+ nlocals)))
+ ((bind-kwargs)
+ #'(lambda (code pos size)
+ (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
+ ntotal)))
+ ((bind-rest)
+ #'(lambda (code pos size)
+ (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
+ (+ dst 1))))
+ ((assert-nargs-ee/locals)
+ #'(lambda (code pos size)
+ (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
+ (+ nargs nlocals))))
+ ((call call-label tail-call tail-call-label expand-apply-argument)
+ #'(lambda (code pos size) #f))
+ ((shuffle-down)
+ #'(lambda (code pos size)
+ (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
+ #xfff))
+ (to (ash (bytevector-u32-native-ref code pos) -20)))
+ (and size (- size (- from to))))))
+ (else
+ #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)))
-
-(define-syntax define-clobber-parser
- (lambda (x)
- (syntax-case x ()
- ((_ name opcode kind arg0 arg* ...)
- (case (syntax->datum #'kind)
- ((!)
- (case (syntax->datum #'name)
- ((call call-label)
- #'(let ((parse (lambda (code pos nslots-in nslots-out)
- (call-with-values
- (lambda ()
- (disassemble-one code (/ pos 4)))
- (lambda (len elt)
- (define frame-size 3)
- (match elt
- ((_ proc . _)
- (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 ()
- (disassemble-one code (/ pos 4)))
- (lambda (len elt)
- (match elt
- ((_ dst . _)
- #,(case (syntax->datum #'arg0)
- ((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)
+ (match (vector-ref stack-effect-parsers opcode)
+ (#f size)
+ (proc (proc code pos size)))))
+
+(define-op-handlers clobber-parsers
+ (lambda (name kind word-types)
+ (match kind
+ ('!
+ (case name
+ ((call call-label)
+ #'(lambda (code pos nslots-in nslots-out)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (define frame-size 3)
+ (match elt
+ ((_ proc . _)
+ (let lp ((slot (- proc frame-size)))
+ (if (and nslots-in (< slot nslots-in))
+ (cons slot (lp (1+ slot)))
+ '()))))))))
+ (else #f)))
+ ('<-
+ #`(lambda (code pos nslots-in nslots-out)
+ (call-with-values (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ dst . _)
+ #,(match word-types
+ (((or 'X8_F24 'X8_F12_F12) . _)
+ #'(list dst))
+ (else
+ #'(if nslots-out
+ (list (- nslots-out 1 dst))
+ '()))))))))))))
(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)))))
- [Guile-commits] branch master updated (5e1748f -> 5342eb5), Andy Wingo, 2020/07/30
- [Guile-commits] 01/09: Add jtable instruction,
Andy Wingo <=
- [Guile-commits] 02/09: Fix patch_veneer on aarch64, Andy Wingo, 2020/07/30
- [Guile-commits] 04/09: Ensure tail caller and callee in jmpi test have compatible ABI, Andy Wingo, 2020/07/30
- [Guile-commits] 03/09: Merge branch 'fix-aarch64-veneers' into 'master', Andy Wingo, 2020/07/30
- [Guile-commits] 06/09: Add support for emitting inline data and table switches, Andy Wingo, 2020/07/30
- [Guile-commits] 07/09: Merge branch 'table-switch' into 'master', Andy Wingo, 2020/07/30
- [Guile-commits] 05/09: Merge branch 'fix-tail-call-test' into 'master', Andy Wingo, 2020/07/30
- [Guile-commits] 08/09: Merge https://gitlab.com/wingo/lightening master branch, Andy Wingo, 2020/07/30
- [Guile-commits] 09/09: Add JIT implementation for jtable, Andy Wingo, 2020/07/30