diff options
Diffstat (limited to 'lisp/disass.el')
| -rw-r--r-- | lisp/disass.el | 446 |
1 files changed, 446 insertions, 0 deletions
diff --git a/lisp/disass.el b/lisp/disass.el new file mode 100644 index 00000000000..77e5a7fc17d --- /dev/null +++ b/lisp/disass.el @@ -0,0 +1,446 @@ +;;; Disassembler for compiled Emacs Lisp code +;; Copyright (C) 1986 Free Software Foundation +;;; By Doug Cutting (doug@csli.stanford.edu) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 1, or (at your option) +;; any later version. + +;; 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 +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + + +(require 'byte-compile "bytecomp") + +(defvar disassemble-column-1-indent 4 "*") + +(defvar disassemble-column-2-indent 9 "*") + +(defvar disassemble-recursive-indent 3 "*") + +;(defun d (x) +; (interactive "xDiss ") +; (with-output-to-temp-buffer "*Disassemble*" +; (disassemble-internal (list 'lambda '() x ''return-value) +; standard-output 0 t))) + +(defun disassemble (object &optional stream indent interactive-p) + "Print disassembled code for OBJECT on (optional) STREAM. +OBJECT can be a function name, lambda expression or any function object +returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will +compile it (but not redefine it)." + (interactive (list (intern (completing-read "Disassemble function: " + obarray 'fboundp t)) + nil 0 t)) + (or indent (setq indent 0)) ;Default indent to zero + (if interactive-p + (with-output-to-temp-buffer "*Disassemble*" + (disassemble-internal object standard-output indent t)) + (disassemble-internal object (or stream standard-output) indent nil)) + nil) + +(defun disassemble-internal (obj stream 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)) + (if (eq (car obj) 'macro) ;handle macros + (setq macro t + obj (cdr obj))) + (if (not (eq (car obj) 'lambda)) + (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-lambda obj)) + (if interactive-p (message "Done compiling. Disassembling..."))) + (setq obj (cdr obj)) ;throw lambda away + (setq args (car obj)) ;save arg list + (setq obj (cdr obj)) + (write-spaces indent stream) + (princ (format "byte code%s%s%s:\n" + (if (or macro name) " for" "") + (if macro " macro" "") + (if name (format " %s" name) "")) + stream) + (let ((doc (and (stringp (car obj)) (car obj)))) + (if doc + (progn (setq obj (cdr obj)) + (write-spaces indent stream) + (princ " doc: " stream) + (princ doc stream) + (terpri stream)))) + (write-spaces indent stream) + (princ " args: " stream) + (prin1 args stream) + (terpri stream) + (let ((interactive (car (cdr (assq 'interactive obj))))) + (if interactive + (progn (write-spaces indent stream) + (princ " interactive: " stream) + (if (eq (car-safe interactive) 'byte-code) + (disassemble-1 interactive stream + (+ indent disassemble-recursive-indent)) + (prin1 interactive stream) + (terpri stream))))) + (setq obj (assq 'byte-code obj)) ;obj is now call to byte-code + (disassemble-1 obj stream indent)) + (if interactive-p + (message ""))) + +(defun disassemble-1 (obj &optional stream indent) + "Prints the byte-code call OBJ to (optional) STREAM. +OBJ should be a call to BYTE-CODE generated by the byte compiler." + (or indent (setq indent 0)) ;default indent to 0 + (or stream (setq stream standard-output)) + (let ((bytes (car (cdr obj))) ;the byte code + (ptr -1) ;where we are in it + (constants (car (cdr (cdr obj)))) ;constant vector + ;(next-indent indent) + offset tmp length) + (setq length (length bytes)) + (terpri stream) + (while (< (setq ptr (1+ ptr)) length) + ;(setq indent next-indent) + (write-spaces indent stream) ;indent to recursive indent + (princ (setq tmp (prin1-to-string ptr)) stream) ;print line # + (write-char ?\ stream) + (write-spaces (- disassemble-column-1-indent (length tmp) 1) + stream) + (setq op (aref bytes ptr)) ;fetch opcode + ;; Note: as offsets are either encoded in opcodes or stored as + ;; bytes in the code, this function (disassemble-offset) + ;; can set OP and/or PTR. + (setq offset (disassemble-offset));fetch offset + (setq tmp (aref byte-code-vector op)) + (if (consp tmp) + (setq ;next-indent (if (numberp (cdr tmp)) + ; (+ indent (cdr tmp)) + ; (+ indent (funcall (cdr tmp) offset))) + tmp (car tmp))) + (setq tmp (symbol-name tmp)) + (princ tmp stream) ;print op-name for opcode + (if (null offset) + nil + (write-char ?\ stream) + (write-spaces (- disassemble-column-2-indent (length tmp) 1) + stream) ;indent to col 2 + (princ ;print offset + (cond ((or (eq op byte-varref) + (eq op byte-varset) + (eq op byte-varbind)) + ;; it's a varname (atom) + (aref constants offset)) ;fetch it from constants + ((or (eq op byte-goto) + (eq op byte-goto-if-nil) + (eq op byte-goto-if-not-nil) + (eq op byte-goto-if-nil-else-pop) + (eq op byte-goto-if-not-nil-else-pop) + (eq op byte-call) + (eq op byte-unbind)) + ;; it's a number + offset) ;return it + ((or (eq op byte-constant) + (eq op byte-constant2)) + ;; it's a constant + (setq tmp (aref constants offset)) + ;; but is constant byte code? + (cond ((and (eq (car-safe tmp) 'lambda) + (assq 'byte-code tmp)) + (princ "<compiled lambda>" stream) + (terpri stream) + (disassemble ;recurse on compiled lambda + tmp + stream + (+ indent disassemble-recursive-indent)) + "") + ((eq (car-safe tmp) 'byte-code) + (princ "<byte code>" stream) + (terpri stream) + (disassemble-1 ;recurse on byte-code object + tmp + stream + (+ indent disassemble-recursive-indent)) + "") + ((eq (car-safe (car-safe tmp)) 'byte-code) + (princ "(<byte code>...)" stream) + (terpri stream) + (mapcar ;recurse on list of byte-code objects + (function (lambda (obj) + (disassemble-1 + obj + stream + (+ indent disassemble-recursive-indent)))) + tmp) + "") + ((and (eq tmp 'byte-code) + (eq (aref bytes (+ ptr 4)) (+ byte-call 3))) + ;; this won't catch cases where args are pushed w/ + ;; constant2. + (setq ptr (+ ptr 4)) + "<compiled call to byte-code. compiled code compiled?>") + (t + ;; really just a constant + (let ((print-escape-newlines t)) + (prin1-to-string tmp))))) + (t "<error in disassembler>")) + stream)) + (terpri stream))) + nil) + + +(defun disassemble-offset () + "Don't call this!" + ;; fetch and return the offset for the current opcode. + ;; return NIL if this opcode has no offset + ;; OP, PTR and BYTES are used and set dynamically + (let (tem) + (cond ((< op byte-nth) + (setq tem (logand op 7)) + (setq op (logand op 248)) + (cond ((eq tem 6) + (setq ptr (1+ ptr)) ;offset in next byte + (aref bytes ptr)) + ((eq tem 7) + (setq ptr (1+ ptr)) ;offset in next 2 bytes + (+ (aref bytes ptr) + (progn (setq ptr (1+ ptr)) + (lsh (aref bytes ptr) 8)))) + (t tem))) ;offset was in opcode + ((>= op byte-constant) + (setq tem (- op byte-constant)) ;offset in opcode + (setq op byte-constant) + tem) + ((or (= op byte-constant2) + (and (>= op byte-goto) + (<= op byte-goto-if-not-nil-else-pop))) + (setq ptr (1+ ptr)) ;offset in next 2 bytes + (+ (aref bytes ptr) + (progn (setq ptr (1+ ptr)) + (lsh (aref bytes ptr) 8)))) + (t nil)))) ;no offset + + +(defun write-spaces (n &optional stream) + "Print N spaces to (optional) STREAM." + (or stream (setq stream standard-output)) + (if (< n 0) (setq n 0)) + (if (eq stream (current-buffer)) + (insert-char ?\ n) + (while (> n 0) + (write-char ?\ stream) + (setq n (1- n))))) + +(defconst byte-code-vector + '[<not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (varref . 1) + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (varset . -1) + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (varbind . 0);Pops a value, "pushes" a binding + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (call . -); #'-, not -1! + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (unbind . -);"pops" bindings + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (nth . -1) + symbolp + consp + stringp + listp + (eq . -1) + (memq . -1) + not + car + cdr + (cons . -1) + list1 + (list2 . -1) + (list3 . -2) + (list4 . -3) + length + (aref . -1) + (aset . -2) + symbol-value + symbol-function + (set . -1) + (fset . -1) + (get . -1) + (substring . -2) + (concat2 . -1) + (concat3 . -2) + (concat4 . -3) + sub1 + add1 + (eqlsign . -1) ;= + (gtr . -1) ;> + (lss . -1) ;< + (leq . -1) ;<= + (geq . -1) ;>= + (diff . -1) ;- + negate ;unary - + (plus . -1) ;+ + (max . -1) + (min . -1) + <not-an-opcode> + (point . 1) + (mark\(obsolete\) . 1) + goto-char + insert + (point-max . 1) + (point-min . 1) + char-after + (following-char . 1) + (preceding-char . 1) + (current-column . 1) + (indent-to . 1) + (scan-buffer\(obsolete\) . -2) + (eolp . 1) + (eobp . 1) + (bolp . 1) + (bobp . 1) + (current-buffer . 1) + set-buffer + (read-char . 1) + set-mark\(obsolete\) + interactive-p + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (constant2 . 1) + goto;>>> + goto-if-nil;>> + goto-if-not-nil;>> + (goto-if-nil-else-pop . -1) + (goto-if-not-nil-else-pop . -1) + return + (discard . -1) + (dup . 1) + (save-excursion . 1);Pushes a binding + (save-window-excursion . 1);Pushes a binding + (save-restriction . 1);Pushes a binding + (catch . -1);Takes one argument, returns a value + (unwind-protect . 1);Takes one argument, pushes a binding, returns a value + (condition-case . -2);Takes three arguments, returns a value + (temp-output-buffer-setup . -1) + temp-output-buffer-show + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + <not-an-opcode> + (constant . 1) + ]) + |