LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/system/vm/disassembler.scm

@@ -0,0 +1,658 @@
+;;; Guile bytecode disassembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 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 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-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_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)
+           #'((logand word #xff)
+              (ash word -8)))
+          ((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 (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 'br
+          'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
+          'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
+          'br-if-char 'br-if-eq 'br-if-eqv
+          'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
+          'br-if-u64-= 'br-if-u64-< 'br-if-u64-<=
+          'br-if-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm
+          'br-if-u64->-scm 'br-if-u64->=-scm
+          'br-if-f64-= 'br-if-f64-< 'br-if-f64-<=
+          'br-if-f64-> 'br-if-f64->=
+          'br-if-logtest) _ ... target)
+     (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+    (('br-if-tc7 slot invert? tc7 target)
+     (list "~A -> ~A"
+           (let ((tag (case tc7
+                        ((5) "symbol?")
+                        ((7) "variable?")
+                        ((13) "vector?")
+                        ((15) "string?")
+                        ((53) "keyword?")
+                        ((#x3d) "syntax?")
+                        ((77) "bytevector?")
+                        ((95) "bitvector?")
+                        (else (number->string tc7)))))
+             (if invert? (string-append "not " tag) tag))
+           (vector-ref labels (- (+ offset target) start))))
+    (('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))
+    (('return-values nlocals)
+     (if (zero? nlocals)
+         (list "all values")
+         (list "~a value~:p" (1- nlocals))))
+    (('bind-rest dst)
+     (list "~a slot~:p" (1+ dst)))
+    (('tail-call nargs proc)
+     (list "~a arg~:p" nargs))
+    (('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)))
+    (('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 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)))
+    (('make-non-immediate dst target)
+     (let ((val (reference-scm target)))
+       (when (program? val)
+         (push-addr! (program-code val) val))
+       (list "~@Y" val)))
+    (('builtin-ref dst idx)
+     (list "~A" (builtin-index->name idx)))
+    (((or 'static-ref 'static-set!) _ target)
+     (list "~@Y" (dereference-scm target)))
+    (((or 'free-ref 'free-set!) _ _ index)
+     (list "free var ~a" index))
+    (('resolve-module dst name public)
+     (list "~a" (if (zero? public) "private" "public")))
+    (('toplevel-box _ var-offset mod-offset sym-offset bound?)
+     (list "`~A'~A" (dereference-scm sym-offset)
+           (if bound? "" " (maybe unbound)")))
+    (('module-box _ var-offset mod-name-offset sym-offset bound?)
+     (let ((mod-name (reference-scm mod-name-offset)))
+       (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
+             (dereference-scm sym-offset)
+             (if bound? "" " (maybe unbound)"))))
+    (('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
+                 ((br
+                   br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
+                   br-if-true br-if-null br-if-nil br-if-pair br-if-struct
+                   br-if-char br-if-tc7 br-if-eq br-if-eqv
+                   br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest
+                   br-if-u64-= br-if-u64-< br-if-u64-<=
+                   br-if-u64-<-scm br-if-u64-<=-scm br-if-u64-=-scm
+                   br-if-u64->-scm br-if-u64->=-scm)
+                  (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))
+      (('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)))
+      (('toplevel-box dst var-offset mod-offset sym-offset bound?)
+       `(toplevel-box ,dst
+                      ,(dereference-scm var-offset)
+                      ,(dereference-scm mod-offset)
+                      ,(dereference-scm sym-offset)
+                      ,bound?))
+      (('module-box dst var-offset mod-name-offset sym-offset bound?)
+       (let ((mod-name (reference-scm mod-name-offset)))
+         `(module-box ,dst
+                      ,(dereference-scm var-offset)
+                      ,(car mod-name)
+                      ,(cdr mod-name)
+                      ,(dereference-scm sym-offset)
+                      ,bound?)))
+      (_ 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
+                       tail-call tail-call-label tail-call/shuffle
+                       return-values
+                       subr-call foreign-call continuation-call
+                       tail-apply
+                       br))
+  (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 (or (memq symname '(br prompt))
+                 (string-prefix? "br-" (symbol->string symname)))
+             (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) (+ size 1)))
+        ((pop)
+         #'(lambda (code pos size) (- size 1)))
+        ((drop)
+         #'(lambda (code pos size)
+             (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
+               (- 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)
+         #'(lambda (code pos size) #f))
+        ((tail-call tail-call-label tail-call/shuffle tail-apply)
+         #'(lambda (code pos size) #f))
+        (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)
+                                  (match elt
+                                    ((_ proc . _)
+                                     (let lp ((slot (- proc 2)))
+                                       (if (< 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
+                                       #'(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)))