[bpt/guile.git] / module / 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-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
          ((U8_X24)
           #'())
          ((U8_U24)
           #'((ash word -8)))
          ((U8_L24)
           #'((unpack-s24 (ash word -8))))
          ((U8_U8_I16)
           #'((logand (ash word -8) #xff)
              (ash word -16)))
          ((U8_U12_U12)
           #'((logand (ash word -8) #xfff)
              (ash word -20)))
          ((U8_U8_U8_U8)
           #'((logand (ash word -8) #xff)
              (logand (ash word -16) #xff)
              (ash word -24)))
          (else
           (error "bad kind" type)))))

    (define (parse-tail-word word type)
      (with-syntax ((word word))
        (case type
          ((U8_X24)
           #'((logand word #ff)))
          ((U8_U24)
           #'((logand word #xff)
              (ash word -8)))
          ((U8_L24)
           #'((logand word #xff)
              (unpack-s24 (ash word -8))))
          ((U32)
           #'(word))
          ((I32)
           #'(word))
          ((A32)
           #'(word))
          ((B32)
           #'(word))
          ((N32)
           #'((unpack-s32 word)))
          ((S32)
           #'((unpack-s32 word)))
          ((L32)
           #'((unpack-s32 word)))
          ((LO32)
           #'((unpack-s32 word)))
          ((X8_U24)
           #'((ash word -8)))
          ((X8_L24)
           #'((unpack-s24 (ash word -8))))
          ((B1_X7_L24)
           #'((not (zero? (logand word #x1)))
              (unpack-s24 (ash word -8))))
          ((B1_U7_L24)
           #'((not (zero? (logand word #x1)))
              (logand (ash word -1) #x7f)
              (unpack-s24 (ash word -8))))
          ((B1_X31)
           #'((not (zero? (logand word #x1)))))
          ((B1_X7_U24)
           #'((not (zero? (logand word #x1)))
              (ash word -8)))
          (else
           (error "bad 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-equal
          'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
          '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?")
                        ((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 arg~:p, ~a local~:p" (1- nargs) locals))
    (('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-equal
                   br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
                  (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 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-clobber-parser
  (lambda (x)
    (syntax-case x ()
      ((_ name opcode kind arg ...)
       (case (syntax->datum #'kind)
         ((!)
          (case (syntax->datum #'name)
            ((call call-label)
             #'(let ((parse (lambda (code pos nslots)
                              (call-with-values
                                  (lambda ()
                                    (disassemble-one code (/ pos 4)))
                                (lambda (len elt)
                                  (match elt
                                    ((_ proc . _)
                                     (let lp ((slot (- proc 2)))
                                       (if (< slot nslots)
                                           (cons slot (lp (1+ slot)))
                                           '())))))))))
                 (vector-set! clobber-parsers opcode parse)))
            (else
             #'(begin))))
         ((<-)
          #'(let ((parse (lambda (code pos nslots)
                           (call-with-values
                               (lambda ()
                                 (disassemble-one code (/ pos 4)))
                             (lambda (len elt)
                               (match elt
                                 ((_ dst . _) (list dst))))))))
              (vector-set! clobber-parsers opcode parse)))
         (else (error "unexpected instruction kind" #'kind)))))))

(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
(visit-opcodes define-clobber-parser)

(define (instruction-slot-clobbers code pos nslots)
  (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
    ((vector-ref clobber-parsers opcode) code pos nslots)))
Commit	Line	Data
691697de	1	;;; Guile bytecode disassembler
82e299f3	2
e2fafeb9	3	;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
82e299f3 AW	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)
691697de	22	#:use-module (language bytecode)
82e299f3 AW	23	#:use-module (system vm elf)
	24	#:use-module (system vm debug)
	25	#:use-module (system vm program)
4cbc95f1	26	#:use-module (system vm loader)
82e299f3 AW	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)
610295ec	34	#:export (disassemble-program
850e80da	35	fold-program-code
93009a7a	36	disassemble-image
20d7d682 AW	37	disassemble-file
	38
	39	instruction-length
	40	instruction-has-fallthrough?
	41	instruction-relative-jump-targets
	42	instruction-slot-clobbers))
82e299f3 AW	43
	44	(define-syntax-rule (u32-ref buf n)
	45	(bytevector-u32-native-ref buf (* n 4)))
	46
	47	(define-syntax-rule (s32-ref buf n)
	48	(bytevector-s32-native-ref buf (* n 4)))
	49
	50	(define-syntax visit-opcodes
	51	(lambda (x)
	52	(syntax-case x ()
	53	((visit-opcodes macro arg ...)
	54	(with-syntax (((inst ...)
	55	(map (lambda (x) (datum->syntax #'macro x))
1b780c13	56	(instruction-list))))
82e299f3 AW	57	#'(begin
	58	(macro arg ... . inst)
	59	...))))))
	60
	61	(eval-when (expand compile load eval)
	62	(define (id-append ctx a b)
	63	(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
	64
	65	(define (unpack-scm n)
	66	(pointer->scm (make-pointer n)))
	67
	68	(define (unpack-s24 s)
	69	(if (zero? (logand s (ash 1 23)))
	70	s
	71	(- s (ash 1 24))))
	72
	73	(define (unpack-s32 s)
	74	(if (zero? (logand s (ash 1 31)))
	75	s
	76	(- s (ash 1 32))))
	77
	78	(define-syntax disassembler
	79	(lambda (x)
	80	(define (parse-first-word word type)
	81	(with-syntax ((word word))
	82	(case type
	83	((U8_X24)
	84	#'())
	85	((U8_U24)
	86	#'((ash word -8)))
	87	((U8_L24)
	88	#'((unpack-s24 (ash word -8))))
82e299f3 AW	89	((U8_U8_I16)
	90	#'((logand (ash word -8) #xff)
	91	(ash word -16)))
	92	((U8_U12_U12)
	93	#'((logand (ash word -8) #xfff)
	94	(ash word -20)))
	95	((U8_U8_U8_U8)
	96	#'((logand (ash word -8) #xff)
	97	(logand (ash word -16) #xff)
	98	(ash word -24)))
	99	(else
	100	(error "bad kind" type)))))
	101
	102	(define (parse-tail-word word type)
	103	(with-syntax ((word word))
	104	(case type
	105	((U8_X24)
	106	#'((logand word #ff)))
	107	((U8_U24)
	108	#'((logand word #xff)
	109	(ash word -8)))
	110	((U8_L24)
	111	#'((logand word #xff)
	112	(unpack-s24 (ash word -8))))
82e299f3 AW	113	((U32)
	114	#'(word))
	115	((I32)
	116	#'(word))
	117	((A32)
	118	#'(word))
	119	((B32)
	120	#'(word))
	121	((N32)
	122	#'((unpack-s32 word)))
	123	((S32)
	124	#'((unpack-s32 word)))
	125	((L32)
	126	#'((unpack-s32 word)))
	127	((LO32)
	128	#'((unpack-s32 word)))
	129	((X8_U24)
	130	#'((ash word -8)))
82e299f3 AW	131	((X8_L24)
	132	#'((unpack-s24 (ash word -8))))
	133	((B1_X7_L24)
	134	#'((not (zero? (logand word #x1)))
	135	(unpack-s24 (ash word -8))))
	136	((B1_U7_L24)
	137	#'((not (zero? (logand word #x1)))
	138	(logand (ash word -1) #x7f)
	139	(unpack-s24 (ash word -8))))
af95414f AW	140	((B1_X31)
	141	#'((not (zero? (logand word #x1)))))
	142	((B1_X7_U24)
	143	#'((not (zero? (logand word #x1)))
	144	(ash word -8)))
82e299f3 AW	145	(else
	146	(error "bad kind" type)))))
	147
	148	(syntax-case x ()
	149	((_ name opcode word0 word* ...)
	150	(let ((vars (generate-temporaries #'(word* ...))))
	151	(with-syntax (((word* ...) vars)
	152	((n ...) (map 1+ (iota (length #'(word* ...)))))
	153	((asm ...)
	154	(parse-first-word #'first (syntax->datum #'word0)))
	155	(((asm* ...) ...)
	156	(map (lambda (word type)
	157	(parse-tail-word word type))
	158	vars
	159	(syntax->datum #'(word* ...)))))
	160	#'(lambda (buf offset first)
	161	(let ((word* (u32-ref buf (+ offset n)))
	162	...)
	163	(values (+ 1 (length '(word* ...)))
	164	(list 'name asm ... asm* ... ...))))))))))
	165
	166	(define (disasm-invalid buf offset first)
	167	(error "bad instruction" (logand first #xff) first buf offset))
	168
	169	(define disassemblers (make-vector 256 disasm-invalid))
	170
	171	(define-syntax define-disassembler
	172	(lambda (x)
	173	(syntax-case x ()
2a294c7c	174	((_ name opcode kind arg ...)
82e299f3 AW	175	(with-syntax ((parse (id-append #'name #'parse- #'name)))
	176	#'(let ((parse (disassembler name opcode arg ...)))
	177	(vector-set! disassemblers opcode parse)))))))
	178
	179	(visit-opcodes define-disassembler)
	180
	181	;; -> len list
	182	(define (disassemble-one buf offset)
	183	(let ((first (u32-ref buf offset)))
78ff7847	184	((vector-ref disassemblers (logand first #xff)) buf offset first)))
82e299f3 AW	185
	186	(define (u32-offset->addr offset context)
	187	"Given an offset into an image in 32-bit units, return the absolute
	188	address of that offset."
	189	(+ (debug-context-base context) (* offset 4)))
	190
321c32dc	191	(define (code-annotation code len offset start labels context push-addr!)
82e299f3 AW	192	;; FIXME: Print names for register loads and stores that correspond to
	193	;; access to named locals.
	194	(define (reference-scm target)
	195	(unpack-scm (u32-offset->addr (+ offset target) context)))
	196
	197	(define (dereference-scm target)
	198	(let ((addr (u32-offset->addr (+ offset target)
	199	context)))
	200	(pointer->scm
	201	(dereference-pointer (make-pointer addr)))))
	202
	203	(match code
	204	(((or 'br
	205	'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
	206	'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
be8b62ca	207	'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
8c6206f3 AW	208	'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
8c6206f3 AW	209	'br-if-logtest) _ ... target)
82e299f3	210	(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
be8b62ca AW	211	(('br-if-tc7 slot invert? tc7 target)
	212	(list "~A -> ~A"
	213	(let ((tag (case tc7
	214	((5) "symbol?")
	215	((7) "variable?")
	216	((13) "vector?")
	217	((15) "string?")
e2fafeb9	218	((53) "keyword?")
becce37b	219	((77) "bytevector?")
d65514a2	220	((95) "bitvector?")
be8b62ca AW	221	(else (number->string tc7)))))
	222	(if invert? (string-append "not " tag) tag))
	223	(vector-ref labels (- (+ offset target) start))))
8d59d55e	224	(('prompt tag escape-only? proc-slot handler)
82e299f3 AW	225	;; The H is for handler.
	226	(list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
	227	(((or 'make-short-immediate 'make-long-immediate) _ imm)
	228	(list "~S" (unpack-scm imm)))
	229	(('make-long-long-immediate _ high low)
	230	(list "~S" (unpack-scm (logior (ash high 32) low))))
	231	(('assert-nargs-ee/locals nargs locals)
7396d216 AW	232	;; The nargs includes the procedure.
7396d216 AW	233	(list "~a arg~:p, ~a local~:p" (1- nargs) locals))
82e299f3 AW	234	(('tail-call nargs proc)
82e299f3 AW	235	(list "~a arg~:p" nargs))
7396d216	236	(('make-closure dst target nfree)
82e299f3	237	(let* ((addr (u32-offset->addr (+ offset target) context))
321c32dc AW	238	(pdi (find-program-debug-info addr context))
	239	(name (or (and pdi (program-debug-info-name pdi))
	240	"anonymous procedure")))
	241	(push-addr! addr name)
	242	(list "~A at #x~X (~A free var~:p)" name addr nfree)))
560bfa92 AW	243	(('call-label closure nlocals target)
	244	(let* ((addr (u32-offset->addr (+ offset target) context))
	245	(pdi (find-program-debug-info addr context))
	246	(name (or (and pdi (program-debug-info-name pdi))
	247	"anonymous procedure")))
	248	(push-addr! addr name)
	249	(list "~A at #x~X" name addr)))
	250	(('tail-call-label nlocals target)
	251	(let* ((addr (u32-offset->addr (+ offset target) context))
	252	(pdi (find-program-debug-info addr context))
	253	(name (or (and pdi (program-debug-info-name pdi))
	254	"anonymous procedure")))
	255	(push-addr! addr name)
	256	(list "~A at #x~X" name addr)))
82e299f3	257	(('make-non-immediate dst target)
321c32dc AW	258	(let ((val (reference-scm target)))
	259	(when (program? val)
	260	(push-addr! (program-code val) val))
	261	(list "~@Y" val)))
486013d6 AW	262	(('builtin-ref dst idx)
486013d6 AW	263	(list "~A" (builtin-index->name idx)))
82e299f3 AW	264	(((or 'static-ref 'static-set!) _ target)
82e299f3 AW	265	(list "~@Y" (dereference-scm target)))
321c32dc AW	266	(((or 'free-ref 'free-set!) _ _ index)
321c32dc AW	267	(list "free var ~a" index))
82e299f3 AW	268	(('resolve-module dst name public)
82e299f3 AW	269	(list "~a" (if (zero? public) "private" "public")))
af95414f AW	270	(('toplevel-box _ var-offset mod-offset sym-offset bound?)
	271	(list "`~A'~A" (dereference-scm sym-offset)
	272	(if bound? "" " (maybe unbound)")))
	273	(('module-box _ var-offset mod-name-offset sym-offset bound?)
82e299f3	274	(let ((mod-name (reference-scm mod-name-offset)))
af95414f AW	275	(list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
	276	(dereference-scm sym-offset)
	277	(if bound? "" " (maybe unbound)"))))
82e299f3 AW	278	(('load-typed-array dst type shape target len)
	279	(let ((addr (u32-offset->addr (+ offset target) context)))
	280	(list "~a bytes from #x~X" len addr)))
	281	(_ #f)))
	282
	283	(define (compute-labels bv start end)
	284	(let ((labels (make-vector (- end start) #f)))
	285	(define (add-label! pos header)
	286	(unless (vector-ref labels (- pos start))
	287	(vector-set! labels (- pos start) header)))
	288
	289	(let lp ((offset start))
	290	(when (< offset end)
	291	(call-with-values (lambda () (disassemble-one bv offset))
	292	(lambda (len elt)
	293	(match elt
	294	((inst arg ...)
	295	(case inst
	296	((br
	297	br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
	298	br-if-true br-if-null br-if-nil br-if-pair br-if-struct
	299	br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
d613ccaa	300	br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
82e299f3 AW	301	(match arg
	302	((_ ... target)
	303	(add-label! (+ offset target) "L"))))
	304	((prompt)
	305	(match arg
	306	((_ ... target)
70a20431	307	(add-label! (+ offset target) "H")))))))
82e299f3 AW	308	(lp (+ offset len))))))
	309	(let lp ((offset start) (n 1))
	310	(when (< offset end)
	311	(let* ((pos (- offset start))
	312	(label (vector-ref labels pos)))
	313	(if label
	314	(begin
	315	(vector-set! labels
	316	pos
	317	(string->symbol
	318	(string-append label (number->string n))))
	319	(lp (1+ offset) (1+ n)))
	320	(lp (1+ offset) n)))))
	321	labels))
	322
	323	(define (print-info port addr label info extra src)
	324	(when label
	325	(format port "~A:\n" label))
	326	(format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
	327	addr info extra src))
	328
321c32dc	329	(define (disassemble-buffer port bv start end context push-addr!)
e9588e70 AW	330	(let ((labels (compute-labels bv start end))
	331	(sources (find-program-sources (u32-offset->addr start context)
	332	context)))
	333	(define (lookup-source addr)
	334	(let lp ((sources sources))
	335	(match sources
	336	(() #f)
	337	((source . sources)
	338	(let ((pc (source-pre-pc source)))
	339	(cond
	340	((< pc addr) (lp sources))
	341	((= pc addr)
	342	(format #f "~a:~a:~a"
1b1c9125	343	(or (source-file source) "(unknown file)")
e9588e70 AW	344	(source-line-for-user source)
	345	(source-column source)))
	346	(else #f)))))))
82e299f3 AW	347	(let lp ((offset start))
	348	(when (< offset end)
	349	(call-with-values (lambda () (disassemble-one bv offset))
	350	(lambda (len elt)
	351	(let ((pos (- offset start))
e9588e70	352	(addr (u32-offset->addr offset context))
82e299f3	353	(annotation (code-annotation elt len offset start labels
321c32dc	354	context push-addr!)))
e9588e70 AW	355	(print-info port pos (vector-ref labels pos) elt annotation
e9588e70 AW	356	(lookup-source addr))
82e299f3 AW	357	(lp (+ offset len)))))))))
82e299f3 AW	358
560bfa92	359	(define* (disassemble-addr addr label port #:optional (seen (make-hash-table)))
321c32dc	360	(format port "Disassembly of ~A at #x~X:\n\n" label addr)
82e299f3	361	(cond
321c32dc	362	((find-program-debug-info addr)
82e299f3	363	=> (lambda (pdi)
321c32dc AW	364	(let ((worklist '()))
321c32dc AW	365	(define (push-addr! addr label)
560bfa92 AW	366	(unless (hashv-ref seen addr)
560bfa92 AW	367	(hashv-set! seen addr #t)
321c32dc AW	368	(set! worklist (acons addr label worklist))))
	369	(disassemble-buffer port
	370	(program-debug-info-image pdi)
	371	(program-debug-info-u32-offset pdi)
	372	(program-debug-info-u32-offset-end pdi)
	373	(program-debug-info-context pdi)
	374	push-addr!)
	375	(for-each (match-lambda
	376	((addr . label)
	377	(display "\n----------------------------------------\n"
	378	port)
560bfa92	379	(disassemble-addr addr label port seen)))
321c32dc	380	worklist))))
82e299f3 AW	381	(else
	382	(format port "Debugging information unavailable.~%")))
	383	(values))
610295ec	384
321c32dc AW	385	(define* (disassemble-program program #:optional (port (current-output-port)))
	386	(disassemble-addr (program-code program) program port))
	387
850e80da AW	388	(define (fold-code-range proc seed bv start end context raw?)
	389	(define (cook code offset)
	390	(define (reference-scm target)
	391	(unpack-scm (u32-offset->addr (+ offset target) context)))
	392
	393	(define (dereference-scm target)
	394	(let ((addr (u32-offset->addr (+ offset target)
	395	context)))
	396	(pointer->scm
	397	(dereference-pointer (make-pointer addr)))))
	398	(match code
	399	(((or 'make-short-immediate 'make-long-immediate) dst imm)
	400	`(,(car code) ,dst ,(unpack-scm imm)))
	401	(('make-long-long-immediate dst high low)
	402	`(make-long-long-immediate ,dst
	403	,(unpack-scm (logior (ash high 32) low))))
	404	(('make-closure dst target nfree)
	405	`(make-closure ,dst
	406	,(u32-offset->addr (+ offset target) context)
	407	,nfree))
	408	(('make-non-immediate dst target)
	409	`(make-non-immediate ,dst ,(reference-scm target)))
	410	(('builtin-ref dst idx)
	411	`(builtin-ref ,dst ,(builtin-index->name idx)))
	412	(((or 'static-ref 'static-set!) dst target)
	413	`(,(car code) ,dst ,(dereference-scm target)))
	414	(('toplevel-box dst var-offset mod-offset sym-offset bound?)
	415	`(toplevel-box ,dst
	416	,(dereference-scm var-offset)
	417	,(dereference-scm mod-offset)
	418	,(dereference-scm sym-offset)
	419	,bound?))
	420	(('module-box dst var-offset mod-name-offset sym-offset bound?)
	421	(let ((mod-name (reference-scm mod-name-offset)))
	422	`(module-box ,dst
	423	,(dereference-scm var-offset)
	424	,(car mod-name)
	425	,(cdr mod-name)
	426	,(dereference-scm sym-offset)
	427	,bound?)))
	428	(_ code)))
	429	(let lp ((offset start) (seed seed))
	430	(cond
	431	((< offset end)
	432	(call-with-values (lambda () (disassemble-one bv offset))
	433	(lambda (len elt)
	434	(lp (+ offset len)
	435	(proc (if raw? elt (cook elt offset))
	436	seed)))))
	437	(else seed))))
	438
	439	(define* (fold-program-code proc seed program-or-addr #:key raw?)
	440	(cond
0bd1e9c6	441	((find-program-debug-info (if (program? program-or-addr)
d1100525	442	(program-code program-or-addr)
850e80da AW	443	program-or-addr))
	444	=> (lambda (pdi)
	445	(fold-code-range proc seed
	446	(program-debug-info-image pdi)
	447	(program-debug-info-u32-offset pdi)
	448	(program-debug-info-u32-offset-end pdi)
	449	(program-debug-info-context pdi)
	450	raw?)))
	451	(else seed)))
	452
610295ec AW	453	(define* (disassemble-image bv #:optional (port (current-output-port)))
	454	(let* ((ctx (debug-context-from-image bv))
	455	(base (debug-context-text-base ctx)))
	456	(for-each-elf-symbol
	457	ctx
	458	(lambda (sym)
	459	(let ((name (elf-symbol-name sym))
	460	(value (elf-symbol-value sym))
	461	(size (elf-symbol-size sym)))
	462	(format port "Disassembly of ~A at #x~X:\n\n"
	463	(if (and (string? name) (not (string-null? name)))
	464	name
	465	"<unnamed function>")
	466	(+ base value))
	467	(disassemble-buffer port
	468	bv
	469	(/ (+ base value) 4)
	470	(/ (+ base value size) 4)
321c32dc AW	471	ctx
321c32dc AW	472	(lambda (addr name) #t))
610295ec AW	473	(display "\n\n" port)))))
610295ec AW	474	(values))
93009a7a AW	475
	476	(define (disassemble-file file)
	477	(let* ((thunk (load-thunk-from-file file))
d1100525	478	(elf (find-mapped-elf-image (program-code thunk))))
93009a7a	479	(disassemble-image elf)))
20d7d682 AW	480
	481	(define-syntax instruction-lengths-vector
	482	(lambda (x)
	483	(syntax-case x ()
	484	((_)
	485	(let ((lengths (make-vector 256 #f)))
	486	(for-each (match-lambda
	487	((name opcode kind words ...)
	488	(vector-set! lengths opcode (* 4 (length words)))))
	489	(instruction-list))
	490	(datum->syntax x lengths))))))
	491
	492	(define (instruction-length code pos)
	493	(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
	494	(or (vector-ref (instruction-lengths-vector) opcode)
	495	(error "Unknown opcode" opcode))))
	496
	497	(define-syntax static-opcode-set
	498	(lambda (x)
	499	(define (instruction-opcode inst)
	500	(cond
	501	((assq inst (instruction-list))
	502	=> (match-lambda ((name opcode . _) opcode)))
	503	(else
	504	(error "unknown instruction" inst))))
	505
	506	(syntax-case x ()
	507	((static-opcode-set inst ...)
	508	(let ((bv (make-bitvector 256 #f)))
	509	(for-each (lambda (inst)
	510	(bitvector-set! bv (instruction-opcode inst) #t))
	511	(syntax->datum #'(inst ...)))
	512	(datum->syntax #'static-opcode-set bv))))))
	513
	514	(define (instruction-has-fallthrough? code pos)
	515	(define non-fallthrough-set
	516	(static-opcode-set halt
	517	tail-call tail-call-label tail-call/shuffle
	518	return return-values
	519	subr-call foreign-call continuation-call
	520	tail-apply
	521	br))
	522	(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
	523	(not (bitvector-ref non-fallthrough-set opcode))))
	524
	525	(define-syntax define-jump-parser
	526	(lambda (x)
	527	(syntax-case x ()
	528	((_ name opcode kind word0 word* ...)
	529	(let ((symname (syntax->datum #'name)))
	530	(if (or (memq symname '(br prompt))
	531	(string-prefix? "br-" (symbol->string symname)))
	532	(let ((offset (* 4 (length #'(word* ...)))))
	533	#`(vector-set!
	534	jump-parsers
	535	opcode
	536	(lambda (code pos)
	537	(let ((target
	538	(bytevector-s32-native-ref code (+ pos #,offset))))
	539	;; Assume that the target is in the last word, as
	540	;; an L24 in the high bits.
	541	(list (* 4 (ash target -8)))))))
	542	#'(begin)))))))
	543
544	(define jump-parsers (make-vector 256 (lambda (code pos) '())))
545	(visit-opcodes define-jump-parser)
546
547	(define (instruction-relative-jump-targets code pos)
548	(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
549	((vector-ref jump-parsers opcode) code pos)))
550
551	(define-syntax define-clobber-parser
552	(lambda (x)
553	(syntax-case x ()
554	((_ name opcode kind arg ...)
555	(case (syntax->datum #'kind)
556	((!)
557	(case (syntax->datum #'name)
558	((call call-label)
559	#'(let ((parse (lambda (code pos nslots)
560	(call-with-values
561	(lambda ()
562	(disassemble-one code (/ pos 4)))
563	(lambda (len elt)
564	(match elt
565	((_ proc . _)
566	(let lp ((slot (- proc 2)))
567	(if (< slot nslots)
568	(cons slot (lp (1+ slot)))
569	'())))))))))
570	(vector-set! clobber-parsers opcode parse)))
571	(else
572	#'(begin))))
573	((<-)
574	#'(let ((parse (lambda (code pos nslots)
575	(call-with-values
576	(lambda ()
577	(disassemble-one code (/ pos 4)))
578	(lambda (len elt)
579	(match elt
580	((_ dst . _) (list dst))))))))
581	(vector-set! clobber-parsers opcode parse)))
582	(else (error "unexpected instruction kind" #'kind)))))))
583
584	(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
585	(visit-opcodes define-clobber-parser)
586
587	(define (instruction-slot-clobbers code pos nslots)
588	(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
589	((vector-ref clobber-parsers opcode) code pos nslots)))