mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 08:10:17 +02:00
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.
This commit is contained in:
Andy Wingo
parent
5e1748f751
commit
bb7fa5bdc2
8 changed files with 381 additions and 264 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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 (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)
|
||||
(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)
|
||||
(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)))
|
||||
(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)
|
||||
((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)
|
||||
(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)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue