D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
usr
/
share
/
guile
/
2.2
/
system
/
vm
/
Filename :
disassembler.scm
back
Copy
;;; 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)))