module/system/vm/disassembler.scm

   1 ;;; Guile RTL disassembler
   2
   3 ;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This library is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU Lesser General Public
   7 ;;; License as published by the Free Software Foundation; either
   8 ;;; version 3 of the License, or (at your option) any later version.
   9 ;;;
  10 ;;; This library is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; Lesser General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU Lesser General Public
  16 ;;; License along with this library; if not, write to the Free Software
  17 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (system vm disassembler)
  22   #:use-module (system vm instruction)
  23   #:use-module (system vm elf)
  24   #:use-module (system vm debug)
  25   #:use-module (system vm program)
  26   #:use-module (system vm objcode)
  27   #:use-module (system foreign)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (ice-9 format)
  30   #:use-module (ice-9 match)
  31   #:use-module (ice-9 vlist)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-4)
  34   #:export (disassemble-program
  35             disassemble-image
  36             disassemble-file))
  37
  38 (define-syntax-rule (u32-ref buf n)
  39   (bytevector-u32-native-ref buf (* n 4)))
  40
  41 (define-syntax-rule (s32-ref buf n)
  42   (bytevector-s32-native-ref buf (* n 4)))
  43
  44 (define-syntax visit-opcodes
  45   (lambda (x)
  46     (syntax-case x ()
  47       ((visit-opcodes macro arg ...)
  48        (with-syntax (((inst ...)
  49                       (map (lambda (x) (datum->syntax #'macro x))
  50                            (rtl-instruction-list))))
  51          #'(begin
  52              (macro arg ... . inst)
  53              ...))))))
  54
  55 (eval-when (expand compile load eval)
  56   (define (id-append ctx a b)
  57     (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
  58
  59 (define (unpack-scm n)
  60   (pointer->scm (make-pointer n)))
  61
  62 (define (unpack-s24 s)
  63   (if (zero? (logand s (ash 1 23)))
  64       s
  65       (- s (ash 1 24))))
  66
  67 (define (unpack-s32 s)
  68   (if (zero? (logand s (ash 1 31)))
  69       s
  70       (- s (ash 1 32))))
  71
  72 (define-syntax disassembler
  73   (lambda (x)
  74     (define (parse-first-word word type)
  75       (with-syntax ((word word))
  76         (case type
  77           ((U8_X24)
  78            #'())
  79           ((U8_U24)
  80            #'((ash word -8)))
  81           ((U8_L24)
  82            #'((unpack-s24 (ash word -8))))
  83           ((U8_U8_I16)
  84            #'((logand (ash word -8) #xff)
  85               (ash word -16)))
  86           ((U8_U12_U12)
  87            #'((logand (ash word -8) #xfff)
  88               (ash word -20)))
  89           ((U8_U8_U8_U8)
  90            #'((logand (ash word -8) #xff)
  91               (logand (ash word -16) #xff)
  92               (ash word -24)))
  93           (else
  94            (error "bad kind" type)))))
  95
  96     (define (parse-tail-word word type)
  97       (with-syntax ((word word))
  98         (case type
  99           ((U8_X24)
 100            #'((logand word #ff)))
 101           ((U8_U24)
 102            #'((logand word #xff)
 103               (ash word -8)))
 104           ((U8_L24)
 105            #'((logand word #xff)
 106               (unpack-s24 (ash word -8))))
 107           ((U8_U8_I16)
 108            #'((logand word #xff)
 109               (logand (ash word -8) #xff)
 110               (ash word -16)))
 111           ((U8_U12_U12)
 112            #'((logand word #xff)
 113               (logand (ash word -8) #xfff)
 114               (ash word -20)))
 115           ((U8_U8_U8_U8)
 116            #'((logand word #xff)
 117               (logand (ash word -8) #xff)
 118               (logand (ash word -16) #xff)
 119               (ash word -24)))
 120           ((U32)
 121            #'(word))
 122           ((I32)
 123            #'(word))
 124           ((A32)
 125            #'(word))
 126           ((B32)
 127            #'(word))
 128           ((N32)
 129            #'((unpack-s32 word)))
 130           ((S32)
 131            #'((unpack-s32 word)))
 132           ((L32)
 133            #'((unpack-s32 word)))
 134           ((LO32)
 135            #'((unpack-s32 word)))
 136           ((X8_U24)
 137            #'((ash word -8)))
 138           ((X8_U12_U12)
 139            #'((logand (ash word -8) #xfff)
 140               (ash word -20)))
 141           ((X8_L24)
 142            #'((unpack-s24 (ash word -8))))
 143           ((B1_X7_L24)
 144            #'((not (zero? (logand word #x1)))
 145               (unpack-s24 (ash word -8))))
 146           ((B1_U7_L24)
 147            #'((not (zero? (logand word #x1)))
 148               (logand (ash word -1) #x7f)
 149               (unpack-s24 (ash word -8))))
 150           ((B1_X31)
 151            #'((not (zero? (logand word #x1)))))
 152           ((B1_X7_U24)
 153            #'((not (zero? (logand word #x1)))
 154               (ash word -8)))
 155           (else
 156            (error "bad kind" type)))))
 157
 158     (syntax-case x ()
 159       ((_ name opcode word0 word* ...)
 160        (let ((vars (generate-temporaries #'(word* ...))))
 161          (with-syntax (((word* ...) vars)
 162                        ((n ...) (map 1+ (iota (length #'(word* ...)))))
 163                        ((asm ...)
 164                         (parse-first-word #'first (syntax->datum #'word0)))
 165                        (((asm* ...) ...)
 166                         (map (lambda (word type)
 167                                (parse-tail-word word type))
 168                              vars
 169                              (syntax->datum #'(word* ...)))))
 170            #'(lambda (buf offset first)
 171                (let ((word* (u32-ref buf (+ offset n)))
 172                      ...)
 173                  (values (+ 1 (length '(word* ...)))
 174                          (list 'name asm ... asm* ... ...))))))))))
 175
 176 (define (disasm-invalid buf offset first)
 177   (error "bad instruction" (logand first #xff) first buf offset))
 178
 179 (define disassemblers (make-vector 256 disasm-invalid))
 180
 181 (define-syntax define-disassembler
 182   (lambda (x)
 183     (syntax-case x ()
 184       ((_ name opcode kind arg ...)
 185        (with-syntax ((parse (id-append #'name #'parse- #'name)))
 186          #'(let ((parse (disassembler name opcode arg ...)))
 187              (vector-set! disassemblers opcode parse)))))))
 188
 189 (visit-opcodes define-disassembler)
 190
 191 ;; -> len list
 192 (define (disassemble-one buf offset)
 193   (let ((first (u32-ref buf offset)))
 194     ((vector-ref disassemblers (logand first #xff)) buf offset first)))
 195
 196 (define (u32-offset->addr offset context)
 197   "Given an offset into an image in 32-bit units, return the absolute
 198 address of that offset."
 199   (+ (debug-context-base context) (* offset 4)))
 200
 201 (define (code-annotation code len offset start labels context)
 202   ;; FIXME: Print names for register loads and stores that correspond to
 203   ;; access to named locals.
 204   (define (reference-scm target)
 205     (unpack-scm (u32-offset->addr (+ offset target) context)))
 206
 207   (define (dereference-scm target)
 208     (let ((addr (u32-offset->addr (+ offset target)
 209                                   context)))
 210       (pointer->scm
 211        (dereference-pointer (make-pointer addr)))))
 212
 213   (match code
 214     (((or 'br
 215           'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
 216           'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
 217           'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
 218           'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
 219      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
 220     (('prompt tag flags handler)
 221      ;; The H is for handler.
 222      (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
 223     (((or 'make-short-immediate 'make-long-immediate) _ imm)
 224      (list "~S" (unpack-scm imm)))
 225     (('make-long-long-immediate _ high low)
 226      (list "~S" (unpack-scm (logior (ash high 32) low))))
 227     (('assert-nargs-ee/locals nargs locals)
 228      ;; The nargs includes the procedure.
 229      (list "~a arg~:p, ~a local~:p" (1- nargs) locals))
 230     (('tail-call nargs proc)
 231      (list "~a arg~:p" nargs))
 232     (('make-closure dst target nfree)
 233      (let* ((addr (u32-offset->addr (+ offset target) context))
 234             (pdi (find-program-debug-info addr context)))
 235        ;; FIXME: Disassemble embedded closures as well.
 236        (list "~A at 0x~X (~A free var~:p)"
 237              (or (and pdi (program-debug-info-name pdi))
 238                  "(anonymous procedure)")
 239              addr
 240              nfree)))
 241     (('make-non-immediate dst target)
 242      (list "~@Y" (reference-scm target)))
 243     (((or 'static-ref 'static-set!) _ target)
 244      (list "~@Y" (dereference-scm target)))
 245     (('link-procedure! src target)
 246      (let* ((addr (u32-offset->addr (+ offset target) context))
 247             (pdi (find-program-debug-info addr context)))
 248        (list "~A at 0x~X"
 249              (or (and pdi (program-debug-info-name pdi))
 250                  "(anonymous procedure)")
 251              addr)))
 252     (('resolve-module dst name public)
 253      (list "~a" (if (zero? public) "private" "public")))
 254     (('toplevel-box _ var-offset mod-offset sym-offset bound?)
 255      (list "`~A'~A" (dereference-scm sym-offset)
 256            (if bound? "" " (maybe unbound)")))
 257     (('module-box _ var-offset mod-name-offset sym-offset bound?)
 258      (let ((mod-name (reference-scm mod-name-offset)))
 259        (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
 260              (dereference-scm sym-offset)
 261              (if bound? "" " (maybe unbound)"))))
 262     (('load-typed-array dst type shape target len)
 263      (let ((addr (u32-offset->addr (+ offset target) context)))
 264        (list "~a bytes from #x~X" len addr)))
 265     (_ #f)))
 266
 267 (define (compute-labels bv start end)
 268   (let ((labels (make-vector (- end start) #f)))
 269     (define (add-label! pos header)
 270       (unless (vector-ref labels (- pos start))
 271         (vector-set! labels (- pos start) header)))
 272
 273     (let lp ((offset start))
 274       (when (< offset end)
 275         (call-with-values (lambda () (disassemble-one bv offset))
 276           (lambda (len elt)
 277             (match elt
 278               ((inst arg ...)
 279                (case inst
 280                  ((br
 281                    br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
 282                    br-if-true br-if-null br-if-nil br-if-pair br-if-struct
 283                    br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
 284                    br-if-= br-if-< br-if-<= br-if-> br-if->=)
 285                   (match arg
 286                     ((_ ... target)
 287                      (add-label! (+ offset target) "L"))))
 288                  ((prompt)
 289                   (match arg
 290                     ((_ ... target)
 291                      (add-label! (+ offset target) "H")))))))
 292             (lp (+ offset len))))))
 293     (let lp ((offset start) (n 1))
 294       (when (< offset end)
 295         (let* ((pos (- offset start))
 296                (label (vector-ref labels pos)))
 297           (if label
 298               (begin
 299                 (vector-set! labels
 300                              pos
 301                              (string->symbol
 302                               (string-append label (number->string n))))
 303                 (lp (1+ offset) (1+ n)))
 304               (lp (1+ offset) n)))))
 305     labels))
 306
 307 (define (print-info port addr label info extra src)
 308   (when label
 309     (format port "~A:\n" label))
 310   (format port "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
 311           addr info extra src))
 312
 313 (define (disassemble-buffer port bv start end context)
 314   (let ((labels (compute-labels bv start end))
 315         (sources (find-program-sources (u32-offset->addr start context)
 316                                        context)))
 317     (define (lookup-source addr)
 318       (let lp ((sources sources))
 319         (match sources
 320           (() #f)
 321           ((source . sources)
 322            (let ((pc (source-pre-pc source)))
 323              (cond
 324               ((< pc addr) (lp sources))
 325               ((= pc addr)
 326                (format #f "~a:~a:~a"
 327                        (source-file source)
 328                        (source-line-for-user source)
 329                        (source-column source)))
 330               (else #f)))))))
 331     (let lp ((offset start))
 332       (when (< offset end)
 333         (call-with-values (lambda () (disassemble-one bv offset))
 334           (lambda (len elt)
 335             (let ((pos (- offset start))
 336                   (addr (u32-offset->addr offset context))
 337                   (annotation (code-annotation elt len offset start labels
 338                                                context)))
 339               (print-info port pos (vector-ref labels pos) elt annotation
 340                           (lookup-source addr))
 341               (lp (+ offset len)))))))))
 342
 343 (define* (disassemble-program program #:optional (port (current-output-port)))
 344   (cond
 345    ((find-program-debug-info (rtl-program-code program))
 346     => (lambda (pdi)
 347          (format port "Disassembly of ~S at #x~X:\n\n" program
 348                  (program-debug-info-addr pdi))
 349          (disassemble-buffer port
 350                              (program-debug-info-image pdi)
 351                              (program-debug-info-u32-offset pdi)
 352                              (program-debug-info-u32-offset-end pdi)
 353                              (program-debug-info-context pdi))))
 354    (else
 355     (format port "Debugging information unavailable.~%")))
 356   (values))
 357
 358 (define* (disassemble-image bv #:optional (port (current-output-port)))
 359   (let* ((ctx (debug-context-from-image bv))
 360          (base (debug-context-text-base ctx)))
 361     (for-each-elf-symbol
 362      ctx
 363      (lambda (sym)
 364        (let ((name (elf-symbol-name sym))
 365              (value (elf-symbol-value sym))
 366              (size (elf-symbol-size sym)))
 367          (format port "Disassembly of ~A at #x~X:\n\n"
 368                  (if (and (string? name) (not (string-null? name)))
 369                      name
 370                      "<unnamed function>")
 371                  (+ base value))
 372          (disassemble-buffer port
 373                              bv
 374                              (/ (+ base value) 4)
 375                              (/ (+ base value size) 4)
 376                              ctx)
 377          (display "\n\n" port)))))
 378   (values))
 379
 380 (define (disassemble-file file)
 381   (let* ((thunk (load-thunk-from-file file))
 382          (elf (find-mapped-elf-image (rtl-program-code thunk))))
 383     (disassemble-image elf)))