diff options
Diffstat (limited to 'module/system/vm/disassembler.scm')
-rw-r--r-- | module/system/vm/disassembler.scm | 643 |
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))) |