diff options
author | Andy Wingo <wingo@pobox.com> | 2020-07-23 12:05:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-07-23 12:24:11 +0200 |
commit | bb7fa5bdc24e35927d3450343ee23879dc556745 (patch) | |
tree | 682b098eee947bee2bee4e66d6969d76d1b37532 | |
parent | 5e1748f75128107e3a0707b66df5adb95d98437e (diff) | |
download | guile-bb7fa5bdc24e35927d3450343ee23879dc556745.tar.gz |
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.
-rw-r--r-- | .dir-locals.el | 1 | ||||
-rw-r--r-- | doc/ref/vm.texi | 18 | ||||
-rw-r--r-- | libguile/instructions.c | 6 | ||||
-rw-r--r-- | libguile/jit.c | 41 | ||||
-rw-r--r-- | libguile/vm-engine.c | 26 | ||||
-rw-r--r-- | module/language/bytecode.scm | 150 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 15 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 394 |
8 files changed, 384 insertions, 267 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 26e4ff9ff..ba48961aa 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 d45a3ad9b..a94c60576 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 ddd88b311..f0db433d8 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 e32b859a4..0299b43b0 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 19d35f113..74825818d 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 ec0392ba4..f10bc6879 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 ff883d38c..e0a39d35c 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 710797793..d51c14d23 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))))) |