disass.el 8.95 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; disass.el --- disassembler for compiled Emacs Lisp code

3
;; Copyright (C) 1986, 1991, 2002-2011 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

Eric S. Raymond's avatar
Eric S. Raymond committed
5 6
;; Author: Doug Cutting <doug@csli.stanford.edu>
;;	Jamie Zawinski <jwz@lucid.com>
7
;; Maintainer: FSF
Eric S. Raymond's avatar
Eric S. Raymond committed
8
;; Keywords: internal
Eric S. Raymond's avatar
Eric S. Raymond committed
9

Jim Blandy's avatar
Jim Blandy committed
10 11
;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Jim Blandy's avatar
Jim Blandy committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Jim Blandy's avatar
Jim Blandy committed
16 17 18 19 20 21 22

;; GNU Emacs 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 General Public License for more details.

;; 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/>.
Jim Blandy's avatar
Jim Blandy committed
24

Eric S. Raymond's avatar
Eric S. Raymond committed
25 26
;;; Commentary:

27 28 29 30 31 32 33 34
;; The single entry point, `disassemble', disassembles a code object generated
;; by the Emacs Lisp byte-compiler.  This doesn't invert the compilation
;; operation, not by a long shot, but it's useful for debugging.

;;
;; Original version by Doug Cutting (doug@csli.stanford.edu)
;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
;; the new lapcode-based byte compiler.
Eric S. Raymond's avatar
Eric S. Raymond committed
35 36

;;; Code:
Jim Blandy's avatar
Jim Blandy committed
37 38

;;; The variable byte-code-vector is defined by the new bytecomp.el.
Jim Blandy's avatar
Jim Blandy committed
39 40
;;; The function byte-decompile-lapcode is defined in byte-opt.el.
;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
41
(require 'byte-compile "bytecomp")
Jim Blandy's avatar
Jim Blandy committed
42

43
(defvar disassemble-column-1-indent 8 "*")
Jim Blandy's avatar
Jim Blandy committed
44 45 46 47
(defvar disassemble-column-2-indent 10 "*")

(defvar disassemble-recursive-indent 3 "*")

Jim Blandy's avatar
Jim Blandy committed
48
;;;###autoload
Jim Blandy's avatar
Jim Blandy committed
49 50 51 52 53 54 55 56 57
(defun disassemble (object &optional buffer indent interactive-p)
  "Print disassembled code for OBJECT in (optional) BUFFER.
OBJECT can be a symbol defined as a function, or a function itself
\(a lambda expression or a compiled-function object).
If OBJECT is not already compiled, we compile it, but do not
redefine OBJECT if it is a symbol."
  (interactive (list (intern (completing-read "Disassemble function: "
					      obarray 'fboundp t))
		     nil 0 t))
58
  (if (and (consp object) (not (eq (car object) 'lambda)))
Jim Blandy's avatar
Jim Blandy committed
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
      (setq object (list 'lambda () object)))
  (or indent (setq indent 0))		;Default indent to zero
  (save-excursion
    (if (or interactive-p (null buffer))
	(with-output-to-temp-buffer "*Disassemble*"
	  (set-buffer "*Disassemble*")
	  (disassemble-internal object indent (not interactive-p)))
      (set-buffer buffer)
      (disassemble-internal object indent nil)))
  nil)


(defun disassemble-internal (obj indent interactive-p)
  (let ((macro 'nil)
	(name 'nil)
	(doc 'nil)
	args)
    (while (symbolp obj)
      (setq name obj
	    obj (symbol-function obj)))
    (if (subrp obj)
	(error "Can't disassemble #<subr %s>" name))
81 82 83
    (when (and (listp obj) (eq (car obj) 'autoload))
      (load (nth 1 obj))
      (setq obj (symbol-function name)))
Jim Blandy's avatar
Jim Blandy committed
84 85 86
    (if (eq (car-safe obj) 'macro)	;handle macros
	(setq macro t
	      obj (cdr obj)))
87
    (when (and (listp obj) (eq (car obj) 'closure))
88
      (error "Don't know how to compile an interpreted closure"))
89
    (if (and (listp obj) (eq (car obj) 'byte-code))
90
	(setq obj (list 'lambda nil obj)))
Jim Blandy's avatar
Jim Blandy committed
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
    (if (and (listp obj) (not (eq (car obj) 'lambda)))
	(error "not a function"))
    (if (consp obj)
	(if (assq 'byte-code obj)
	    nil
	  (if interactive-p (message (if name
					 "Compiling %s's definition..."
				       "Compiling definition...")
				     name))
	  (setq obj (byte-compile obj))
	  (if interactive-p (message "Done compiling.  Disassembling..."))))
    (cond ((consp obj)
	   (setq obj (cdr obj))		;throw lambda away
	   (setq args (car obj))	;save arg list
	   (setq obj (cdr obj)))
106 107 108
	  ((byte-code-function-p obj)
	   (setq args (aref obj 0)))
          (t (error "Compilation failed")))
Jim Blandy's avatar
Jim Blandy committed
109 110 111 112 113 114 115 116 117
    (if (zerop indent) ; not a nested function
	(progn
	  (indent-to indent)
	  (insert (format "byte code%s%s%s:\n"
			  (if (or macro name) " for" "")
			  (if macro " macro" "")
			  (if name (format " %s" name) "")))))
    (let ((doc (if (consp obj)
		   (and (stringp (car obj)) (car obj))
118 119
		 ;; Use documentation to get lazy-loaded doc string
		 (documentation obj t))))
Jim Blandy's avatar
Jim Blandy committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
      (if (and doc (stringp doc))
	  (progn (and (consp obj) (setq obj (cdr obj)))
		 (indent-to indent)
		 (princ "  doc:  " (current-buffer))
		 (if (string-match "\n" doc)
		     (setq doc (concat (substring doc 0 (match-beginning 0))
				       " ...")))
		 (insert doc "\n"))))
    (indent-to indent)
    (insert "  args: ")
    (prin1 args (current-buffer))
    (insert "\n")
    (let ((interactive (cond ((consp obj)
			      (assq 'interactive obj))
			     ((> (length obj) 5)
			      (list 'interactive (aref obj 5))))))
      (if interactive
	  (progn
	    (setq interactive (nth 1 interactive))
	    (if (eq (car-safe (car-safe obj)) 'interactive)
		(setq obj (cdr obj)))
	    (indent-to indent)
	    (insert " interactive: ")
	    (if (eq (car-safe interactive) 'byte-code)
		(progn
		  (insert "\n")
		  (disassemble-1 interactive
				 (+ indent disassemble-recursive-indent)))
	      (let ((print-escape-newlines t))
		(prin1 interactive (current-buffer))))
	    (insert "\n"))))
    (cond ((and (consp obj) (assq 'byte-code obj))
	   (disassemble-1 (assq 'byte-code obj) indent))
Jim Blandy's avatar
Jim Blandy committed
153
	  ((byte-code-function-p obj)
Jim Blandy's avatar
Jim Blandy committed
154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
	   (disassemble-1 obj indent))
	  (t
	   (insert "Uncompiled body:  ")
	   (let ((print-escape-newlines t))
	     (prin1 (if (cdr obj) (cons 'progn obj) (car obj))
		    (current-buffer))))))
  (if interactive-p
      (message "")))


(defun disassemble-1 (obj indent)
  "Prints the byte-code call OBJ in the current buffer.
OBJ should be a call to BYTE-CODE generated by the byte compiler."
  (let (bytes constvec)
    (if (consp obj)
	(setq bytes (car (cdr obj))		;the byte code
	      constvec (car (cdr (cdr obj))))	;constant vector
171 172
      ;; If it is lazy-loaded, load it now
      (fetch-bytecode obj)
173
      (setq bytes (aref obj 1)
Jim Blandy's avatar
Jim Blandy committed
174
	    constvec (aref obj 2)))
175
    (let ((lap (byte-decompile-bytecode (string-as-unibyte bytes) constvec))
176
	  op arg opname pc-value)
Jim Blandy's avatar
Jim Blandy committed
177 178 179 180 181 182 183
      (let ((tagno 0)
	    tmp
	    (lap lap))
	(while (setq tmp (assq 'TAG lap))
	  (setcar (cdr tmp) (setq tagno (1+ tagno)))
	  (setq lap (cdr (memq tmp lap)))))
      (while lap
184 185 186 187 188 189 190
	;; Take off the pc value of the next thing
	;; and put it in pc-value.
	(setq pc-value nil)
	(if (numberp (car lap))
	    (setq pc-value (car lap)
		  lap (cdr lap)))
	;; Fetch the next op and its arg.
Jim Blandy's avatar
Jim Blandy committed
191 192
	(setq op (car (car lap))
	      arg (cdr (car lap)))
193
	(setq lap (cdr lap))
Jim Blandy's avatar
Jim Blandy committed
194 195
	(indent-to indent)
	(if (eq 'TAG op)
196 197 198 199 200 201 202 203
	    (progn
	      ;; We have a label.  Display it, but first its pc value.
	      (if pc-value
		  (insert (format "%d:" pc-value)))
	      (insert (int-to-string (car arg))))
	  ;; We have an instruction.  Display its pc value first.
	  (if pc-value
	      (insert (format "%d" pc-value)))
Jim Blandy's avatar
Jim Blandy committed
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218
	  (indent-to (+ indent disassemble-column-1-indent))
	  (if (and op
		   (string-match "^byte-" (setq opname (symbol-name op))))
	      (setq opname (substring opname 5))
	    (setq opname "<not-an-opcode>"))
	  (if (eq op 'byte-constant2)
	      (insert " #### shouldn't have seen constant2 here!\n  "))
	  (insert opname)
	  (indent-to (+ indent disassemble-column-1-indent
			disassemble-column-2-indent
			-1))
	  (insert " ")
	  (cond ((memq op byte-goto-ops)
		 (insert (int-to-string (nth 1 arg))))
		((memq op '(byte-call byte-unbind
219 220 221
			    byte-listN byte-concatN byte-insertN
			    byte-stack-ref byte-stack-set byte-stack-set2
			    byte-discardN byte-discardN-preserve-tos))
Jim Blandy's avatar
Jim Blandy committed
222 223 224 225 226 227 228 229
		 (insert (int-to-string arg)))
		((memq op '(byte-varref byte-varset byte-varbind))
		 (prin1 (car arg) (current-buffer)))
		((memq op '(byte-constant byte-constant2))
		 ;; it's a constant
		 (setq arg (car arg))
		 ;; but if the value of the constant is compiled code, then
		 ;; recursively disassemble it.
Jim Blandy's avatar
Jim Blandy committed
230
		 (cond ((or (byte-code-function-p arg)
Jim Blandy's avatar
Jim Blandy committed
231 232 233
			    (and (eq (car-safe arg) 'lambda)
				 (assq 'byte-code arg))
			    (and (eq (car-safe arg) 'macro)
Jim Blandy's avatar
Jim Blandy committed
234
				 (or (byte-code-function-p (cdr arg))
Jim Blandy's avatar
Jim Blandy committed
235 236
				     (and (eq (car-safe (cdr arg)) 'lambda)
					  (assq 'byte-code (cdr arg))))))
Jim Blandy's avatar
Jim Blandy committed
237
			(cond ((byte-code-function-p arg)
Jim Blandy's avatar
Jim Blandy committed
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
			       (insert "<compiled-function>\n"))
			      ((eq (car-safe arg) 'lambda)
			       (insert "<compiled lambda>"))
			      (t (insert "<compiled macro>\n")))
			(disassemble-internal
			 arg
			 (+ indent disassemble-recursive-indent 1)
			 nil))
		       ((eq (car-safe arg) 'byte-code)
			(insert "<byte code>\n")
			(disassemble-1	;recurse on byte-code object
			 arg
			 (+ indent disassemble-recursive-indent)))
		       ((eq (car-safe (car-safe arg)) 'byte-code)
			(insert "(<byte code>...)\n")
253
			(mapc ;recurse on list of byte-code objects
Jim Blandy's avatar
Jim Blandy committed
254 255 256 257 258 259 260 261 262 263
			 '(lambda (obj)
			    (disassemble-1
			     obj
			     (+ indent disassemble-recursive-indent)))
			 arg))
		       (t
			;; really just a constant
			(let ((print-escape-newlines t))
			  (prin1 arg (current-buffer))))))
		)
264
	  (insert "\n")))))
Jim Blandy's avatar
Jim Blandy committed
265
  nil)
Eric S. Raymond's avatar
Eric S. Raymond committed
266

Richard M. Stallman's avatar
Richard M. Stallman committed
267 268
(provide 'disass)

Eric S. Raymond's avatar
Eric S. Raymond committed
269
;;; disass.el ends here