| 1 | ;;; disass.el --- disassembler for compiled Emacs Lisp code |
| 2 | |
| 3 | ;; Copyright (C) 1986, 1991, 2002-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Doug Cutting <doug@csli.stanford.edu> |
| 6 | ;; Jamie Zawinski <jwz@lucid.com> |
| 7 | ;; Maintainer: emacs-devel@gnu.org |
| 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 | (setq obj (autoload-do-load obj name)) |
| 84 | (if (eq (car-safe obj) 'macro) ;Handle macros. |
| 85 | (setq macro t |
| 86 | obj (cdr obj))) |
| 87 | (if (and (listp obj) (eq (car obj) 'byte-code)) |
| 88 | (setq obj (list 'lambda nil obj))) |
| 89 | (if (and (listp obj) (not (eq (car obj) 'lambda))) |
| 90 | (error "not a function")) |
| 91 | (if (consp obj) |
| 92 | (if (assq 'byte-code obj) |
| 93 | nil |
| 94 | (if interactive-p (message (if name |
| 95 | "Compiling %s's definition..." |
| 96 | "Compiling definition...") |
| 97 | name)) |
| 98 | (setq obj (byte-compile obj)) |
| 99 | (if interactive-p (message "Done compiling. Disassembling...")))) |
| 100 | (cond ((consp obj) |
| 101 | (setq obj (cdr obj)) ;throw lambda away |
| 102 | (setq args (car obj)) ;save arg list |
| 103 | (setq obj (cdr obj))) |
| 104 | ((byte-code-function-p obj) |
| 105 | (setq args (aref obj 0))) |
| 106 | (t (error "Compilation failed"))) |
| 107 | (if (zerop indent) ; not a nested function |
| 108 | (progn |
| 109 | (indent-to indent) |
| 110 | (insert (format "byte code%s%s%s:\n" |
| 111 | (if (or macro name) " for" "") |
| 112 | (if macro " macro" "") |
| 113 | (if name (format " %s" name) ""))))) |
| 114 | (let ((doc (if (consp obj) |
| 115 | (and (stringp (car obj)) (car obj)) |
| 116 | ;; Use documentation to get lazy-loaded doc string |
| 117 | (documentation obj t)))) |
| 118 | (if (and doc (stringp doc)) |
| 119 | (progn (and (consp obj) (setq obj (cdr obj))) |
| 120 | (indent-to indent) |
| 121 | (princ " doc: " (current-buffer)) |
| 122 | (if (string-match "\n" doc) |
| 123 | (setq doc (concat (substring doc 0 (match-beginning 0)) |
| 124 | " ..."))) |
| 125 | (insert doc "\n")))) |
| 126 | (indent-to indent) |
| 127 | (insert " args: ") |
| 128 | (prin1 args (current-buffer)) |
| 129 | (insert "\n") |
| 130 | (let ((interactive (cond ((consp obj) |
| 131 | (assq 'interactive obj)) |
| 132 | ((> (length obj) 5) |
| 133 | (list 'interactive (aref obj 5)))))) |
| 134 | (if interactive |
| 135 | (progn |
| 136 | (setq interactive (nth 1 interactive)) |
| 137 | (if (eq (car-safe (car-safe obj)) 'interactive) |
| 138 | (setq obj (cdr obj))) |
| 139 | (indent-to indent) |
| 140 | (insert " interactive: ") |
| 141 | (if (eq (car-safe interactive) 'byte-code) |
| 142 | (progn |
| 143 | (insert "\n") |
| 144 | (disassemble-1 interactive |
| 145 | (+ indent disassemble-recursive-indent))) |
| 146 | (let ((print-escape-newlines t)) |
| 147 | (prin1 interactive (current-buffer)))) |
| 148 | (insert "\n")))) |
| 149 | (cond ((and (consp obj) (assq 'byte-code obj)) |
| 150 | (disassemble-1 (assq 'byte-code obj) indent)) |
| 151 | ((byte-code-function-p obj) |
| 152 | (disassemble-1 obj indent)) |
| 153 | (t |
| 154 | (insert "Uncompiled body: ") |
| 155 | (let ((print-escape-newlines t)) |
| 156 | (prin1 (macroexp-progn obj) |
| 157 | (current-buffer)))))) |
| 158 | (if interactive-p |
| 159 | (message ""))) |
| 160 | |
| 161 | |
| 162 | (defun disassemble-1 (obj indent) |
| 163 | "Prints the byte-code call OBJ in the current buffer. |
| 164 | OBJ should be a call to BYTE-CODE generated by the byte compiler." |
| 165 | (let (bytes constvec) |
| 166 | (if (consp obj) |
| 167 | (setq bytes (car (cdr obj)) ;the byte code |
| 168 | constvec (car (cdr (cdr obj)))) ;constant vector |
| 169 | ;; If it is lazy-loaded, load it now |
| 170 | (fetch-bytecode obj) |
| 171 | (setq bytes (aref obj 1) |
| 172 | constvec (aref obj 2))) |
| 173 | (let ((lap (byte-decompile-bytecode (string-as-unibyte bytes) constvec)) |
| 174 | op arg opname pc-value) |
| 175 | (let ((tagno 0) |
| 176 | tmp |
| 177 | (lap lap)) |
| 178 | (while (setq tmp (assq 'TAG lap)) |
| 179 | (setcar (cdr tmp) (setq tagno (1+ tagno))) |
| 180 | (setq lap (cdr (memq tmp lap))))) |
| 181 | (while lap |
| 182 | ;; Take off the pc value of the next thing |
| 183 | ;; and put it in pc-value. |
| 184 | (setq pc-value nil) |
| 185 | (if (numberp (car lap)) |
| 186 | (setq pc-value (car lap) |
| 187 | lap (cdr lap))) |
| 188 | ;; Fetch the next op and its arg. |
| 189 | (setq op (car (car lap)) |
| 190 | arg (cdr (car lap))) |
| 191 | (setq lap (cdr lap)) |
| 192 | (indent-to indent) |
| 193 | (if (eq 'TAG op) |
| 194 | (progn |
| 195 | ;; We have a label. Display it, but first its pc value. |
| 196 | (if pc-value |
| 197 | (insert (format "%d:" pc-value))) |
| 198 | (insert (int-to-string (car arg)))) |
| 199 | ;; We have an instruction. Display its pc value first. |
| 200 | (if pc-value |
| 201 | (insert (format "%d" pc-value))) |
| 202 | (indent-to (+ indent disassemble-column-1-indent)) |
| 203 | (if (and op |
| 204 | (string-match "^byte-" (setq opname (symbol-name op)))) |
| 205 | (setq opname (substring opname 5)) |
| 206 | (setq opname "<not-an-opcode>")) |
| 207 | (if (eq op 'byte-constant2) |
| 208 | (insert " #### shouldn't have seen constant2 here!\n ")) |
| 209 | (insert opname) |
| 210 | (indent-to (+ indent disassemble-column-1-indent |
| 211 | disassemble-column-2-indent |
| 212 | -1)) |
| 213 | (insert " ") |
| 214 | (cond ((memq op byte-goto-ops) |
| 215 | (insert (int-to-string (nth 1 arg)))) |
| 216 | ((memq op '(byte-call byte-unbind |
| 217 | byte-listN byte-concatN byte-insertN |
| 218 | byte-stack-ref byte-stack-set byte-stack-set2 |
| 219 | byte-discardN byte-discardN-preserve-tos)) |
| 220 | (insert (int-to-string arg))) |
| 221 | ((memq op '(byte-varref byte-varset byte-varbind)) |
| 222 | (prin1 (car arg) (current-buffer))) |
| 223 | ((memq op '(byte-constant byte-constant2)) |
| 224 | ;; it's a constant |
| 225 | (setq arg (car arg)) |
| 226 | ;; but if the value of the constant is compiled code, then |
| 227 | ;; recursively disassemble it. |
| 228 | (cond ((or (byte-code-function-p arg) |
| 229 | (and (eq (car-safe arg) 'lambda) |
| 230 | (assq 'byte-code arg)) |
| 231 | (and (eq (car-safe arg) 'macro) |
| 232 | (or (byte-code-function-p (cdr arg)) |
| 233 | (and (eq (car-safe (cdr arg)) 'lambda) |
| 234 | (assq 'byte-code (cdr arg)))))) |
| 235 | (cond ((byte-code-function-p arg) |
| 236 | (insert "<compiled-function>\n")) |
| 237 | ((eq (car-safe arg) 'lambda) |
| 238 | (insert "<compiled lambda>")) |
| 239 | (t (insert "<compiled macro>\n"))) |
| 240 | (disassemble-internal |
| 241 | arg |
| 242 | (+ indent disassemble-recursive-indent 1) |
| 243 | nil)) |
| 244 | ((eq (car-safe arg) 'byte-code) |
| 245 | (insert "<byte code>\n") |
| 246 | (disassemble-1 ;recurse on byte-code object |
| 247 | arg |
| 248 | (+ indent disassemble-recursive-indent))) |
| 249 | ((eq (car-safe (car-safe arg)) 'byte-code) |
| 250 | (insert "(<byte code>...)\n") |
| 251 | (mapc ;recurse on list of byte-code objects |
| 252 | (lambda (obj) |
| 253 | (disassemble-1 |
| 254 | obj |
| 255 | (+ indent disassemble-recursive-indent))) |
| 256 | arg)) |
| 257 | (t |
| 258 | ;; really just a constant |
| 259 | (let ((print-escape-newlines t)) |
| 260 | (prin1 arg (current-buffer)))))) |
| 261 | ) |
| 262 | (insert "\n"))))) |
| 263 | nil) |
| 264 | |
| 265 | (provide 'disass) |
| 266 | |
| 267 | ;;; disass.el ends here |