mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20: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))) (indent-tabs-mode . nil)))
(scheme-mode (scheme-mode
. ((indent-tabs-mode . nil) . ((indent-tabs-mode . nil)
(eval . (put 'with-syntax 'scheme-indent-function 1))
(eval . (put 'let/ec 'scheme-indent-function 1)) (eval . (put 'let/ec 'scheme-indent-function 1))
(eval . (put 'pass-if 'scheme-indent-function 1)) (eval . (put 'pass-if 'scheme-indent-function 1))
(eval . (put 'pass-if-exception 'scheme-indent-function 2)) (eval . (put 'pass-if-exception 'scheme-indent-function 2))

18
doc/ref/vm.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @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 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @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 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 number of words offset from that label, for example when patching a
field of a statically allocated object. 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 @item b1
A boolean value: 1 for true, otherwise 0. A boolean value: 1 for true, otherwise 0.
@item x@var{n} @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}. a NaN. For exact numbers, @code{jnge} is the same as @code{jl}.
@end deftypefn @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 @node Raw Memory Access Instructions
@subsubsection 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. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -74,7 +74,9 @@ SCM_SYMBOL (sym_bang, "!");
M(B1_X7_S24) \ M(B1_X7_S24) \
M(B1_X7_F24) \ M(B1_X7_F24) \
M(B1_X31) \ M(B1_X31) \
M(C16_C16) M(C16_C16) \
M(V32_X8_L24) /* Length-prefixed array of X8_L24. */ \
/**/
#define TYPE_WIDTH 6 #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 static void
compile_heap_numbers_equal (scm_jit_state *j, uint16_t a, uint16_t b) 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) \ #define COMPILE_X8_S8_C8_S8__C32(j, comp) \
COMPILE_X8_S8_S8_C8__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) \ #define COMPILE_X32__LO32__L32(j, comp) \
{ \ { \
int32_t a = j->ip[1], b = j->ip[2]; \ 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; j->op_attrs[target - j->start] |= OP_ATTR_BLOCK;
break; 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:
case scm_op_call_label: case scm_op_call_label:
attrs = OP_ATTR_BLOCK; attrs = OP_ATTR_BLOCK;

26
libguile/vm-engine.c
View file

@ -3376,7 +3376,31 @@ VM_NAME (scm_thread *thread)
NEXT (2); 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 (164, unused_164, NULL, NOP)
VM_DEFINE_OP (165, unused_165, NULL, NOP) VM_DEFINE_OP (165, unused_165, NULL, NOP)
VM_DEFINE_OP (166, unused_166, NULL, NOP) VM_DEFINE_OP (166, unused_166, NULL, NOP)

150
module/language/bytecode.scm
View file

@ -1,6 +1,6 @@
;;; Bytecode ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -22,7 +22,6 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module ((srfi srfi-1) #:select (fold)) #:use-module ((srfi srfi-1) #:select (fold))
#:export (instruction-list #:export (instruction-list
instruction-arity
builtin-name->index builtin-name->index
builtin-index->name builtin-index->name
intrinsic-name->index intrinsic-name->index
@ -35,80 +34,87 @@
(load-extension (string-append "libguile-" (effective-version)) (load-extension (string-append "libguile-" (effective-version))
"scm_init_intrinsics") "scm_init_intrinsics")
(define (compute-instruction-arity name args) (begin-deprecated
(define (first-word-arity word) (define (compute-instruction-arity name args)
(case word (define (first-word-arity word)
((X32) 0) (case word
((X8_S24) 1) ((X32) 0)
((X8_F24) 1) ((X8_S24) 1)
((X8_C24) 1) ((X8_F24) 1)
((X8_L24) 1) ((X8_C24) 1)
((X8_S8_I16) 2) ((X8_L24) 1)
((X8_S12_S12) 2) ((X8_S8_I16) 2)
((X8_S12_C12) 2) ((X8_S12_S12) 2)
((X8_S12_Z12) 2) ((X8_S12_C12) 2)
((X8_C12_C12) 2) ((X8_S12_Z12) 2)
((X8_F12_F12) 2) ((X8_C12_C12) 2)
((X8_S8_S8_S8) 3) ((X8_F12_F12) 2)
((X8_S8_S8_C8) 3) ((X8_S8_S8_S8) 3)
((X8_S8_C8_S8) 3))) ((X8_S8_S8_C8) 3)
(define (tail-word-arity word) ((X8_S8_C8_S8) 3)))
(case word (define (tail-word-arity word)
((C32) 1) (case word
((I32) 1) ((C32) 1)
((A32 AU32 AS32 AF32) 1) ((I32) 1)
((B32 BF32 BS32 BU32) 0) ((A32 AU32 AS32 AF32) 1)
((N32) 1) ((B32 BF32 BS32 BU32) 0)
((R32) 1) ((N32) 1)
((L32) 1) ((R32) 1)
((LO32) 1) ((L32) 1)
((C8_C24) 2) ((LO32) 1)
((C8_S24) 2) ((C8_C24) 2)
((C16_C16) 2) ((C8_S24) 2)
((B1_C7_L24) 3) ((C16_C16) 2)
((B1_X7_S24) 2) ((B1_C7_L24) 3)
((B1_X7_F24) 2) ((B1_X7_S24) 2)
((B1_X7_C24) 2) ((B1_X7_F24) 2)
((B1_X7_L24) 2) ((B1_X7_C24) 2)
((B1_X31) 1) ((B1_X7_L24) 2)
((X8_S24) 1) ((B1_X31) 1)
((X8_F24) 1) ((X8_S24) 1)
((X8_C24) 1) ((X8_F24) 1)
((X8_L24) 1))) ((X8_C24) 1)
(match args ((X8_L24) 1)))
((arg0 . args) (match args
(fold (lambda (arg arity) ((arg0 . args)
(+ (tail-word-arity arg) arity)) (fold (lambda (arg arity)
(first-word-arity arg0) (+ (tail-word-arity arg) arity))
args)))) (first-word-arity arg0)
args))))
(define *macro-instruction-arities* (define *macro-instruction-arities*
'((cache-current-module! . (0 . 1)) '((cache-current-module! . (0 . 1))
(cached-toplevel-box . (1 . 0)) (cached-toplevel-box . (1 . 0))
(cached-module-box . (1 . 0)))) (cached-module-box . (1 . 0))))
(define (compute-instruction-arities) (define (compute-instruction-arities)
(let ((table (make-hash-table))) (issue-deprecation-warning
(for-each "`instruction-arity' is deprecated. Instead, use instruction-list directly
(match-lambda if needed.")
;; Put special cases here. (let ((table (make-hash-table)))
((name op '! . args) (for-each
(hashq-set! table name (match-lambda
(cons 0 (compute-instruction-arity name args)))) ;; Put special cases here.
((name op '<- . args) (('jtable . _)
(hashq-set! table name ;; No macro-instruction.
(cons 1 (1- (compute-instruction-arity name args)))))) #f)
(instruction-list)) ((name op '! . args)
(for-each (match-lambda (hashq-set! table name
((name . arity) (cons 0 (compute-instruction-arity name args))))
(hashq-set! table name arity))) ((name op '<- . args)
*macro-instruction-arities*) (hashq-set! table name
table)) (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) (define-public (instruction-arity name)
(hashq-ref (force *instruction-arities*) name)) (hashq-ref (force *instruction-arities*) name)))
(define *intrinsic-codes* (define *intrinsic-codes*
(delay (let ((tab (make-hash-table))) (delay (let ((tab (make-hash-table)))

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

@ -89,6 +89,7 @@
emit-jne emit-jne
emit-jge emit-jge
emit-jnge emit-jnge
emit-jtable
emit-fixnum? emit-fixnum?
emit-heap-object? emit-heap-object?
@ -746,6 +747,19 @@ later by the linker."
(emit asm (pack-u8-u24 a b))) (emit asm (pack-u8-u24 a b)))
((C16_C16 a b) ((C16_C16 a b)
(emit asm (pack-u16-u16 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) ((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)))
@ -1050,6 +1064,7 @@ later by the linker."
('C8_C24 #'(a b)) ('C8_C24 #'(a b))
('C8_S24 #'(a b)) ('C8_S24 #'(a b))
('C16_C16 #'(a b)) ('C16_C16 #'(a b))
('V32_X8_L24 #'(labels))
('B1_X7_L24 #'(a label)) ('B1_X7_L24 #'(a label))
('B1_C7_L24 #'(a b label)) ('B1_C7_L24 #'(a b label))
('B1_X31 #'(a)) ('B1_X31 #'(a))

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

@ -1,6 +1,6 @@
;;; Guile bytecode disassembler ;;; 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 ;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public ;;; modify it under the terms of the GNU Lesser General Public
@ -43,27 +43,6 @@
instruction-stack-size-after instruction-stack-size-after
instruction-slot-clobbers)) 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) (define (unpack-scm n)
(pointer->scm (make-pointer n))) (pointer->scm (make-pointer n)))
@ -82,8 +61,31 @@
s s
(- s (ash 1 32)))) (- s (ash 1 32))))
(define-syntax disassembler (eval-when (expand)
(lambda (x) (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) (define (parse-first-word word type)
(with-syntax ((word word)) (with-syntax ((word word))
(case type (case type
@ -114,75 +116,76 @@
(else (else
(error "bad head kind" type))))) (error "bad head kind" type)))))
(define (parse-tail-word word type) (define (parse-tail-word word type n)
(with-syntax ((word word)) (with-syntax ((word word) (n n))
(case type (case type
((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32) ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
#'(word)) #'(1 word))
((N32 R32 L32 LO32) ((N32 R32 L32 LO32)
#'((unpack-s32 word))) #'(1 (unpack-s32 word)))
((C8_C24 C8_S24) ((C8_C24 C8_S24)
#'((logand word #xff) #'(1
(logand word #xff)
(ash word -8))) (ash word -8)))
((C16_C16) ((C16_C16)
#'((logand word #xffff) #'(1
(logand word #xffff)
(ash word -16))) (ash word -16)))
((B1_C7_L24) ((B1_C7_L24)
#'((not (zero? (logand word #x1))) #'(1
(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_X7_S24 B1_X7_F24 B1_X7_C24) ((B1_X7_S24 B1_X7_F24 B1_X7_C24)
#'((not (zero? (logand word #x1))) #'(1
(not (zero? (logand word #x1)))
(ash word -8))) (ash word -8)))
((B1_X7_L24) ((B1_X7_L24)
#'((not (zero? (logand word #x1))) #'(1
(not (zero? (logand word #x1)))
(unpack-s24 (ash word -8)))) (unpack-s24 (ash word -8))))
((B1_X31) ((B1_X31)
#'((not (zero? (logand word #x1))))) #'(1 (not (zero? (logand word #x1)))))
((X8_S24 X8_F24 X8_C24) ((X8_S24 X8_F24 X8_C24)
#'((ash word -8))) #'(1 (ash word -8)))
((X8_L24) ((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 (else
(error "bad tail kind" type))))) (error "bad tail kind" type)))))
(syntax-case x () (match word-types
((_ name opcode word0 word* ...) ((first-word . tail-words)
(let ((vars (generate-temporaries #'(word* ...)))) (let ((vars (generate-temporaries tail-words))
(with-syntax (((word* ...) vars) (word-offsets (map 1+ (iota (length tail-words)))))
((n ...) (map 1+ (iota (length #'(word* ...))))) (with-syntax ((name (datum->syntax #'nowhere name))
((word* ...) vars)
((n ...) word-offsets)
((asm ...) ((asm ...)
(parse-first-word #'first (syntax->datum #'word0))) (parse-first-word #'first first-word))
(((asm* ...) ...) (((len asm* ...) ...)
(map (lambda (word type) (map parse-tail-word vars tail-words word-offsets)))
(parse-tail-word word type))
vars
(syntax->datum #'(word* ...)))))
#'(lambda (buf offset first) #'(lambda (buf offset first)
(let ((word* (u32-ref buf (+ offset n))) (let ((word* (u32-ref buf (+ offset n)))
...) ...)
(values (+ 1 (length '(word* ...))) (values (+ 1 len ...)
(list 'name asm ... asm* ... ...)))))))))) (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 ;; -> len list
(define (disassemble-one buf offset) (define (disassemble-one buf offset)
(let ((first (u32-ref 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) (define (u32-offset->addr offset context)
"Given an offset into an image in 32-bit units, return the absolute "Given an offset into an image in 32-bit units, return the absolute
@ -305,7 +308,15 @@ address of that offset."
((prompt) ((prompt)
(match arg (match arg
((_ ... target) ((_ ... 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)))))) (lp (+ offset len))))))
(let lp ((offset start) (n 1)) (let lp ((offset start) (n 1))
(when (< offset end) (when (< offset end)
@ -473,15 +484,27 @@ address of that offset."
((_) ((_)
(let ((lengths (make-vector 256 #f))) (let ((lengths (make-vector 256 #f)))
(for-each (match-lambda (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 ...) ((name opcode kind words ...)
(vector-set! lengths opcode (* 4 (length words))))) (vector-set! lengths opcode (* 4 (length words)))))
(instruction-list)) (instruction-list))
(datum->syntax x lengths)))))) (datum->syntax x lengths))))))
(define (instruction-length code pos) (define (instruction-length code pos)
(unless (zero? (modulo pos 4))
(error "invalid pos"))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(or (vector-ref (instruction-lengths-vector) opcode) (match (vector-ref (instruction-lengths-vector) opcode)
(error "Unknown opcode" 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 (define-syntax static-opcode-set
(lambda (x) (lambda (x)
@ -507,139 +530,128 @@ address of that offset."
tail-call tail-call-label tail-call tail-call-label
return-values return-values
subr-call foreign-call continuation-call subr-call foreign-call continuation-call
j)) j jtable))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(bitvector-bit-clear? non-fallthrough-set opcode))) (bitvector-bit-clear? non-fallthrough-set opcode)))
(define-syntax define-jump-parser (define (word-offset->byte-offset n)
(lambda (x) (* n 4))
(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) '()))) (define-op-handlers jump-parsers
(visit-opcodes define-jump-parser) (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) (define (instruction-relative-jump-targets code pos)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (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 (define-op-handlers stack-effect-parsers
(lambda (x) (lambda (name kind word-types)
(define (stack-effect-parser name) (case name
(case name ((push)
((push) #'(lambda (code pos size) (and size (+ size 1))))
#'(lambda (code pos size) (and size (+ size 1)))) ((pop)
((pop) #'(lambda (code pos size) (and size (- size 1))))
#'(lambda (code pos size) (and size (- size 1)))) ((drop)
((drop) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
(let ((count (ash (bytevector-u32-native-ref code pos) -8))) (and size (- size count)))))
(and size (- size count))))) ((alloc-frame reset-frame bind-optionals)
((alloc-frame reset-frame bind-optionals) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
(let ((nlocals (ash (bytevector-u32-native-ref code pos) -8))) nlocals)))
nlocals))) ((receive)
((receive) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
(let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4)) -8)))
-8))) nlocals)))
nlocals))) ((bind-kwargs)
((bind-kwargs) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
(let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8))) ntotal)))
ntotal))) ((bind-rest)
((bind-rest) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
(let ((dst (ash (bytevector-u32-native-ref code pos) -8))) (+ dst 1))))
(+ dst 1)))) ((assert-nargs-ee/locals)
((assert-nargs-ee/locals) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
(let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8) #xfff))
#xfff)) (nlocals (ash (bytevector-u32-native-ref code pos) -20)))
(nlocals (ash (bytevector-u32-native-ref code pos) -20))) (+ nargs nlocals))))
(+ nargs nlocals)))) ((call call-label tail-call tail-call-label expand-apply-argument)
((call call-label tail-call tail-call-label expand-apply-argument) #'(lambda (code pos size) #f))
#'(lambda (code pos size) #f)) ((shuffle-down)
((shuffle-down) #'(lambda (code pos size)
#'(lambda (code pos size) (let ((from (logand (ash (bytevector-u32-native-ref code pos) -8)
(let ((from (logand (ash (bytevector-u32-native-ref code pos) -8) #xfff))
#xfff)) (to (ash (bytevector-u32-native-ref code pos) -20)))
(to (ash (bytevector-u32-native-ref code pos) -20))) (and size (- size (- from to))))))
(and size (- size (- from to)))))) (else
(else #f))))
#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 (instruction-stack-size-after code pos size) (define (instruction-stack-size-after code pos size)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (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 (define-op-handlers clobber-parsers
(lambda (x) (lambda (name kind word-types)
(syntax-case x () (match kind
((_ name opcode kind arg0 arg* ...) ('!
(case (syntax->datum #'kind) (case name
((!) ((call call-label)
(case (syntax->datum #'name) #'(lambda (code pos nslots-in nslots-out)
((call call-label) (call-with-values
#'(let ((parse (lambda (code pos nslots-in nslots-out) (lambda ()
(call-with-values (disassemble-one code (/ pos 4)))
(lambda () (lambda (len elt)
(disassemble-one code (/ pos 4))) (define frame-size 3)
(lambda (len elt) (match elt
(define frame-size 3) ((_ proc . _)
(match elt (let lp ((slot (- proc frame-size)))
((_ proc . _) (if (and nslots-in (< slot nslots-in))
(let lp ((slot (- proc frame-size))) (cons slot (lp (1+ slot)))
(if (and nslots-in (< slot nslots-in)) '()))))))))
(cons slot (lp (1+ slot))) (else #f)))
'()))))))))) ('<-
(vector-set! clobber-parsers opcode parse))) #`(lambda (code pos nslots-in nslots-out)
(else (call-with-values (lambda ()
#'(begin)))) (disassemble-one code (/ pos 4)))
((<-) (lambda (len elt)
#`(let ((parse (lambda (code pos nslots-in nslots-out) (match elt
(call-with-values ((_ dst . _)
(lambda () #,(match word-types
(disassemble-one code (/ pos 4))) (((or 'X8_F24 'X8_F12_F12) . _)
(lambda (len elt) #'(list dst))
(match elt (else
((_ dst . _) #'(if nslots-out
#,(case (syntax->datum #'arg0) (list (- nslots-out 1 dst))
((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) (define (instruction-slot-clobbers code pos nslots-in nslots-out)
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (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)))))