module/language/assembly/disassemble.scm

   1 ;;; Guile VM code converters
   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 (language assembly disassemble)
  22   #:use-module (ice-9 format)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (system vm instruction)
  25   #:use-module (system vm program)
  26   #:use-module (system base pmatch)
  27   #:use-module (language assembly)
  28   #:use-module (system base compile)
  29   #:export (disassemble))
  30
  31 (define (disassemble x)
  32   (format #t "Disassembly of ~A:\n\n" x)
  33   (call-with-values
  34       (lambda () (decompile x #:from 'value #:to 'assembly))
  35     disassemble-load-program))
  36
  37 (define (disassemble-load-program asm env)
  38   (pmatch asm
  39     ((load-program ,labels ,len ,meta . ,code)
  40      (let ((objs  (and env (assq-ref env 'objects)))
  41            (free-vars (and env (assq-ref env 'free-vars)))
  42            (meta  (and env (assq-ref env 'meta)))
  43            (blocs (and env (assq-ref env 'blocs)))
  44            (srcs  (and env (assq-ref env 'sources))))
  45        (let lp ((pos 0) (code code) (programs '()))
  46          (cond
  47           ((null? code)
  48            (newline)
  49            (for-each
  50             (lambda (sym+asm)
  51               (format #t "Embedded program ~A:\n\n" (car sym+asm))
  52               (disassemble-load-program (cdr sym+asm) '()))
  53             (reverse! programs)))
  54           (else
  55            (let* ((asm (car code))
  56                   (len (byte-length asm))
  57                   (end (+ pos len)))
  58              (pmatch asm
  59                ((load-program . _)
  60                 (let ((sym (gensym "")))
  61                   (print-info pos `(load-program ,sym) #f #f)
  62                   (lp (+ pos (byte-length asm)) (cdr code)
  63                       (acons sym asm programs))))
  64                ((nop)
  65                 (lp (+ pos (byte-length asm)) (cdr code) programs))
  66                (else
  67                 (print-info pos asm
  68                             ;; FIXME: code-annotation for whether it's
  69                             ;; an arg or not, currently passing nargs=-1
  70                             (code-annotation end asm objs -1 blocs
  71                                              labels)
  72                             (and=> (and srcs (assq end srcs)) source->string))
  73                 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
  74
  75        (if (pair? free-vars)
  76            (disassemble-free-vars free-vars))
  77        (if meta
  78            (disassemble-meta meta))
  79
  80        ;; Disassemble other bytecode in it
  81        ;; FIXME: something about the module.
  82        (if objs
  83            (for-each
  84             (lambda (x)
  85               (if (program? x)
  86                   (begin (display "----------------------------------------\n")
  87                          (disassemble x))))
  88             (cdr (vector->list objs))))))
  89     (else
  90      (error "bad load-program form" asm))))
  91
  92 (define (disassemble-free-vars free-vars)
  93   (display "Free variables:\n\n")
  94   (fold (lambda (free-var i)
  95           (print-info i free-var #f #f)
  96           (+ 1 i))
  97         0
  98         free-vars))
  99
 100 (define-macro (unless test . body)
 101   `(if (not ,test) (begin ,@body)))
 102
 103 (define *uninteresting-props* '(name))
 104
 105 (define (disassemble-meta meta)
 106   (let ((props (filter (lambda (x)
 107                          (not (memq (car x) *uninteresting-props*)))
 108                        (cdddr meta))))
 109     (unless (null? props)
 110       (display "Properties:\n\n")
 111       (for-each (lambda (x) (print-info #f x #f #f)) props)
 112       (newline))))
 113
 114 (define (source->string src)
 115   (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
 116           (source:line-for-user src) (source:column src)))
 117
 118 (define (make-int16 byte1 byte2)
 119   (+ (* byte1 256) byte2))
 120
 121 (define (code-annotation end-addr code objs nargs blocs labels)
 122   (let* ((code (assembly-unpack code))
 123          (inst (car code))
 124          (args (cdr code)))
 125     (case inst
 126       ((list vector)
 127        (list "~a element~:p" (apply make-int16 args)))
 128       ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
 129        (list "-> ~A" (assq-ref labels (car args))))
 130       ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
 131        (list "-> ~A" (assq-ref labels (caddr args))))
 132       ((bind-optionals/shuffle-or-br)
 133        (list "-> ~A" (assq-ref labels (car (last-pair args)))))
 134       ((object-ref)
 135        (and objs (list "~s" (vector-ref objs (car args)))))
 136       ((local-ref local-boxed-ref local-set local-boxed-set)
 137        (and blocs
 138             (let lp ((bindings (list-ref blocs (car args))))
 139               (and (pair? bindings)
 140                    (let ((b (car bindings)))
 141                      (if (and (< (binding:start (car bindings)) end-addr)
 142                               (>= (binding:end (car bindings)) end-addr))
 143                          (list "`~a'~@[ (arg)~]"
 144                                (binding:name b) (< (binding:index b) nargs))
 145                          (lp (cdr bindings))))))))
 146       ((assert-nargs-ee/locals assert-nargs-ge/locals)
 147        (list "~a arg~:p, ~a local~:p"
 148              (logand (car args) #x7) (ash (car args) -3)))
 149       ((free-ref free-boxed-ref free-boxed-set)
 150        ;; FIXME: we can do better than this
 151        (list "(closure variable)"))
 152       ((toplevel-ref toplevel-set)
 153        (and objs
 154             (let ((v (vector-ref objs (car args))))
 155               (if (and (variable? v) (variable-bound? v))
 156                   (list "~s" (variable-ref v))
 157                   (list "`~s'" v)))))
 158       ((mv-call)
 159        (list "MV -> ~A" (assq-ref labels (cadr args))))
 160       ((prompt)
 161        ;; the H is for handler
 162        (list "H -> ~A" (assq-ref labels (cadr args))))
 163       (else
 164        (and=> (assembly->object code)
 165               (lambda (obj) (list "~s" obj)))))))
 166
 167 ;; i am format's daddy.
 168 (define (print-info addr info extra src)
 169   (format #t "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))