1;;; disass.el --- disassembler for compiled Emacs Lisp code 2 3;;; Copyright (C) 1986, 1991 Free Software Foundation, Inc. 4 5;; Author: Doug Cutting <doug@csli.stanford.edu> 6;; Jamie Zawinski <jwz@lucid.com> 7;; Maintainer: Jamie Zawinski <jwz@lucid.com> 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 2, or (at your option) 15;; 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; see the file COPYING. If not, write to 24;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 25 26;;; Commentary: 27 28;; The single entry point, `disassemble', disassembles a code object generated 29;; by the Emacs Lisp byte-compiler. This doesn't invert the compilation 30;; operation, not by a long shot, but it's useful for debugging. 31 32;; 33;; Original version by Doug Cutting (doug@csli.stanford.edu) 34;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for 35;; the new lapcode-based byte compiler. 36 37;;; Code: 38 39;;; The variable byte-code-vector is defined by the new bytecomp.el. 40;;; The function byte-decompile-lapcode is defined in byte-opt.el. 41;;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt. 42(require 'byte-compile "bytecomp") 43 44(defvar disassemble-column-1-indent 5 "*") 45(defvar disassemble-column-2-indent 10 "*") 46 47(defvar disassemble-recursive-indent 3 "*") 48 49;;;###autoload 50(defun disassemble (object &optional buffer indent interactive-p) 51 "Print disassembled code for OBJECT in (optional) BUFFER. 52OBJECT can be a symbol defined as a function, or a function itself 53\(a lambda expression or a compiled-function object). 54If OBJECT is not already compiled, we compile it, but do not 55redefine OBJECT if it is a symbol." 56 (interactive (list (intern (completing-read "Disassemble function: " 57 obarray 'fboundp t)) 58 nil 0 t)) 59 (if (eq (car-safe object) 'byte-code) 60 (setq object (list 'lambda () object))) 61 (or indent (setq indent 0)) ;Default indent to zero 62 (save-excursion 63 (if (or interactive-p (null buffer)) 64 (with-output-to-temp-buffer "*Disassemble*" 65 (set-buffer "*Disassemble*") 66 (disassemble-internal object indent (not interactive-p))) 67 (set-buffer buffer) 68 (disassemble-internal object indent nil))) 69 nil) 70 71 72(defun disassemble-internal (obj indent interactive-p) 73 (let ((macro 'nil) 74 (name 'nil) 75 (doc 'nil) 76 args) 77 (while (symbolp obj) 78 (setq name obj 79 obj (symbol-function obj))) 80 (if (subrp obj) 81 (error "Can't disassemble #<subr %s>" name)) 82 (if (and (listp obj) (eq (car obj) 'autoload)) 83 (progn 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 (if (and (listp obj) (eq (car obj) 'byte-code)) 90 (setq obj (list 'lambda nil obj))) 91 (if (and (listp obj) (not (eq (car obj) 'lambda))) 92 (error "not a function")) 93 (if (consp obj) 94 (if (assq 'byte-code obj) 95 nil 96 (if interactive-p (message (if name 97 "Compiling %s's definition..." 98 "Compiling definition...") 99 name)) 100 (setq obj (byte-compile obj)) 101 (if interactive-p (message "Done compiling. Disassembling...")))) 102 (cond ((consp obj) 103 (setq obj (cdr obj)) ;throw lambda away 104 (setq args (car obj)) ;save arg list 105 (setq obj (cdr obj))) 106 (t 107 (setq args (aref obj 0)))) 108 (if (zerop indent) ; not a nested function 109 (progn 110 (indent-to indent) 111 (insert (format "byte code%s%s%s:\n" 112 (if (or macro name) " for" "") 113 (if macro " macro" "") 114 (if name (format " %s" name) ""))))) 115 (let ((doc (if (consp obj) 116 (and (stringp (car obj)) (car obj)) 117 (and (> (length obj) 4) (aref obj 4))))) 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 (if (cdr obj) (cons 'progn obj) (car 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. 164OBJ 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 (setq bytes (aref obj 1) 170 constvec (aref obj 2))) 171 (let ((lap (byte-decompile-bytecode bytes constvec)) 172 op arg opname) 173 (let ((tagno 0) 174 tmp 175 (lap lap)) 176 (while (setq tmp (assq 'TAG lap)) 177 (setcar (cdr tmp) (setq tagno (1+ tagno))) 178 (setq lap (cdr (memq tmp lap))))) 179 (while lap 180 (setq op (car (car lap)) 181 arg (cdr (car lap))) 182 (indent-to indent) 183 (if (eq 'TAG op) 184 (insert (int-to-string (car arg)) ":") 185 186 (indent-to (+ indent disassemble-column-1-indent)) 187 (if (and op 188 (string-match "^byte-" (setq opname (symbol-name op)))) 189 (setq opname (substring opname 5)) 190 (setq opname "<not-an-opcode>")) 191 (if (eq op 'byte-constant2) 192 (insert " #### shouldn't have seen constant2 here!\n ")) 193 (insert opname) 194 (indent-to (+ indent disassemble-column-1-indent 195 disassemble-column-2-indent 196 -1)) 197 (insert " ") 198 (cond ((memq op byte-goto-ops) 199 (insert (int-to-string (nth 1 arg)))) 200 ((memq op '(byte-call byte-unbind 201 byte-listN byte-concatN byte-insertN)) 202 (insert (int-to-string arg))) 203 ((memq op '(byte-varref byte-varset byte-varbind)) 204 (prin1 (car arg) (current-buffer))) 205 ((memq op '(byte-constant byte-constant2)) 206 ;; it's a constant 207 (setq arg (car arg)) 208 ;; but if the value of the constant is compiled code, then 209 ;; recursively disassemble it. 210 (cond ((or (byte-code-function-p arg) 211 (and (eq (car-safe arg) 'lambda) 212 (assq 'byte-code arg)) 213 (and (eq (car-safe arg) 'macro) 214 (or (byte-code-function-p (cdr arg)) 215 (and (eq (car-safe (cdr arg)) 'lambda) 216 (assq 'byte-code (cdr arg)))))) 217 (cond ((byte-code-function-p arg) 218 (insert "<compiled-function>\n")) 219 ((eq (car-safe arg) 'lambda) 220 (insert "<compiled lambda>")) 221 (t (insert "<compiled macro>\n"))) 222 (disassemble-internal 223 arg 224 (+ indent disassemble-recursive-indent 1) 225 nil)) 226 ((eq (car-safe arg) 'byte-code) 227 (insert "<byte code>\n") 228 (disassemble-1 ;recurse on byte-code object 229 arg 230 (+ indent disassemble-recursive-indent))) 231 ((eq (car-safe (car-safe arg)) 'byte-code) 232 (insert "(<byte code>...)\n") 233 (mapcar ;recurse on list of byte-code objects 234 '(lambda (obj) 235 (disassemble-1 236 obj 237 (+ indent disassemble-recursive-indent))) 238 arg)) 239 (t 240 ;; really just a constant 241 (let ((print-escape-newlines t)) 242 (prin1 arg (current-buffer)))))) 243 ) 244 (insert "\n")) 245 (setq lap (cdr lap))))) 246 nil) 247 248;;; disass.el ends here 249