disass.el 9.85 KB
Newer Older
1
;;; disass.el --- disassembler for compiled Emacs Lisp code  -*- lexical-binding:t -*-
Eric S. Raymond's avatar
Eric S. Raymond committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1986, 1991, 2002-2019 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: emacs-devel@gnu.org
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 <https://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
(require 'macroexp)
39
(require 'cl-lib)
40

41 42 43
;; The variable byte-code-vector is defined by the new bytecomp.el.
;; 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.
44
(require 'byte-compile "bytecomp")
Jim Blandy's avatar
Jim Blandy committed
45

46
(defvar disassemble-column-1-indent 8 "*")
Jim Blandy's avatar
Jim Blandy committed
47 48 49 50
(defvar disassemble-column-2-indent 10 "*")

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

Jim Blandy's avatar
Jim Blandy committed
51
;;;###autoload
Jim Blandy's avatar
Jim Blandy committed
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."
58 59 60 61 62 63 64
  (interactive
   (let* ((fn (function-called-at-point))
          (prompt (if fn (format "Disassemble function (default %s): " fn)
                    "Disassemble function: "))
          (def (and fn (symbol-name fn))))
     (list (intern (completing-read prompt obarray 'fboundp t nil nil def))
           nil 0 t)))
65 66
  (if (and (consp object) (not (functionp object)))
      (setq object `(lambda () ,object)))
Jim Blandy's avatar
Jim Blandy committed
67 68 69 70 71 72 73 74 75 76 77 78 79
  (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)
80 81 82
	(name (when (symbolp obj)
                (prog1 obj
                  (setq obj (indirect-function obj)))))
Jim Blandy's avatar
Jim Blandy committed
83
	args)
84
    (setq obj (autoload-do-load obj name))
Jim Blandy's avatar
Jim Blandy committed
85 86
    (if (subrp obj)
	(error "Can't disassemble #<subr %s>" name))
87
    (if (eq (car-safe obj) 'macro)	;Handle macros.
Jim Blandy's avatar
Jim Blandy committed
88 89
	(setq macro t
	      obj (cdr obj)))
90 91 92 93 94 95 96 97 98 99 100 101
    (if (eq (car-safe obj) 'byte-code)
	(setq obj `(lambda () ,obj)))
    (when (consp obj)
      (unless (functionp obj) (error "not a function"))
      (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..."))))
Jim Blandy's avatar
Jim Blandy committed
102
    (cond ((consp obj)
103
	   (setq args (help-function-arglist obj))	;save arg list
Jim Blandy's avatar
Jim Blandy committed
104 105
	   (setq obj (cdr obj))		;throw lambda away
	   (setq obj (cdr obj)))
106
	  ((byte-code-function-p obj)
107
	   (setq args (help-function-arglist obj)))
108
          (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
      (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")
132
    (let ((interactive (interactive-form obj)))
Jim Blandy's avatar
Jim Blandy committed
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
      (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
150
	  ((byte-code-function-p obj)
Jim Blandy's avatar
Jim Blandy committed
151 152 153 154
	   (disassemble-1 obj indent))
	  (t
	   (insert "Uncompiled body:  ")
	   (let ((print-escape-newlines t))
155
	     (prin1 (macroexp-progn obj)
Jim Blandy's avatar
Jim Blandy committed
156 157 158 159 160 161 162 163 164 165 166 167
		    (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
168 169
      ;; If it is lazy-loaded, load it now
      (fetch-bytecode obj)
170
      (setq bytes (aref obj 1)
Jim Blandy's avatar
Jim Blandy committed
171
	    constvec (aref obj 2)))
172 173
    (cl-assert (not (multibyte-string-p bytes)))
    (let ((lap (byte-decompile-bytecode bytes constvec))
174
	  op arg opname pc-value)
Jim Blandy's avatar
Jim Blandy committed
175 176 177 178 179 180 181
      (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
182 183 184 185 186 187 188
	;; 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
189 190
	(setq op (car (car lap))
	      arg (cdr (car lap)))
191
	(setq lap (cdr lap))
Jim Blandy's avatar
Jim Blandy committed
192 193
	(indent-to indent)
	(if (eq 'TAG op)
194 195 196 197 198 199 200 201
	    (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
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
	  (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
217 218 219
			    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
220 221 222 223 224 225
		 (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))
226 227 228
                 ;; if the succeeding op is byte-switch, display the jump table
                 ;; used
		 (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch)
229 230 231 232 233 234 235 236
                         (insert (format "<jump-table-%s (" (hash-table-test arg)))
                         (let ((first-time t))
                           (maphash #'(lambda (value tag)
                                        (if first-time
                                            (setq first-time nil)
                                          (insert " "))
                                        (insert (format "%s %s" value (cadr tag))))
                                    arg))
237 238 239 240
                         (insert ")>"))
                  ;; if the value of the constant is compiled code, then
                  ;; recursively disassemble it.
                  ((or (byte-code-function-p arg)
241
			    (and (consp arg) (functionp arg)
Jim Blandy's avatar
Jim Blandy committed
242 243
				 (assq 'byte-code arg))
			    (and (eq (car-safe arg) 'macro)
Jim Blandy's avatar
Jim Blandy committed
244
				 (or (byte-code-function-p (cdr arg))
245 246
				     (and (consp (cdr arg))
                                          (functionp (cdr arg))
Jim Blandy's avatar
Jim Blandy committed
247
					  (assq 'byte-code (cdr arg))))))
Jim Blandy's avatar
Jim Blandy committed
248
			(cond ((byte-code-function-p arg)
Jim Blandy's avatar
Jim Blandy committed
249
			       (insert "<compiled-function>\n"))
250
			      ((functionp arg)
Jim Blandy's avatar
Jim Blandy committed
251 252 253 254 255 256 257 258 259 260 261 262 263
			       (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")
264
			(mapc ;recurse on list of byte-code objects
265 266 267 268
			 (lambda (obj)
                           (disassemble-1
                            obj
                            (+ indent disassemble-recursive-indent)))
Jim Blandy's avatar
Jim Blandy committed
269 270 271 272 273 274
			 arg))
		       (t
			;; really just a constant
			(let ((print-escape-newlines t))
			  (prin1 arg (current-buffer))))))
		)
275
	  (insert "\n")))))
Jim Blandy's avatar
Jim Blandy committed
276
  nil)
Eric S. Raymond's avatar
Eric S. Raymond committed
277

Richard M. Stallman's avatar
Richard M. Stallman committed
278 279
(provide 'disass)

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