summaryrefslogtreecommitdiff
path: root/module/system/vm/disassembler.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/disassembler.scm')
-rw-r--r--module/system/vm/disassembler.scm643
1 files changed, 643 insertions, 0 deletions
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
new file mode 100644
index 000000000..83499333c
--- /dev/null
+++ b/module/system/vm/disassembler.scm
@@ -0,0 +1,643 @@
+;;; Guile bytecode disassembler
+
+;;; Copyright (C) 2001, 2009-2010, 2012-2015, 2017-2018 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
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm disassembler)
+ #:use-module (language bytecode)
+ #:use-module (system vm elf)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system base types internal)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program
+ fold-program-code
+ disassemble-image
+ disassemble-file
+
+ instruction-length
+ instruction-has-fallthrough?
+ instruction-relative-jump-targets
+ 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)))
+
+(define (unpack-s24 s)
+ (if (zero? (logand s (ash 1 23)))
+ s
+ (- s (ash 1 24))))
+
+(define (unpack-s12 s)
+ (if (zero? (logand s (ash 1 11)))
+ s
+ (- s (ash 1 12))))
+
+(define (unpack-s32 s)
+ (if (zero? (logand s (ash 1 31)))
+ s
+ (- s (ash 1 32))))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((X32)
+ #'())
+ ((X8_S24 X8_F24 X8_C24)
+ #'((ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((X8_S8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((X8_S12_S12
+ X8_S12_C12
+ X8_C12_C12
+ X8_F12_F12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((X8_S12_Z12)
+ #'((logand (ash word -8) #xfff)
+ (unpack-s12 (ash word -20))))
+ ((X8_S8_S8_S8
+ X8_S8_S8_C8
+ X8_S8_C8_S8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad head kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32)
+ #'(word))
+ ((N32 R32 L32 LO32)
+ #'((unpack-s32 word)))
+ ((C8_C24 C8_S24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((C16_C16)
+ #'((logand word #xffff)
+ (ash word -16)))
+ ((B1_C7_L24)
+ #'((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)))
+ (ash word -8)))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_X31)
+ #'((not (zero? (logand word #x1)))))
+ ((X8_S24 X8_F24 X8_C24)
+ #'((ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ (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* ...)))))
+ ((asm ...)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ (((asm* ...) ...)
+ (map (lambda (word type)
+ (parse-tail-word word type))
+ vars
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (buf offset first)
+ (let ((word* (u32-ref buf (+ offset n)))
+ ...)
+ (values (+ 1 (length '(word* ...)))
+ (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)))
+
+(define (u32-offset->addr offset context)
+ "Given an offset into an image in 32-bit units, return the absolute
+address of that offset."
+ (+ (debug-context-base context) (* offset 4)))
+
+(define immediate-tag-annotations '())
+(define-syntax-rule (define-immediate-tag-annotation name pred mask tag)
+ (set! immediate-tag-annotations
+ (cons `((,mask ,tag) ,(symbol->string 'pred)) immediate-tag-annotations)))
+(visit-immediate-tags define-immediate-tag-annotation)
+
+(define heap-tag-annotations '())
+(define-syntax-rule (define-heap-tag-annotation name pred mask tag)
+ (set! heap-tag-annotations
+ (cons `((,mask ,tag) ,(symbol->string 'pred)) heap-tag-annotations)))
+
+(visit-heap-tags define-heap-tag-annotation)
+
+(define (code-annotation code len offset start labels context push-addr!)
+ ;; FIXME: Print names for register loads and stores that correspond to
+ ;; access to named locals.
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+
+ (match code
+ (((or 'j 'je 'jl 'jge 'jne 'jnl 'jnge) target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('immediate-tag=? _ mask tag)
+ (assoc-ref immediate-tag-annotations (list mask tag)))
+ (('heap-tag=? _ mask tag)
+ (assoc-ref heap-tag-annotations (list mask tag)))
+ (('prompt tag escape-only? proc-slot handler)
+ ;; The H is for handler.
+ (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+ (((or 'make-short-immediate 'make-long-immediate) _ imm)
+ (list "~S" (unpack-scm imm)))
+ (('make-long-long-immediate _ high low)
+ (list "~S" (unpack-scm (logior (ash high 32) low))))
+ (('assert-nargs-ee/locals nargs locals)
+ ;; The nargs includes the procedure.
+ (list "~a slot~:p (~a arg~:p)" (+ locals nargs) (1- nargs)))
+ (('alloc-frame nlocals)
+ (list "~a slot~:p" nlocals))
+ (('reset-frame nlocals)
+ (list "~a slot~:p" nlocals))
+ (('bind-rest dst)
+ (list "~a slot~:p" (1+ dst)))
+ (('make-closure dst target nfree)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X (~A free var~:p)" name addr nfree)))
+ (('load-label dst src)
+ (let* ((addr (u32-offset->addr (+ offset src) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X" name addr)))
+ (('call-label closure nlocals target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X" name addr)))
+ (('tail-call-label target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X" name addr)))
+ (('make-non-immediate dst target)
+ (let ((val (reference-scm target)))
+ (when (program? val)
+ (push-addr! (program-code val) val))
+ (list "~@Y" val)))
+ (((or 'throw/value 'throw/value+data) dst target)
+ (list "~@Y" (reference-scm target)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "~@Y" (dereference-scm target)))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (('load-typed-array dst type shape target len)
+ (let ((addr (u32-offset->addr (+ offset target) context)))
+ (list "~a bytes from #x~X" len addr)))
+ (_ #f)))
+
+(define (compute-labels bv start end)
+ (let ((labels (make-vector (- end start) #f)))
+ (define (add-label! pos header)
+ (unless (vector-ref labels (- pos start))
+ (vector-set! labels (- pos start) header)))
+
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (match elt
+ ((inst arg ...)
+ (case inst
+ ((j je jl jge jne jnl jnge)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "L"))))
+ ((prompt)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "H")))))))
+ (lp (+ offset len))))))
+ (let lp ((offset start) (n 1))
+ (when (< offset end)
+ (let* ((pos (- offset start))
+ (label (vector-ref labels pos)))
+ (if label
+ (begin
+ (vector-set! labels
+ pos
+ (string->symbol
+ (string-append label (number->string n))))
+ (lp (1+ offset) (1+ n)))
+ (lp (1+ offset) n)))))
+ labels))
+
+(define (print-info port addr label info extra src)
+ (when label
+ (format port "~A:\n" label))
+ (format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
+ addr info extra src))
+
+(define (disassemble-buffer port bv start end context push-addr!)
+ (let ((labels (compute-labels bv start end))
+ (sources (find-program-sources (u32-offset->addr start context)
+ context)))
+ (define (lookup-source addr)
+ (let lp ((sources sources))
+ (match sources
+ (() #f)
+ ((source . sources)
+ (let ((pc (source-pre-pc source)))
+ (cond
+ ((< pc addr) (lp sources))
+ ((= pc addr)
+ (format #f "~a:~a:~a"
+ (or (source-file source) "(unknown file)")
+ (source-line-for-user source)
+ (source-column source)))
+ (else #f)))))))
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (let ((pos (- offset start))
+ (addr (u32-offset->addr offset context))
+ (annotation (code-annotation elt len offset start labels
+ context push-addr!)))
+ (print-info port pos (vector-ref labels pos) elt annotation
+ (lookup-source addr))
+ (lp (+ offset len)))))))))
+
+(define* (disassemble-addr addr label port #:optional (seen (make-hash-table)))
+ (format port "Disassembly of ~A at #x~X:\n\n" label addr)
+ (cond
+ ((find-program-debug-info addr)
+ => (lambda (pdi)
+ (let ((worklist '()))
+ (define (push-addr! addr label)
+ (unless (hashv-ref seen addr)
+ (hashv-set! seen addr #t)
+ (set! worklist (acons addr label worklist))))
+ (disassemble-buffer port
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ push-addr!)
+ (for-each (match-lambda
+ ((addr . label)
+ (display "\n----------------------------------------\n"
+ port)
+ (disassemble-addr addr label port seen)))
+ worklist))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (disassemble-addr (program-code program) program port))
+
+(define (fold-code-range proc seed bv start end context raw?)
+ (define (cook code offset)
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+ (match code
+ (((or 'make-short-immediate 'make-long-immediate) dst imm)
+ `(,(car code) ,dst ,(unpack-scm imm)))
+ (('make-long-long-immediate dst high low)
+ `(make-long-long-immediate ,dst
+ ,(unpack-scm (logior (ash high 32) low))))
+ (('make-closure dst target nfree)
+ `(make-closure ,dst
+ ,(u32-offset->addr (+ offset target) context)
+ ,nfree))
+ (('load-label dst src)
+ `(load-label ,dst ,(u32-offset->addr (+ offset src) context)))
+ (('make-non-immediate dst target)
+ `(make-non-immediate ,dst ,(reference-scm target)))
+ (('builtin-ref dst idx)
+ `(builtin-ref ,dst ,(builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) dst target)
+ `(,(car code) ,dst ,(dereference-scm target)))
+ (_ code)))
+ (let lp ((offset start) (seed seed))
+ (cond
+ ((< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (lp (+ offset len)
+ (proc (if raw? elt (cook elt offset))
+ seed)))))
+ (else seed))))
+
+(define* (fold-program-code proc seed program-or-addr #:key raw?)
+ (cond
+ ((find-program-debug-info (if (program? program-or-addr)
+ (program-code program-or-addr)
+ program-or-addr))
+ => (lambda (pdi)
+ (fold-code-range proc seed
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ raw?)))
+ (else seed)))
+
+(define* (disassemble-image bv #:optional (port (current-output-port)))
+ (let* ((ctx (debug-context-from-image bv))
+ (base (debug-context-text-base ctx)))
+ (for-each-elf-symbol
+ ctx
+ (lambda (sym)
+ (let ((name (elf-symbol-name sym))
+ (value (elf-symbol-value sym))
+ (size (elf-symbol-size sym)))
+ (format port "Disassembly of ~A at #x~X:\n\n"
+ (if (and (string? name) (not (string-null? name)))
+ name
+ "<unnamed function>")
+ (+ base value))
+ (disassemble-buffer port
+ bv
+ (/ (+ base value) 4)
+ (/ (+ base value size) 4)
+ ctx
+ (lambda (addr name) #t))
+ (display "\n\n" port)))))
+ (values))
+
+(define (disassemble-file file)
+ (let* ((thunk (load-thunk-from-file file))
+ (elf (find-mapped-elf-image (program-code thunk))))
+ (disassemble-image elf)))
+
+(define-syntax instruction-lengths-vector
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ (let ((lengths (make-vector 256 #f)))
+ (for-each (match-lambda
+ ((name opcode kind words ...)
+ (vector-set! lengths opcode (* 4 (length words)))))
+ (instruction-list))
+ (datum->syntax x lengths))))))
+
+(define (instruction-length code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (or (vector-ref (instruction-lengths-vector) opcode)
+ (error "Unknown opcode" opcode))))
+
+(define-syntax static-opcode-set
+ (lambda (x)
+ (define (instruction-opcode inst)
+ (cond
+ ((assq inst (instruction-list))
+ => (match-lambda ((name opcode . _) opcode)))
+ (else
+ (error "unknown instruction" inst))))
+
+ (syntax-case x ()
+ ((static-opcode-set inst ...)
+ (let ((bv (make-bitvector 256 #f)))
+ (for-each (lambda (inst)
+ (bitvector-set! bv (instruction-opcode inst) #t))
+ (syntax->datum #'(inst ...)))
+ (datum->syntax #'static-opcode-set bv))))))
+
+(define (instruction-has-fallthrough? code pos)
+ (define non-fallthrough-set
+ (static-opcode-set halt
+ throw throw/value throw/value+data
+ tail-call tail-call-label
+ return-values
+ subr-call foreign-call continuation-call
+ j))
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (not (bitvector-ref 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 (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)
+ #'(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 (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)
+
+(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)))