File: //proc/thread-self/root/proc/thread-self/root/usr/share/guile/2.2/system/vm/disassembler.scm
;;; 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)))