lisp/emacs-lisp/disass.el

   1 ;;; disass.el --- disassembler for compiled Emacs Lisp code
   2
   3 ;; Copyright (C) 1986, 1991, 2002-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Doug Cutting <doug@csli.stanford.edu>
   6 ;;      Jamie Zawinski <jwz@lucid.com>
   7 ;; Maintainer: FSF
   8 ;; Keywords: internal
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; The single entry point, `disassemble', disassembles a code object generated
  28 ;; by the Emacs Lisp byte-compiler.  This doesn't invert the compilation
  29 ;; operation, not by a long shot, but it's useful for debugging.
  30
  31 ;;
  32 ;; Original version by Doug Cutting (doug@csli.stanford.edu)
  33 ;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
  34 ;; the new lapcode-based byte compiler.
  35
  36 ;;; Code:
  37
  38 (require 'macroexp)
  39
  40 ;;; The variable byte-code-vector is defined by the new bytecomp.el.
  41 ;;; The function byte-decompile-lapcode is defined in byte-opt.el.
  42 ;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
  43 (require 'byte-compile "bytecomp")
  44
  45 (defvar disassemble-column-1-indent 8 "*")
  46 (defvar disassemble-column-2-indent 10 "*")
  47
  48 (defvar disassemble-recursive-indent 3 "*")
  49
  50 ;;;###autoload
  51 (defun disassemble (object &optional buffer indent interactive-p)
  52   "Print disassembled code for OBJECT in (optional) BUFFER.
  53 OBJECT can be a symbol defined as a function, or a function itself
  54 \(a lambda expression or a compiled-function object).
  55 If OBJECT is not already compiled, we compile it, but do not
  56 redefine OBJECT if it is a symbol."
  57   (interactive (list (intern (completing-read "Disassemble function: "
  58                                               obarray 'fboundp t))
  59                      nil 0 t))
  60   (if (and (consp object) (not (eq (car object) 'lambda)))
  61       (setq object (list 'lambda () object)))
  62   (or indent (setq indent 0))           ;Default indent to zero
  63   (save-excursion
  64     (if (or interactive-p (null buffer))
  65         (with-output-to-temp-buffer "*Disassemble*"
  66           (set-buffer "*Disassemble*")
  67           (disassemble-internal object indent (not interactive-p)))
  68       (set-buffer buffer)
  69       (disassemble-internal object indent nil)))
  70   nil)
  71
  72
  73 (defun disassemble-internal (obj indent interactive-p)
  74   (let ((macro 'nil)
  75         (name 'nil)
  76         (doc 'nil)
  77         args)
  78     (while (symbolp obj)
  79       (setq name obj
  80             obj (symbol-function obj)))
  81     (if (subrp obj)
  82         (error "Can't disassemble #<subr %s>" name))
  83     (when (and (listp obj) (eq (car obj) 'autoload))
  84       (load (nth 1 obj))
  85       (setq obj (symbol-function name)))
  86     (if (eq (car-safe obj) 'macro)      ;handle macros
  87         (setq macro t
  88               obj (cdr obj)))
  89     (when (and (listp obj) (eq (car obj) 'closure))
  90       (error "Don't know how to compile an interpreted closure"))
  91     (if (and (listp obj) (eq (car obj) 'byte-code))
  92         (setq obj (list 'lambda nil obj)))
  93     (if (and (listp obj) (not (eq (car obj) 'lambda)))
  94         (error "not a function"))
  95     (if (consp obj)
  96         (if (assq 'byte-code obj)
  97             nil
  98           (if interactive-p (message (if name
  99                                          "Compiling %s's definition..."
 100                                        "Compiling definition...")
 101                                      name))
 102           (setq obj (byte-compile obj))
 103           (if interactive-p (message "Done compiling.  Disassembling..."))))
 104     (cond ((consp obj)
 105            (setq obj (cdr obj))         ;throw lambda away
 106            (setq args (car obj))        ;save arg list
 107            (setq obj (cdr obj)))
 108           ((byte-code-function-p obj)
 109            (setq args (aref obj 0)))
 110           (t (error "Compilation failed")))
 111     (if (zerop indent) ; not a nested function
 112         (progn
 113           (indent-to indent)
 114           (insert (format "byte code%s%s%s:\n"
 115                           (if (or macro name) " for" "")
 116                           (if macro " macro" "")
 117                           (if name (format " %s" name) "")))))
 118     (let ((doc (if (consp obj)
 119                    (and (stringp (car obj)) (car obj))
 120                  ;; Use documentation to get lazy-loaded doc string
 121                  (documentation obj t))))
 122       (if (and doc (stringp doc))
 123           (progn (and (consp obj) (setq obj (cdr obj)))
 124                  (indent-to indent)
 125                  (princ "  doc:  " (current-buffer))
 126                  (if (string-match "\n" doc)
 127                      (setq doc (concat (substring doc 0 (match-beginning 0))
 128                                        " ...")))
 129                  (insert doc "\n"))))
 130     (indent-to indent)
 131     (insert "  args: ")
 132     (prin1 args (current-buffer))
 133     (insert "\n")
 134     (let ((interactive (cond ((consp obj)
 135                               (assq 'interactive obj))
 136                              ((> (length obj) 5)
 137                               (list 'interactive (aref obj 5))))))
 138       (if interactive
 139           (progn
 140             (setq interactive (nth 1 interactive))
 141             (if (eq (car-safe (car-safe obj)) 'interactive)
 142                 (setq obj (cdr obj)))
 143             (indent-to indent)
 144             (insert " interactive: ")
 145             (if (eq (car-safe interactive) 'byte-code)
 146                 (progn
 147                   (insert "\n")
 148                   (disassemble-1 interactive
 149                                  (+ indent disassemble-recursive-indent)))
 150               (let ((print-escape-newlines t))
 151                 (prin1 interactive (current-buffer))))
 152             (insert "\n"))))
 153     (cond ((and (consp obj) (assq 'byte-code obj))
 154            (disassemble-1 (assq 'byte-code obj) indent))
 155           ((byte-code-function-p obj)
 156            (disassemble-1 obj indent))
 157           (t
 158            (insert "Uncompiled body:  ")
 159            (let ((print-escape-newlines t))
 160              (prin1 (macroexp-progn obj)
 161                     (current-buffer))))))
 162   (if interactive-p
 163       (message "")))
 164
 165
 166 (defun disassemble-1 (obj indent)
 167   "Prints the byte-code call OBJ in the current buffer.
 168 OBJ should be a call to BYTE-CODE generated by the byte compiler."
 169   (let (bytes constvec)
 170     (if (consp obj)
 171         (setq bytes (car (cdr obj))             ;the byte code
 172               constvec (car (cdr (cdr obj))))   ;constant vector
 173       ;; If it is lazy-loaded, load it now
 174       (fetch-bytecode obj)
 175       (setq bytes (aref obj 1)
 176             constvec (aref obj 2)))
 177     (let ((lap (byte-decompile-bytecode (string-as-unibyte bytes) constvec))
 178           op arg opname pc-value)
 179       (let ((tagno 0)
 180             tmp
 181             (lap lap))
 182         (while (setq tmp (assq 'TAG lap))
 183           (setcar (cdr tmp) (setq tagno (1+ tagno)))
 184           (setq lap (cdr (memq tmp lap)))))
 185       (while lap
 186         ;; Take off the pc value of the next thing
 187         ;; and put it in pc-value.
 188         (setq pc-value nil)
 189         (if (numberp (car lap))
 190             (setq pc-value (car lap)
 191                   lap (cdr lap)))
 192         ;; Fetch the next op and its arg.
 193         (setq op (car (car lap))
 194               arg (cdr (car lap)))
 195         (setq lap (cdr lap))
 196         (indent-to indent)
 197         (if (eq 'TAG op)
 198             (progn
 199               ;; We have a label.  Display it, but first its pc value.
 200               (if pc-value
 201                   (insert (format "%d:" pc-value)))
 202               (insert (int-to-string (car arg))))
 203           ;; We have an instruction.  Display its pc value first.
 204           (if pc-value
 205               (insert (format "%d" pc-value)))
 206           (indent-to (+ indent disassemble-column-1-indent))
 207           (if (and op
 208                    (string-match "^byte-" (setq opname (symbol-name op))))
 209               (setq opname (substring opname 5))
 210             (setq opname "<not-an-opcode>"))
 211           (if (eq op 'byte-constant2)
 212               (insert " #### shouldn't have seen constant2 here!\n  "))
 213           (insert opname)
 214           (indent-to (+ indent disassemble-column-1-indent
 215                         disassemble-column-2-indent
 216                         -1))
 217           (insert " ")
 218           (cond ((memq op byte-goto-ops)
 219                  (insert (int-to-string (nth 1 arg))))
 220                 ((memq op '(byte-call byte-unbind
 221                             byte-listN byte-concatN byte-insertN
 222                             byte-stack-ref byte-stack-set byte-stack-set2
 223                             byte-discardN byte-discardN-preserve-tos))
 224                  (insert (int-to-string arg)))
 225                 ((memq op '(byte-varref byte-varset byte-varbind))
 226                  (prin1 (car arg) (current-buffer)))
 227                 ((memq op '(byte-constant byte-constant2))
 228                  ;; it's a constant
 229                  (setq arg (car arg))
 230                  ;; but if the value of the constant is compiled code, then
 231                  ;; recursively disassemble it.
 232                  (cond ((or (byte-code-function-p arg)
 233                             (and (eq (car-safe arg) 'lambda)
 234                                  (assq 'byte-code arg))
 235                             (and (eq (car-safe arg) 'macro)
 236                                  (or (byte-code-function-p (cdr arg))
 237                                      (and (eq (car-safe (cdr arg)) 'lambda)
 238                                           (assq 'byte-code (cdr arg))))))
 239                         (cond ((byte-code-function-p arg)
 240                                (insert "<compiled-function>\n"))
 241                               ((eq (car-safe arg) 'lambda)
 242                                (insert "<compiled lambda>"))
 243                               (t (insert "<compiled macro>\n")))
 244                         (disassemble-internal
 245                          arg
 246                          (+ indent disassemble-recursive-indent 1)
 247                          nil))
 248                        ((eq (car-safe arg) 'byte-code)
 249                         (insert "<byte code>\n")
 250                         (disassemble-1  ;recurse on byte-code object
 251                          arg
 252                          (+ indent disassemble-recursive-indent)))
 253                        ((eq (car-safe (car-safe arg)) 'byte-code)
 254                         (insert "(<byte code>...)\n")
 255                         (mapc ;recurse on list of byte-code objects
 256                          (lambda (obj)
 257                            (disassemble-1
 258                             obj
 259                             (+ indent disassemble-recursive-indent)))
 260                          arg))
 261                        (t
 262                         ;; really just a constant
 263                         (let ((print-escape-newlines t))
 264                           (prin1 arg (current-buffer))))))
 265                 )
 266           (insert "\n")))))
 267   nil)
 268
 269 (provide 'disass)
 270
 271 ;;; disass.el ends here