Mercurial > emacs
changeset 757:745b7fc3a3d3
Initial revision
| author | Jim Blandy <jimb@redhat.com> |
|---|---|
| date | Fri, 10 Jul 1992 22:06:47 +0000 |
| parents | 0276f8eb306f |
| children | f8688580137c |
| files | lisp/byte-run.el lisp/emacs-lisp/byte-opt.el lisp/emacs-lisp/bytecomp.el lisp/emacs-lisp/disass.el |
| diffstat | 4 files changed, 5127 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/byte-run.el Fri Jul 10 22:06:47 1992 +0000 @@ -0,0 +1,173 @@ +;;; -*- Mode:Emacs-Lisp -*- + +;; Runtime support for the new optimizing byte compiler. +;; By Jamie Zawinski <jwz@lucid.com>. +;; Last Modified: 27-jul-91. +;; +;; The code in this file should always be loaded, because it defines things +;; like "defsubst" which should work interpreted as well. The code in +;; bytecomp.el and byte-optimize.el can be loaded as needed. +;; +;; This should be loaded by loadup.el or startup.el. If you can't modify +;; those files, load this from your .emacs file. But if you are using +;; emacs18, this file must be loaded before any .elc files which were +;; generated by the new compiler without emacs18 compatibility turned on. +;; If this file is loaded, certain emacs19 binaries will run in emacs18. +;; Meditate on the meanings of byte-compile-generate-emacs19-bytecodes and +;; byte-compile-emacs18-compatibility. + + +;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +;; 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. + + +;; emacs-18 compatibility. + +(if (fboundp 'make-byte-code) + nil + ;; + ;; To avoid compiler bootstrapping problems, this temporary uncompiled + ;; make-byte-code is needed to load the compiled one. Ignore the warnings. + (fset 'make-byte-code + '(lambda (arglist bytestring constants stackdepth doc) + (list 'lambda arglist doc + (list 'byte-code bytestring constants stackdepth)))) + ;; + ;; Now get a compiled version. + (defun make-byte-code (arglist bytestring constants stackdepth + &optional doc &rest interactive) + "For compatibility with Emacs19 ``.elc'' files." + (nconc (list 'lambda arglist) + ;; #### Removed the (stringp doc) for speed. Because the V19 + ;; make-byte-code depends on the args being correct, it won't + ;; help to make a smarter version for V18 alone. + ;; Btw, it should have been (or (stringp doc) (natnump doc)). + (if doc (list doc)) + (if interactive + (list (cons 'interactive (if (car interactive) interactive)))) + (list (list 'byte-code bytestring constants stackdepth))))) + + +;;; interface to selectively inlining functions. +;;; This only happens when source-code optimization is turned on. + +;; Redefined in byte-optimize.el. +(fset 'inline 'progn) +(put 'inline 'lisp-indent-hook 0) + + +;;; Interface to inline functions. + +(defmacro proclaim-inline (&rest fns) + "Cause the named functions to be open-coded when called from compiled code. +They will only be compiled open-coded when byte-compile-optimize is true." + (cons 'eval-and-compile + (mapcar '(lambda (x) + (or (memq (get x 'byte-optimizer) + '(nil byte-compile-inline-expand)) + (error + "%s already has a byte-optimizer, can't make it inline" + x)) + (list 'put (list 'quote x) + ''byte-optimizer ''byte-compile-inline-expand)) + fns))) + + +(defmacro proclaim-notinline (&rest fns) + "Cause the named functions to no longer be open-coded." + (cons 'eval-and-compile + (mapcar '(lambda (x) + (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand) + (put x 'byte-optimizer nil)) + (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer) + ''byte-compile-inline-expand) + (list 'put x ''byte-optimizer nil))) + fns))) + +;; This has a special byte-hunk-handler in bytecomp.el. +(defmacro defsubst (name arglist &rest body) + "Same syntax as defun, but the defined function will always be open-coded, +so long as byte-compile-optimize is true." + (list 'prog1 + (cons 'defun (cons name (cons arglist body))) + (list 'proclaim-inline name))) + +(defun make-obsolete (fn new) + "Make the byte-compiler warn that FUNCTION is obsolete and NEW should be +used instead. If NEW is a string, that is the `use instead' message." + (interactive "aMake function obsolete: \nxObsoletion replacement: ") + (let ((handler (get fn 'byte-compile))) + (if (eq 'byte-compile-obsolete handler) + (setcar (get fn 'byte-obsolete-info) new) + (put fn 'byte-obsolete-info (cons new handler)) + (put fn 'byte-compile 'byte-compile-obsolete))) + fn) + +(put 'dont-compile 'lisp-indent-hook 0) +(defmacro dont-compile (&rest body) + "Like progn, but the body will always run interpreted (not compiled)." + (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) + + +;;; interface to evaluating things at compile time and/or load time +;;; these macro must come after any uses of them in this file, as their +;;; definition in the file overrides the magic definitions on the +;;; byte-compile-macro-environment. + +(put 'eval-when-compile 'lisp-indent-hook 0) +(defmacro eval-when-compile (&rest body) + "Like progn, but evaluates the body at compile-time. The result of the +body appears to the compiler as a quoted constant." + ;; Not necessary because we have it in b-c-initial-macro-environment + ;; (list 'quote (eval (cons 'progn body))) + (cons 'progn body)) + +(put 'eval-and-compile 'lisp-indent-hook 0) +(defmacro eval-and-compile (&rest body) + "Like progn, but evaluates the body at compile-time as well as at load-time." + ;; Remember, it's magic. + (cons 'progn body)) + + +;;; Interface to file-local byte-compiler parameters. +;;; Redefined in bytecomp.el. + +(put 'byte-compiler-options 'lisp-indent-hook 0) +(defmacro byte-compiler-options (&rest args) + "Set some compilation-parameters for this file. This will affect only the +file in which it appears; this does nothing when evaluated, and when loaded +from a .el file. + +Each argument to this macro must be a list of a key and a value. + + Keys: Values: Corresponding variable: + + verbose t, nil byte-compile-verbose + optimize t, nil, source, byte byte-compile-optimize + warnings list of warnings byte-compile-warnings + Legal elements: (callargs redefine free-vars unresolved) + file-format emacs18, emacs19 byte-compile-emacs18-compatibility + new-bytecodes t, nil byte-compile-generate-emacs19-bytecodes + +For example, this might appear at the top of a source file: + + (byte-compiler-options + (optimize t) + (warnings (- free-vars)) ; Don't warn about free variables + (file-format emacs19))" + nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/byte-opt.el Fri Jul 10 22:06:47 1992 +0000 @@ -0,0 +1,1730 @@ +;;; -*- Mode:Emacs-Lisp -*- +;;; The optimization passes of the emacs-lisp byte compiler. + +;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>. +;; last modified 29-oct-91. + +;; 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. + +;;; ======================================================================== +;;; "No matter how hard you try, you can't make a racehorse out of a pig. +;;; you can, however, make a faster pig." +;;; +;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code +;;; makes it be a VW Bug with fuel injection and a turbocharger... You're +;;; still not going to make it go faster than 70 mph, but it might be easier +;;; to get it there. +;;; + +;;; TO DO: +;;; +;;; (apply '(lambda (x &rest y) ...) 1 (foo)) +;;; +;;; collapse common subexpressions +;;; +;;; maintain a list of functions known not to access any global variables +;;; (actually, give them a 'dynamically-safe property) and then +;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> +;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) +;;; by recursing on this, we might be able to eliminate the entire let. +;;; However certain variables should never have their bindings optimized +;;; away, because they affect everything. +;;; (put 'debug-on-error 'binding-is-magic t) +;;; (put 'debug-on-abort 'binding-is-magic t) +;;; (put 'inhibit-quit 'binding-is-magic t) +;;; (put 'quit-flag 'binding-is-magic t) +;;; others? +;;; +;;; Simple defsubsts often produce forms like +;;; (let ((v1 (f1)) (v2 (f2)) ...) +;;; (FN v1 v2 ...)) +;;; It would be nice if we could optimize this to +;;; (FN (f1) (f2) ...) +;;; but we can't unless FN is dynamically-safe (it might be dynamically +;;; referring to the bindings that the lambda arglist established.) +;;; One of the uncountable lossages introduced by dynamic scope... +;;; +;;; Maybe there should be a control-structure that says "turn on +;;; fast-and-loose type-assumptive optimizations here." Then when +;;; we see a form like (car foo) we can from then on assume that +;;; the variable foo is of type cons, and optimize based on that. +;;; But, this won't win much because of (you guessed it) dynamic +;;; scope. Anything down the stack could change the value. +;;; +;;; It would be nice if redundant sequences could be factored out as well, +;;; when they are known to have no side-effects: +;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 +;;; but beware of traps like +;;; (cons (list x y) (list x y)) +;;; +;;; Tail-recursion elimination is not really possible in elisp. Tail-recursion +;;; elimination is almost always impossible when all variables have dynamic +;;; scope, but given that the "return" byteop requires the binding stack to be +;;; empty (rather than emptying it itself), there can be no truly tail- +;;; recursive elisp functions that take any arguments or make any bindings. +;;; +;;; Here is an example of an elisp function which could safely be +;;; byte-compiled tail-recursively: +;;; +;;; (defun tail-map (fn list) +;;; (cond (list +;;; (funcall fn (car list)) +;;; (tail-map fn (cdr list))))) +;;; +;;; However, if there was even a single let-binding around the COND, +;;; it could not be byte-compiled, because there would be an "unbind" +;;; byte-op between the final "call" and "return." Adding a +;;; Bunbind_all byteop would fix this. +;;; +;;; (defun foo (x y z) ... (foo a b c)) +;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) +;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) +;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) +;;; +;;; this also can be considered tail recursion: +;;; +;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) +;;; could generalize this by doing the optimization +;;; (goto X) ... X: (return) --> (return) +;;; +;;; But this doesn't solve all of the problems: although by doing tail- +;;; recursion elimination in this way, the call-stack does not grow, the +;;; binding-stack would grow with each recursive step, and would eventually +;;; overflow. I don't believe there is any way around this without lexical +;;; scope. +;;; +;;; Wouldn't it be nice if elisp had lexical scope. +;;; +;;; Idea: the form (lexical-scope) in a file means that the file may be +;;; compiled lexically. This proclamation is file-local. Then, within +;;; that file, "let" would establish lexical bindings, and "let-dynamic" +;;; would do things the old way. (Or we could use CL "declare" forms.) +;;; We'd have to notice defvars and defconsts, since those variables should +;;; always be dynamic, and attempting to do a lexical binding of them +;;; should simply do a dynamic binding instead. +;;; But! We need to know about variables that were not necessarily defvarred +;;; in the file being compiled (doing a boundp check isn't good enough.) +;;; Fdefvar() would have to be modified to add something to the plist. +;;; +;;; A major disadvantage of this scheme is that the interpreter and compiler +;;; would have different semantics for files compiled with (dynamic-scope). +;;; Since this would be a file-local optimization, there would be no way to +;;; modify the interpreter to obey this (unless the loader was hacked +;;; in some grody way, but that's a really bad idea.) +;;; +;;; Really the Right Thing is to make lexical scope the default across +;;; the board, in the interpreter and compiler, and just FIX all of +;;; the code that relies on dynamic scope of non-defvarred variables. + + +(require 'byte-compile "bytecomp") + +(or (fboundp 'byte-compile-lapcode) + (error "loading bytecomp got the wrong version of the compiler.")) + +(defun byte-compile-log-lap-1 (format &rest args) + (if (aref byte-code-vector 0) + (error "The old version of the disassembler is loaded. Reload new-bytecomp as well.")) + (byte-compile-log-1 + (apply 'format format + (let (c a) + (mapcar '(lambda (arg) + (if (not (consp arg)) + (if (and (symbolp arg) + (string-match "^byte-" (symbol-name arg))) + (intern (substring (symbol-name arg) 5)) + arg) + (if (integerp (setq c (car arg))) + (error "non-symbolic byte-op %s" c)) + (if (eq c 'TAG) + (setq c arg) + (setq a (cond ((memq c byte-goto-ops) + (car (cdr (cdr arg)))) + ((memq c byte-constref-ops) + (car (cdr arg))) + (t (cdr arg)))) + (setq c (symbol-name c)) + (if (string-match "^byte-." c) + (setq c (intern (substring c 5))))) + (if (eq c 'constant) (setq c 'const)) + (if (and (eq (cdr arg) 0) + (not (memq c '(unbind call const)))) + c + (format "(%s %s)" c a)))) + args))))) + +(defmacro byte-compile-log-lap (format-string &rest args) + (list 'and + '(memq byte-optimize-log '(t byte)) + (cons 'byte-compile-log-lap-1 + (cons format-string args)))) + + +;;; byte-compile optimizers to support inlining + +(put 'inline 'byte-optimizer 'byte-optimize-inline-handler) + +(defun byte-optimize-inline-handler (form) + "byte-optimize-handler for the `inline' special-form." + (cons 'progn + (mapcar + '(lambda (sexp) + (let ((fn (car-safe sexp))) + (if (and (symbolp fn) + (or (cdr (assq fn byte-compile-function-environment)) + (and (fboundp fn) + (not (or (cdr (assq fn byte-compile-macro-environment)) + (and (consp (setq fn (symbol-function fn))) + (eq (car fn) 'macro)) + (subrp fn)))))) + (byte-compile-inline-expand sexp) + sexp))) + (cdr form)))) + + +(defun byte-inline-lapcode (lap) + "splice the given lap code into the current instruction stream. +If it has any labels in it, you're responsible for making sure there +are no collisions, and that byte-compile-tag-number is reasonable +after this is spliced in. the provided list is destroyed." + (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) + + +(defun byte-compile-inline-expand (form) + (let* ((name (car form)) + (fn (or (cdr (assq name byte-compile-function-environment)) + (and (fboundp name) (symbol-function name))))) + (if (null fn) + (progn + (byte-compile-warn "attempt to inline %s before it was defined" name) + form) + ;; else + (if (and (consp fn) (eq (car fn) 'autoload)) + (load (nth 1 fn))) + (if (and (consp fn) (eq (car fn) 'autoload)) + (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) + (if (symbolp fn) + (byte-compile-inline-expand (cons fn (cdr form))) + (if (compiled-function-p fn) + (cons (list 'lambda (aref fn 0) + (list 'byte-code (aref fn 1) (aref fn 2) (aref fn 3))) + (cdr form)) + (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) + (cons fn (cdr form))))))) + +;;; ((lambda ...) ...) +;;; +(defun byte-compile-unfold-lambda (form &optional name) + (or name (setq name "anonymous lambda")) + (let ((lambda (car form)) + (values (cdr form))) + (if (compiled-function-p lambda) + (setq lambda (list 'lambda (nth 0 form) + (list 'byte-code + (nth 1 form) (nth 2 form) (nth 3 form))))) + (let ((arglist (nth 1 lambda)) + (body (cdr (cdr lambda))) + optionalp restp + bindings) + (if (and (stringp (car body)) (cdr body)) + (setq body (cdr body))) + (if (and (consp (car body)) (eq 'interactive (car (car body)))) + (setq body (cdr body))) + (while arglist + (cond ((eq (car arglist) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr arglist)) + (error "nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car arglist) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in arglists. + (if (null (cdr arglist)) + (error "nothing after &rest in %s" name)) + (if (cdr (cdr arglist)) + (error "multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car arglist) + (and values (cons 'list values))) + bindings) + values nil)) + ((and (not optionalp) (null values)) + (byte-compile-warn "attempt to open-code %s with too few arguments" name) + (setq arglist nil values 'too-few)) + (t + (setq bindings (cons (list (car arglist) (car values)) + bindings) + values (cdr values)))) + (setq arglist (cdr arglist))) + (if values + (progn + (or (eq values 'too-few) + (byte-compile-warn + "attempt to open-code %s with too many arguments" name)) + form) + (let ((newform + (if bindings + (cons 'let (cons (nreverse bindings) body)) + (cons 'progn body)))) + (byte-compile-log " %s\t==>\t%s" form newform) + newform))))) + + +;;; implementing source-level optimizers + +(defun byte-optimize-form-code-walker (form for-effect) + ;; + ;; For normal function calls, We can just mapcar the optimizer the cdr. But + ;; we need to have special knowledge of the syntax of the special forms + ;; like let and defun (that's why they're special forms :-). (Actually, + ;; the important aspect is that they are subrs that don't evaluate all of + ;; their args.) + ;; + (let ((fn (car-safe form)) + tmp) + (cond ((not (consp form)) + (if (not (and for-effect + (or byte-compile-delete-errors + (not (symbolp form)) + (eq form t)))) + form)) + ((eq fn 'quote) + (if (cdr (cdr form)) + (byte-compile-warn "malformed quote form: %s" + (prin1-to-string form))) + ;; map (quote nil) to nil to simplify optimizer logic. + ;; map quoted constants to nil if for-effect (just because). + (and (nth 1 form) + (not for-effect) + form)) + ((or (compiled-function-p fn) + (eq 'lambda (car-safe fn))) + (byte-compile-unfold-lambda form)) + ((memq fn '(let let*)) + ;; recursively enter the optimizer for the bindings and body + ;; of a let or let*. This for depth-firstness: forms that + ;; are more deeply nested are optimized first. + (cons fn + (cons + (mapcar '(lambda (binding) + (if (symbolp binding) + binding + (if (cdr (cdr binding)) + (byte-compile-warn "malformed let binding: %s" + (prin1-to-string binding))) + (list (car binding) + (byte-optimize-form (nth 1 binding) nil)))) + (nth 1 form)) + (byte-optimize-body (cdr (cdr form)) for-effect)))) + ((eq fn 'cond) + (cons fn + (mapcar '(lambda (clause) + (if (consp clause) + (cons + (byte-optimize-form (car clause) nil) + (byte-optimize-body (cdr clause) for-effect)) + (byte-compile-warn "malformed cond form: %s" + (prin1-to-string clause)) + clause)) + (cdr form)))) + ((eq fn 'progn) + ;; as an extra added bonus, this simplifies (progn <x>) --> <x> + (if (cdr (cdr form)) + (progn + (setq tmp (byte-optimize-body (cdr form) for-effect)) + (if (cdr tmp) (cons 'progn tmp) (car tmp))) + (byte-optimize-form (nth 1 form) for-effect))) + ((eq fn 'prog1) + (if (cdr (cdr form)) + (cons 'prog1 + (cons (byte-optimize-form (nth 1 form) for-effect) + (byte-optimize-body (cdr (cdr form)) t))) + (byte-optimize-form (nth 1 form) for-effect))) + ((eq fn 'prog2) + (cons 'prog2 + (cons (byte-optimize-form (nth 1 form) t) + (cons (byte-optimize-form (nth 2 form) for-effect) + (byte-optimize-body (cdr (cdr (cdr form))) t))))) + + ((memq fn '(save-excursion save-restriction)) + ;; those subrs which have an implicit progn; it's not quite good + ;; enough to treat these like normal function calls. + ;; This can turn (save-excursion ...) into (save-excursion) which + ;; will be optimized away in the lap-optimize pass. + (cons fn (byte-optimize-body (cdr form) for-effect))) + + ((eq fn 'with-output-to-temp-buffer) + ;; this is just like the above, except for the first argument. + (cons fn + (cons + (byte-optimize-form (nth 1 form) nil) + (byte-optimize-body (cdr (cdr form)) for-effect)))) + + ((eq fn 'if) + (cons fn + (cons (byte-optimize-form (nth 1 form) nil) + (cons + (byte-optimize-form (nth 2 form) for-effect) + (byte-optimize-body (nthcdr 3 form) for-effect))))) + + ((memq fn '(and or)) ; remember, and/or are control structures. + ;; take forms off the back until we can't any more. + ;; In the future it could concievably be a problem that the + ;; subexpressions of these forms are optimized in the reverse + ;; order, but it's ok for now. + (if for-effect + (let ((backwards (reverse (cdr form)))) + (while (and backwards + (null (setcar backwards + (byte-optimize-form (car backwards) + for-effect)))) + (setq backwards (cdr backwards))) + (if (and (cdr form) (null backwards)) + (byte-compile-log + " all subforms of %s called for effect; deleted" form)) + (and backwards + (cons fn (nreverse backwards)))) + (cons fn (mapcar 'byte-optimize-form (cdr form))))) + + ((eq fn 'interactive) + (byte-compile-warn "misplaced interactive spec: %s" + (prin1-to-string form)) + nil) + + ((memq fn '(defun defmacro function + condition-case save-window-excursion)) + ;; These forms are compiled as constants or by breaking out + ;; all the subexpressions and compiling them separately. + form) + + ((eq fn 'unwind-protect) + ;; the "protected" part of an unwind-protect is compiled (and thus + ;; optimized) as a top-level form, so don't do it here. But the + ;; non-protected part has the same for-effect status as the + ;; unwind-protect itself. (The protected part is always for effect, + ;; but that isn't handled properly yet.) + (cons fn + (cons (byte-optimize-form (nth 1 form) for-effect) + (cdr (cdr form))))) + + ((eq fn 'catch) + ;; the body of a catch is compiled (and thus optimized) as a + ;; top-level form, so don't do it here. The tag is never + ;; for-effect. The body should have the same for-effect status + ;; as the catch form itself, but that isn't handled properly yet. + (cons fn + (cons (byte-optimize-form (nth 1 form) nil) + (cdr (cdr form))))) + + ;; If optimization is on, this is the only place that macros are + ;; expanded. If optimization is off, then macroexpansion happens + ;; in byte-compile-form. Otherwise, the macros are already expanded + ;; by the time that is reached. + ((not (eq form + (setq form (macroexpand form + byte-compile-macro-environment)))) + (byte-optimize-form form for-effect)) + + ((not (symbolp fn)) + (or (eq 'mocklisp (car-safe fn)) ; ha! + (byte-compile-warn "%s is a malformed function" + (prin1-to-string fn))) + form) + + ((and for-effect (setq tmp (get fn 'side-effect-free)) + (or byte-compile-delete-errors + (eq tmp 'error-free) + (progn + (byte-compile-warn "%s called for effect" + (prin1-to-string form)) + nil))) + (byte-compile-log " %s called for effect; deleted" fn) + ;; appending a nil here might not be necessary, but it can't hurt. + (byte-optimize-form + (cons 'progn (append (cdr form) '(nil))) t)) + + (t + ;; Otherwise, no args can be considered to be for-effect, + ;; even if the called function is for-effect, because we + ;; don't know anything about that function. + (cons fn (mapcar 'byte-optimize-form (cdr form))))))) + + +(defun byte-optimize-form (form &optional for-effect) + "The source-level pass of the optimizer." + ;; + ;; First, optimize all sub-forms of this one. + (setq form (byte-optimize-form-code-walker form for-effect)) + ;; + ;; after optimizing all subforms, optimize this form until it doesn't + ;; optimize any further. This means that some forms will be passed through + ;; the optimizer many times, but that's necessary to make the for-effect + ;; processing do as much as possible. + ;; + (let (opt new) + (if (and (consp form) + (symbolp (car form)) + (or (and for-effect + ;; we don't have any of these yet, but we might. + (setq opt (get (car form) 'byte-for-effect-optimizer))) + (setq opt (get (car form) 'byte-optimizer))) + (not (eq form (setq new (funcall opt form))))) + (progn +;; (if (equal form new) (error "bogus optimizer -- %s" opt)) + (byte-compile-log " %s\t==>\t%s" form new) + (setq new (byte-optimize-form new for-effect)) + new) + form))) + + +(defun byte-optimize-body (forms all-for-effect) + ;; optimize the cdr of a progn or implicit progn; all forms is a list of + ;; forms, all but the last of which are optimized with the assumption that + ;; they are being called for effect. the last is for-effect as well if + ;; all-for-effect is true. returns a new list of forms. + (let ((rest forms) + (result nil) + fe new) + (while rest + (setq fe (or all-for-effect (cdr rest))) + (setq new (and (car rest) (byte-optimize-form (car rest) fe))) + (if (or new (not fe)) + (setq result (cons new result))) + (setq rest (cdr rest))) + (nreverse result))) + + +;;; some source-level optimizers +;;; +;;; when writing optimizers, be VERY careful that the optimizer returns +;;; something not EQ to its argument if and ONLY if it has made a change. +;;; This implies that you cannot simply destructively modify the list; +;;; you must return something not EQ to it if you make an optimization. +;;; +;;; It is now safe to optimize code such that it introduces new bindings. + +;; I'd like this to be a defsubst, but let's not be self-referental... +(defmacro byte-compile-trueconstp (form) + ;; Returns non-nil if FORM is a non-nil constant. + (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) + ((not (symbolp (, form)))) + ((eq (, form) t))))) + +(defun byte-optimize-associative-math (form) + "If the function is being called with constant numeric args, +evaluate as much as possible at compile-time. This optimizer +assumes that the function is associative, like + or *." + (let ((args nil) + (constants nil) + (rest (cdr form))) + (while rest + (if (numberp (car rest)) + (setq constants (cons (car rest) constants)) + (setq args (cons (car rest) args))) + (setq rest (cdr rest))) + (if (cdr constants) + (if args + (list (car form) + (apply (car form) constants) + (if (cdr args) + (cons (car form) (nreverse args)) + (car args))) + (apply (car form) constants)) + form))) + +(defun byte-optimize-nonassociative-math (form) + "If the function is being called with constant numeric args, +evaluate as much as possible at compile-time. This optimizer +assumes that the function is nonassociative, like - or /." + (if (or (not (numberp (car (cdr form)))) + (not (numberp (car (cdr (cdr form)))))) + form + (let ((constant (car (cdr form))) + (rest (cdr (cdr form)))) + (while (numberp (car rest)) + (setq constant (funcall (car form) constant (car rest)) + rest (cdr rest))) + (if rest + (cons (car form) (cons constant rest)) + constant)))) + +;;(defun byte-optimize-associative-two-args-math (form) +;; (setq form (byte-optimize-associative-math form)) +;; (if (consp form) +;; (byte-optimize-two-args-left form) +;; form)) + +;;(defun byte-optimize-nonassociative-two-args-math (form) +;; (setq form (byte-optimize-nonassociative-math form)) +;; (if (consp form) +;; (byte-optimize-two-args-right form) +;; form)) + +(defun byte-optimize-delay-constants-math (form start fun) + ;; Merge all FORM's constants from number START, call FUN on them + ;; and put the result at the end. + (let ((rest (nthcdr (1- start) form))) + (while (cdr (setq rest (cdr rest))) + (if (numberp (car rest)) + (let (constants) + (setq form (copy-sequence form) + rest (nthcdr (1- start) form)) + (while (setq rest (cdr rest)) + (cond ((numberp (car rest)) + (setq constants (cons (car rest) constants)) + (setcar rest nil)))) + (setq form (nconc (delq nil form) + (list (apply fun (nreverse constants)))))))) + form)) + +(defun byte-optimize-plus (form) + (setq form (byte-optimize-delay-constants-math form 1 '+)) + (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) + ;;(setq form (byte-optimize-associative-two-args-math form)) + (cond ((null (cdr form)) + (condition-case () + (eval form) + (error form))) + ((null (cdr (cdr form))) (nth 1 form)) + (t form))) + +(defun byte-optimize-minus (form) + ;; Put constants at the end, except the last constant. + (setq form (byte-optimize-delay-constants-math form 2 '+)) + ;; Now only first and last element can be a number. + (let ((last (car (reverse (nthcdr 3 form))))) + (cond ((eq 0 last) + ;; (- x y ... 0) --> (- x y ...) + (setq form (copy-sequence form)) + (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) + ;; If form is (- CONST foo... CONST), merge first and last. + ((and (numberp (nth 1 form)) + (numberp last)) + (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) + (delq last (copy-sequence (nthcdr 3 form)))))))) + (if (eq (nth 2 form) 0) + (nth 1 form) ; (- x 0) --> x + (byte-optimize-predicate + (if (and (null (cdr (cdr (cdr form)))) + (eq (nth 1 form) 0)) ; (- 0 x) --> (- x) + (cons (car form) (cdr (cdr form))) + form)))) + +(defun byte-optimize-multiply (form) + (setq form (byte-optimize-delay-constants-math form 1 '*)) + ;; If there is a constant in FORM, it is now the last element. + (cond ((null (cdr form)) 1) + ((null (cdr (cdr form))) (nth 1 form)) + ((let ((last (car (reverse form)))) + (cond ((eq 0 last) (list 'progn (cdr form))) + ((eq 1 last) (delq 1 (copy-sequence form))) + ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) + ((and (eq 2 last) + (memq t (mapcar 'symbolp (cdr form)))) + (prog1 (setq form (delq 2 (copy-sequence form))) + (while (not (symbolp (car (setq form (cdr form)))))) + (setcar form (list '+ (car form) (car form))))) + (form)))))) + +(defsubst byte-compile-butlast (form) + (nreverse (cdr (reverse form)))) + +(defun byte-optimize-divide (form) + (setq form (byte-optimize-delay-constants-math form 2 '*)) + (let ((last (car (reverse (cdr (cdr form)))))) + (if (numberp last) + (cond ((= last 1) + (setq form (byte-compile-butlast form))) + ((numberp (nth 1 form)) + (setq form (cons (car form) + (cons (/ (nth 1 form) last) + (byte-compile-butlast (cdr (cdr form))))) + last nil)))) + (cond ((null (cdr (cdr form))) + (nth 1 form)) + ((eq (nth 1 form) 0) + (append '(progn) (cdr (cdr form)) '(0))) + ((eq last -1) + (list '- (if (nthcdr 3 form) + (byte-compile-butlast form) + (nth 1 form)))) + (form)))) + +(defun byte-optimize-logmumble (form) + (setq form (byte-optimize-delay-constants-math form 1 (car form))) + (byte-optimize-predicate + (cond ((memq 0 form) + (setq form (if (eq (car form) 'logand) + (cons 'progn (cdr form)) + (delq 0 (copy-sequence form))))) + ((and (eq (car-safe form) 'logior) + (memq -1 form)) + (delq -1 (copy-sequence form))) + (form)))) + + +(defun byte-optimize-binary-predicate (form) + (if (byte-compile-constp (nth 1 form)) + (if (byte-compile-constp (nth 2 form)) + (condition-case () + (list 'quote (eval form)) + (error form)) + ;; This can enable some lapcode optimizations. + (list (car form) (nth 2 form) (nth 1 form))) + form)) + +(defun byte-optimize-predicate (form) + (let ((ok t) + (rest (cdr form))) + (while (and rest ok) + (setq ok (byte-compile-constp (car rest)) + rest (cdr rest))) + (if ok + (condition-case () + (list 'quote (eval form)) + (error form)) + form))) + +(defun byte-optimize-identity (form) + (if (and (cdr form) (null (cdr (cdr form)))) + (nth 1 form) + (byte-compile-warn "identity called with %d arg%s, but requires 1" + (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s")) + form)) + +(put 'identity 'byte-optimizer 'byte-optimize-identity) + +(put '+ 'byte-optimizer 'byte-optimize-plus) +(put '* 'byte-optimizer 'byte-optimize-multiply) +(put '- 'byte-optimizer 'byte-optimize-minus) +(put '/ 'byte-optimizer 'byte-optimize-divide) +(put 'max 'byte-optimizer 'byte-optimize-associative-math) +(put 'min 'byte-optimizer 'byte-optimize-associative-math) + +(put '= 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) +(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) + +(put '< 'byte-optimizer 'byte-optimize-predicate) +(put '> 'byte-optimizer 'byte-optimize-predicate) +(put '<= 'byte-optimizer 'byte-optimize-predicate) +(put '>= 'byte-optimizer 'byte-optimize-predicate) +(put '1+ 'byte-optimizer 'byte-optimize-predicate) +(put '1- 'byte-optimizer 'byte-optimize-predicate) +(put 'not 'byte-optimizer 'byte-optimize-predicate) +(put 'null 'byte-optimizer 'byte-optimize-predicate) +(put 'memq 'byte-optimizer 'byte-optimize-predicate) +(put 'consp 'byte-optimizer 'byte-optimize-predicate) +(put 'listp 'byte-optimizer 'byte-optimize-predicate) +(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) +(put 'stringp 'byte-optimizer 'byte-optimize-predicate) +(put 'string< 'byte-optimizer 'byte-optimize-predicate) +(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) + +(put 'logand 'byte-optimizer 'byte-optimize-logmumble) +(put 'logior 'byte-optimizer 'byte-optimize-logmumble) +(put 'logxor 'byte-optimizer 'byte-optimize-logmumble) +(put 'lognot 'byte-optimizer 'byte-optimize-predicate) + +(put 'car 'byte-optimizer 'byte-optimize-predicate) +(put 'cdr 'byte-optimizer 'byte-optimize-predicate) +(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) +(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) + + +;; I'm not convinced that this is necessary. Doesn't the optimizer loop +;; take care of this? - Jamie +;; I think this may some times be necessary to reduce ie (quote 5) to 5, +;; so arithmetic optimizers recognize the numerinc constant. - Hallvard +(put 'quote 'byte-optimizer 'byte-optimize-quote) +(defun byte-optimize-quote (form) + (if (or (consp (nth 1 form)) + (and (symbolp (nth 1 form)) + (not (memq (nth 1 form) '(nil t))))) + form + (nth 1 form))) + +(defun byte-optimize-zerop (form) + (cond ((numberp (nth 1 form)) + (eval form)) + (byte-compile-delete-errors + (list '= (nth 1 form) 0)) + (form))) + +(put 'zerop 'byte-optimizer 'byte-optimize-zerop) + +(defun byte-optimize-and (form) + ;; Simplify if less than 2 args. + ;; if there is a literal nil in the args to `and', throw it and following + ;; forms away, and surround the `and' with (progn ... nil). + (cond ((null (cdr form))) + ((memq nil form) + (list 'progn + (byte-optimize-and + (prog1 (setq form (copy-sequence form)) + (while (nth 1 form) + (setq form (cdr form))) + (setcdr form nil))) + nil)) + ((null (cdr (cdr form))) + (nth 1 form)) + ((byte-optimize-predicate form)))) + +(defun byte-optimize-or (form) + ;; Throw away nil's, and simplify if less than 2 args. + ;; If there is a literal non-nil constant in the args to `or', throw away all + ;; following forms. + (if (memq nil form) + (setq form (delq nil (copy-sequence form)))) + (let ((rest form)) + (while (cdr (setq rest (cdr rest))) + (if (byte-compile-trueconstp (car rest)) + (setq form (copy-sequence form) + rest (setcdr (memq (car rest) form) nil)))) + (if (cdr (cdr form)) + (byte-optimize-predicate form) + (nth 1 form)))) + +(defun byte-optimize-cond (form) + ;; if any clauses have a literal nil as their test, throw them away. + ;; if any clause has a literal non-nil constant as its test, throw + ;; away all following clauses. + (let (rest) + ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...) + (while (setq rest (assq nil (cdr form))) + (setq form (delq rest (copy-sequence form)))) + (if (memq nil (cdr form)) + (setq form (delq nil (copy-sequence form)))) + (setq rest form) + (while (setq rest (cdr rest)) + (cond ((byte-compile-trueconstp (car-safe (car rest))) + (cond ((eq rest (cdr form)) + (setq form + (if (cdr (car rest)) + (if (cdr (cdr (car rest))) + (cons 'progn (cdr (car rest))) + (nth 1 (car rest))) + (car (car rest))))) + ((cdr rest) + (setq form (copy-sequence form)) + (setcdr (memq (car rest) form) nil))) + (setq rest nil))))) + ;; + ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... )) + (if (eq 'cond (car-safe form)) + (let ((clauses (cdr form))) + (if (and (consp (car clauses)) + (null (cdr (car clauses)))) + (list 'or (car (car clauses)) + (byte-optimize-cond + (cons (car form) (cdr (cdr form))))) + form)) + form)) + +(defun byte-optimize-if (form) + ;; (if <true-constant> <then> <else...>) ==> <then> + ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) + ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) + ;; (if <test> <then> nil) ==> (if <test> <then>) + (let ((clause (nth 1 form))) + (cond ((byte-compile-trueconstp clause) + (nth 2 form)) + ((null clause) + (if (nthcdr 4 form) + (cons 'progn (nthcdr 3 form)) + (nth 3 form))) + ((nth 2 form) + (if (equal '(nil) (nthcdr 3 form)) + (list 'if clause (nth 2 form)) + form)) + ((or (nth 3 form) (nthcdr 4 form)) + (list 'if (list 'not clause) + (if (nthcdr 4 form) + (cons 'progn (nthcdr 3 form)) + (nth 3 form)))) + (t + (list 'progn clause nil))))) + +(defun byte-optimize-while (form) + (if (nth 1 form) + form)) + +(put 'and 'byte-optimizer 'byte-optimize-and) +(put 'or 'byte-optimizer 'byte-optimize-or) +(put 'cond 'byte-optimizer 'byte-optimize-cond) +(put 'if 'byte-optimizer 'byte-optimize-if) +(put 'while 'byte-optimizer 'byte-optimize-while) + +;; byte-compile-negation-optimizer lives in bytecomp.el +(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) +(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) +(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) + + +(defun byte-optimize-funcall (form) + ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) + ;; (funcall 'foo ...) ==> (foo ...) + (let ((fn (nth 1 form))) + (if (memq (car-safe fn) '(quote function)) + (cons (nth 1 fn) (cdr (cdr form))) + form))) + +(defun byte-optimize-apply (form) + ;; If the last arg is a literal constant, turn this into a funcall. + ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). + (let ((fn (nth 1 form)) + (last (nth (1- (length form)) form))) ; I think this really is fastest + (or (if (or (null last) + (eq (car-safe last) 'quote)) + (if (listp (nth 1 last)) + (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) + (nconc (list 'funcall fn) butlast (nth 1 last))) + (byte-compile-warn + "last arg to apply can't be a literal atom: %s" + (prin1-to-string last)) + nil)) + form))) + +(put 'funcall 'byte-optimizer 'byte-optimize-funcall) +(put 'apply 'byte-optimizer 'byte-optimize-apply) + + +(put 'let 'byte-optimizer 'byte-optimize-letX) +(put 'let* 'byte-optimizer 'byte-optimize-letX) +(defun byte-optimize-letX (form) + (cond ((null (nth 1 form)) + ;; No bindings + (cons 'progn (cdr (cdr form)))) + ((or (nth 2 form) (nthcdr 3 form)) + form) + ;; The body is nil + ((eq (car form) 'let) + (append '(progn) (mapcar 'car (mapcar 'cdr (nth 1 form))) '(nil))) + (t + (let ((binds (reverse (nth 1 form)))) + (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) + + +(put 'nth 'byte-optimizer 'byte-optimize-nth) +(defun byte-optimize-nth (form) + (if (memq (nth 1 form) '(0 1)) + (list 'car (if (zerop (nth 1 form)) + (nth 2 form) + (list 'cdr (nth 2 form)))) + (byte-optimize-predicate form))) + +(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) +(defun byte-optimize-nthcdr (form) + (let ((count (nth 1 form))) + (if (not (memq count '(0 1 2))) + (byte-optimize-predicate form) + (setq form (nth 2 form)) + (while (natnump (setq count (1- count))) + (setq form (list 'cdr form))) + form))) + +;;; enumerating those functions which need not be called if the returned +;;; value is not used. That is, something like +;;; (progn (list (something-with-side-effects) (yow)) +;;; (foo)) +;;; may safely be turned into +;;; (progn (progn (something-with-side-effects) (yow)) +;;; (foo)) +;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. + +;;; I wonder if I missed any :-\) +(let ((side-effect-free-fns + '(% * + / /= 1+ < <= = > >= append aref ash assoc assq boundp + buffer-file-name buffer-local-variables buffer-modified-p + buffer-substring capitalize car cdr concat coordinates-in-window-p + copy-marker count-lines documentation downcase elt fboundp featurep + file-directory-p file-exists-p file-locked-p file-name-absolute-p + file-newer-than-file-p file-readable-p file-symlink-p file-writable-p + format get get-buffer get-buffer-window getenv get-file-buffer length + logand logior lognot logxor lsh marker-buffer max member memq min mod + next-window nth nthcdr previous-window rassq regexp-quote reverse + string< string= string-lessp string-equal substring user-variable-p + window-buffer window-edges window-height window-hscroll window-width + zerop)) + ;; could also add plusp, minusp, signum. If anyone ever defines + ;; these, they will certainly be side-effect free. + (side-effect-and-error-free-fns + '(arrayp atom bobp bolp buffer-end buffer-list buffer-size + buffer-string bufferp char-or-string-p commandp cons consp + current-buffer dot dot-marker eobp eolp eq eql equal + get-largest-window identity integerp integer-or-marker-p + interactive-p keymapp list listp make-marker mark mark-marker + markerp minibuffer-window natnump nlistp not null numberp + one-window-p point point-marker processp selected-window sequencep + stringp subrp symbolp syntax-table-p vector vectorp windowp))) + (while side-effect-free-fns + (put (car side-effect-free-fns) 'side-effect-free t) + (setq side-effect-free-fns (cdr side-effect-free-fns))) + (while side-effect-and-error-free-fns + (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free) + (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns))) + nil) + + +(defun byte-compile-splice-in-already-compiled-code (form) + ;; form is (byte-code "..." [...] n) + (if (not (memq byte-optimize '(t lap))) + (byte-compile-normal-call form) + (byte-inline-lapcode + (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t)) + (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form)) + byte-compile-maxdepth)) + (setq byte-compile-depth (1+ byte-compile-depth)))) + +(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code) + + +(defconst byte-constref-ops + '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) + +;;; This function extracts the bitfields from variable-length opcodes. +;;; Originally defined in disass.el (which no longer uses it.) + +(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 + (defvar op) + (defvar ptr) + (defvar bytes) + (cond ((< op byte-nth) + (let ((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) + (prog1 (- op byte-constant) ;offset in opcode + (setq op byte-constant))) + ((and (>= op byte-constant2) + (<= 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)))) + ((and (>= op byte-rel-goto) + (<= op byte-insertN)) + (setq ptr (1+ ptr)) ;offset in next byte + (aref bytes ptr)))) + + +;;; This de-compiler is used for inline expansion of compiled functions, +;;; and by the disassembler. +;;; +(defun byte-decompile-bytecode (bytes constvec) + "Turns BYTECODE into lapcode, refering to CONSTVEC." + (let ((byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0)) + (byte-decompile-bytecode-1 bytes constvec))) + +(defun byte-decompile-bytecode-1 (bytes constvec &optional make-splicable) + "As byte-decompile-bytecode, but updates +byte-compile-{constants, variables, tag-number}. +If the optional 3rd arg is true, then `return' opcodes are replaced +with `goto's destined for the end of the code." + (let ((length (length bytes)) + (ptr 0) optr tag tags op offset + lap tmp + endtag + (retcount 0)) + (while (not (= ptr length)) + (setq op (aref bytes ptr) + optr ptr + offset (disassemble-offset)) ; this does dynamic-scope magic + (setq op (aref byte-code-vector op)) + (cond ((or (memq op byte-goto-ops) + (cond ((memq op byte-rel-goto-ops) + (setq op (aref byte-code-vector + (- (symbol-value op) + (- byte-rel-goto byte-goto)))) + (setq offset (+ ptr (- offset 127))) + t))) + ;; it's a pc + (setq offset + (cdr (or (assq offset tags) + (car (setq tags + (cons (cons offset + (byte-compile-make-tag)) + tags))))))) + ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) + ((memq op byte-constref-ops))) + (setq tmp (aref constvec offset) + offset (if (eq op 'byte-constant) + (byte-compile-get-constant tmp) + (or (assq tmp byte-compile-variables) + (car (setq byte-compile-variables + (cons (list tmp) + byte-compile-variables))))))) + ((and make-splicable + (eq op 'byte-return)) + (if (= ptr (1- length)) + (setq op nil) + (setq offset (or endtag (setq endtag (byte-compile-make-tag))) + op 'byte-goto)))) + ;; lap = ( [ (pc . (op . arg)) ]* ) + (setq lap (cons (cons optr (cons op (or offset 0))) + lap)) + (setq ptr (1+ ptr))) + ;; take off the dummy nil op that we replaced a trailing "return" with. + (let ((rest lap)) + (while rest + (cond ((setq tmp (assq (car (car rest)) tags)) + ;; this addr is jumped to + (setcdr rest (cons (cons nil (cdr tmp)) + (cdr rest))) + (setq tags (delq tmp tags)) + (setq rest (cdr rest)))) + (setq rest (cdr rest)))) + (if tags (error "optimizer error: missed tags %s" tags)) + (if (null (car (cdr (car lap)))) + (setq lap (cdr lap))) + (if endtag + (setq lap (cons (cons nil endtag) lap))) + ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* ) + (mapcar 'cdr (nreverse lap)))) + + +;;; peephole optimizer + +(defconst byte-tagref-ops (cons 'TAG byte-goto-ops)) + +(defconst byte-conditional-ops + '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + +(defconst byte-after-unbind-ops + '(byte-constant byte-dup + byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp + byte-eq byte-equal byte-not + byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 + byte-interactive-p + ;; How about other side-effect-free-ops? Is it safe to move an + ;; error invocation (such as from nth) out of an unwind-protect? + "Byte-codes that can be moved past an unbind.")) + +(defconst byte-compile-side-effect-and-error-free-ops + '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp + byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe + byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max + byte-point-min byte-following-char byte-preceding-char + byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp + byte-current-buffer byte-interactive-p)) + +(defconst byte-compile-side-effect-free-ops + (nconc + '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref + byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 + byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate + byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax + byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt + byte-member byte-assq byte-quo byte-rem) + byte-compile-side-effect-and-error-free-ops)) + +;;; This piece of shit is because of the way DEFVAR_BOOL() variables work. +;;; Consider the code +;;; +;;; (defun foo (flag) +;;; (let ((old-pop-ups pop-up-windows) +;;; (pop-up-windows flag)) +;;; (cond ((not (eq pop-up-windows old-pop-ups)) +;;; (setq old-pop-ups pop-up-windows) +;;; ...)))) +;;; +;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is +;;; something else. But if we optimize +;;; +;;; varref flag +;;; varbind pop-up-windows +;;; varref pop-up-windows +;;; not +;;; to +;;; varref flag +;;; dup +;;; varbind pop-up-windows +;;; not +;;; +;;; we break the program, because it will appear that pop-up-windows and +;;; old-pop-ups are not EQ when really they are. So we have to know what +;;; the BOOL variables are, and not perform this optimization on them. +;;; +(defconst byte-boolean-vars + '(abbrevs-changed abbrev-all-caps inverse-video visible-bell + check-protected-fields no-redraw-on-reenter cursor-in-echo-area + noninteractive stack-trace-on-error debug-on-error debug-on-quit + debug-on-next-call insert-default-directory vms-stmlf-recfm + indent-tabs-mode meta-flag load-in-progress defining-kbd-macro + completion-auto-help completion-ignore-case enable-recursive-minibuffers + print-escape-newlines delete-exited-processes parse-sexp-ignore-comments + words-include-escapes pop-up-windows auto-new-screen + reset-terminal-on-clear truncate-partial-width-windows + mode-line-inverse-video) + "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t. +If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer +may generate incorrect code.") + +(defun byte-optimize-lapcode (lap &optional for-effect) + "Simple peephole optimizer. LAP is both modified and returned." + (let (lap0 off0 + lap1 off1 + lap2 off2 + (keep-going 'first-time) + (add-depth 0) + rest tmp tmp2 tmp3 + (side-effect-free (if byte-compile-delete-errors + byte-compile-side-effect-free-ops + byte-compile-side-effect-and-error-free-ops))) + (while keep-going + (or (eq keep-going 'first-time) + (byte-compile-log-lap " ---- next pass")) + (setq rest lap + keep-going nil) + (while rest + (setq lap0 (car rest) + lap1 (nth 1 rest) + lap2 (nth 2 rest)) + + ;; You may notice that sequences like "dup varset discard" are + ;; optimized but sequences like "dup varset TAG1: discard" are not. + ;; You may be tempted to change this; resist that temptation. + (cond ;; + ;; <side-effect-free> pop --> <deleted> + ;; ...including: + ;; const-X pop --> <deleted> + ;; varref-X pop --> <deleted> + ;; dup pop --> <deleted> + ;; + ((and (eq 'byte-discard (car lap1)) + (memq (car lap0) side-effect-free)) + (setq keep-going t) + (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) + (setq rest (cdr rest)) + (cond ((= tmp 1) + (byte-compile-log-lap + " %s discard\t-->\t<deleted>" lap0) + (setq lap (delq lap0 (delq lap1 lap)))) + ((= tmp 0) + (byte-compile-log-lap + " %s discard\t-->\t<deleted> discard" lap0) + (setq lap (delq lap0 lap))) + ((= tmp -1) + (byte-compile-log-lap + " %s discard\t-->\tdiscard discard" lap0) + (setcar lap0 'byte-discard) + (setcdr lap0 0)) + ((error "Optimizer error: too much on the stack")))) + ;; + ;; goto*-X X: --> X: + ;; + ((and (memq (car lap0) byte-goto-ops) + (eq (cdr lap0) lap1)) + (cond ((eq (car lap0) 'byte-goto) + (setq lap (delq lap0 lap)) + (setq tmp "<deleted>")) + ((memq (car lap0) byte-goto-always-pop-ops) + (setcar lap0 (setq tmp 'byte-discard)) + (setcdr lap0 0)) + ((error "Depth conflict at tag %d" (nth 2 lap0)))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " (goto %s) %s:\t-->\t%s %s:" + (nth 1 lap1) (nth 1 lap1) + tmp (nth 1 lap1))) + (setq keep-going t)) + ;; + ;; varset-X varref-X --> dup varset-X + ;; varbind-X varref-X --> dup varbind-X + ;; const/dup varset-X varref-X --> const/dup varset-X const/dup + ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup + ;; The latter two can enable other optimizations. + ;; + ((and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + (not (eq (car lap0) 'byte-constant))) + nil + (setq keep-going t) + (if (memq (car lap0) '(byte-constant byte-dup)) + (progn + (setq tmp (if (or (not tmp) + (memq (car (cdr lap0)) '(nil t))) + (cdr lap0) + (byte-compile-get-constant t))) + (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" + lap0 lap1 lap2 lap0 lap1 + (cons (car lap0) tmp)) + (setcar lap2 (car lap0)) + (setcdr lap2 tmp)) + (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1) + (setcar lap2 (car lap1)) + (setcar lap1 'byte-dup) + (setcdr lap1 0) + ;; The stack depth gets locally increased, so we will + ;; increase maxdepth in case depth = maxdepth here. + ;; This can cause the third argument to byte-code to + ;; be larger than necessary. + (setq add-depth 1)))) + ;; + ;; dup varset-X discard --> varset-X + ;; dup varbind-X discard --> varbind-X + ;; (the varbind variant can emerge from other optimizations) + ;; + ((and (eq 'byte-dup (car lap0)) + (eq 'byte-discard (car lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) + (setq keep-going t + rest (cdr rest)) + (setq lap (delq lap0 (delq lap2 lap)))) + ;; + ;; not goto-X-if-nil --> goto-X-if-non-nil + ;; not goto-X-if-non-nil --> goto-X-if-nil + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (eq 'byte-not (car lap0)) + (or (eq 'byte-goto-if-nil (car lap1)) + (eq 'byte-goto-if-not-nil (car lap1)))) + (byte-compile-log-lap " not %s\t-->\t%s" + lap1 + (cons + (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil) + (cdr lap1))) + (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil) + 'byte-goto-if-not-nil + 'byte-goto-if-nil)) + (setq lap (delq lap0 lap)) + (setq keep-going t)) + ;; + ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: + ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: + ;; + ;; it is wrong to do the same thing for the -else-pop variants. + ;; + ((and (or (eq 'byte-goto-if-nil (car lap0)) + (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX + (eq 'byte-goto (car lap1)) ; gotoY + (eq (cdr lap0) lap2)) ; TAG X + (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) + 'byte-goto-if-not-nil 'byte-goto-if-nil))) + (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" + lap0 lap1 lap2 + (cons inverse (cdr lap1)) lap2) + (setq lap (delq lap0 lap)) + (setcar lap1 inverse) + (setq keep-going t))) + ;; + ;; const goto-if-* --> whatever + ;; + ((and (eq 'byte-constant (car lap0)) + (memq (car lap1) byte-conditional-ops)) + (cond ((if (or (eq (car lap1) 'byte-goto-if-nil) + (eq (car lap1) 'byte-goto-if-nil-else-pop)) + (car (cdr lap0)) + (not (car (cdr lap0)))) + (byte-compile-log-lap " %s %s\t-->\t<deleted>" + lap0 lap1) + (setq rest (cdr rest) + lap (delq lap0 (delq lap1 lap)))) + (t + (if (memq (car lap1) byte-goto-always-pop-ops) + (progn + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 (cons 'byte-goto (cdr lap1))) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-goto (cdr lap1)))) + (setcar lap1 'byte-goto))) + (setq keep-going t)) + ;; + ;; varref-X varref-X --> varref-X dup + ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup + ;; We don't optimize the const-X variations on this here, + ;; because that would inhibit some goto optimizations; we + ;; optimize the const-X case after all other optimizations. + ;; + ((and (eq 'byte-varref (car lap0)) + (progn + (setq tmp (cdr rest)) + (while (eq (car (car tmp)) 'byte-dup) + (setq tmp (cdr tmp))) + t) + (eq (cdr lap0) (cdr (car tmp))) + (eq 'byte-varref (car (car tmp)))) + (if (memq byte-optimize-log '(t byte)) + (let ((str "")) + (setq tmp2 (cdr rest)) + (while (not (eq tmp tmp2)) + (setq tmp2 (cdr tmp2) + str (concat str " dup"))) + (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup" + lap0 str lap0 lap0 str))) + (setq keep-going t) + (setcar (car tmp) 'byte-dup) + (setcdr (car tmp) 0) + (setq rest tmp)) + ;; + ;; TAG1: TAG2: --> TAG1: <deleted> + ;; (and other references to TAG2 are replaced with TAG1) + ;; + ((and (eq (car lap0) 'TAG) + (eq (car lap1) 'TAG)) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " adjascent tags %d and %d merged" + (nth 1 lap1) (nth 1 lap0))) + (setq tmp3 lap) + (while (setq tmp2 (rassq lap0 tmp3)) + (setcdr tmp2 lap1) + (setq tmp3 (cdr (memq tmp2 tmp3)))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; unused-TAG: --> <deleted> + ;; + ((and (eq 'TAG (car lap0)) + (not (rassq lap0 lap))) + (and (memq byte-optimize-log '(t byte)) + (byte-compile-log " unused tag %d removed" (nth 1 lap0))) + (setq lap (delq lap0 lap) + keep-going t)) + ;; + ;; goto ... --> goto <delete until TAG or end> + ;; return ... --> return <delete until TAG or end> + ;; + ((and (memq (car lap0) '(byte-goto byte-return)) + (not (memq (car lap1) '(TAG nil)))) + (setq tmp rest) + (let ((i 0) + (opt-p (memq byte-optimize-log '(t lap))) + str deleted) + (while (and (setq tmp (cdr tmp)) + (not (eq 'TAG (car (car tmp))))) + (if opt-p (setq deleted (cons (car tmp) deleted) + str (concat str " %s") + i (1+ i)))) + (if opt-p + (let ((tagstr + (if (eq 'TAG (car (car tmp))) + (format "%d:" (cdr (car tmp))) + (or (car tmp) "")))) + (if (< i 6) + (apply 'byte-compile-log-lap-1 + (concat " %s" str + " %s\t-->\t%s <deleted> %s") + lap0 + (nconc (nreverse deleted) + (list tagstr lap0 tagstr))) + (byte-compile-log-lap + " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s" + lap0 i (if (= i 1) "" "s") + tagstr lap0 tagstr)))) + (rplacd rest tmp)) + (setq keep-going t)) + ;; + ;; <safe-op> unbind --> unbind <safe-op> + ;; (this may enable other optimizations.) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) byte-after-unbind-ops)) + (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) + (setcar rest lap1) + (setcar (cdr rest) lap0) + (setq keep-going t)) + ;; + ;; varbind-X unbind-N --> discard unbind-(N-1) + ;; save-excursion unbind-N --> unbind-(N-1) + ;; save-restriction unbind-N --> unbind-(N-1) + ;; + ((and (eq 'byte-unbind (car lap1)) + (memq (car lap0) '(byte-varbind byte-save-excursion + byte-save-restriction)) + (< 0 (cdr lap1))) + (if (zerop (setcdr lap1 (1- (cdr lap1)))) + (delq lap1 rest)) + (if (eq (car lap0) 'byte-varbind) + (setcar rest (cons 'byte-discard 0)) + (setq lap (delq lap0 lap))) + (byte-compile-log-lap " %s %s\t-->\t%s %s" + lap0 (cons (car lap1) (1+ (cdr lap1))) + (if (eq (car lap0) 'byte-varbind) + (car rest) + (car (cdr rest))) + (if (and (/= 0 (cdr lap1)) + (eq (car lap0) 'byte-varbind)) + (car (cdr rest)) + "")) + (setq keep-going t)) + ;; + ;; goto*-X ... X: goto-Y --> goto*-Y + ;; goto-X ... X: return --> return + ;; + ((and (memq (car lap0) byte-goto-ops) + (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap)))) + '(byte-goto byte-return))) + (cond ((and (not (eq tmp lap0)) + (or (eq (car lap0) 'byte-goto) + (eq (car tmp) 'byte-goto))) + (byte-compile-log-lap " %s [%s]\t-->\t%s" + (car lap0) tmp tmp) + (if (eq (car tmp) 'byte-return) + (setcar lap0 'byte-return)) + (setcdr lap0 (cdr tmp)) + (setq keep-going t)))) + ;; + ;; goto-*-else-pop X ... X: goto-if-* --> whatever + ;; goto-*-else-pop X ... X: discard --> whatever + ;; + ((and (memq (car lap0) '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop)) + (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap0 (car tmp)))) + (setq tmp2 (car tmp)) + (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop + byte-goto-if-nil) + (byte-goto-if-not-nil-else-pop + byte-goto-if-not-nil)))) + (if (memq (car tmp2) tmp3) + (progn (setcar lap0 (car tmp2)) + (setcdr lap0 (cdr tmp2)) + (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s" + (car lap0) tmp2 lap0)) + ;; Get rid of the -else-pop's and jump one step further. + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>" + (car lap0) tmp2 (nth 1 tmp3)) + (setcar lap0 (nth 1 tmp3)) + (setcdr lap0 (nth 1 tmp))) + (setq keep-going t)) + ;; + ;; const goto-X ... X: goto-if-* --> whatever + ;; const goto-X ... X: discard --> whatever + ;; + ((and (eq (car lap0) 'byte-constant) + (eq (car lap1) 'byte-goto) + (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap))))) + (eval-when-compile + (cons 'byte-discard byte-conditional-ops))) + (not (eq lap1 (car tmp)))) + (setq tmp2 (car tmp)) + (cond ((memq (car tmp2) + (if (null (car (cdr lap0))) + '(byte-goto-if-nil byte-goto-if-nil-else-pop) + '(byte-goto-if-not-nil + byte-goto-if-not-nil-else-pop))) + (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s" + lap0 tmp2 lap0 tmp2) + (setcar lap1 (car tmp2)) + (setcdr lap1 (cdr tmp2)) + ;; Let next step fix the (const,goto-if*) sequence. + (setq rest (cons nil rest))) + (t + ;; Jump one step further + (byte-compile-log-lap + " %s goto [%s]\t-->\t<deleted> goto <skip>" + lap0 tmp2) + (or (eq 'TAG (car (nth 1 tmp))) + (setcdr tmp (cons (byte-compile-make-tag) + (cdr tmp)))) + (setcdr lap1 (car (cdr tmp))) + (setq lap (delq lap0 lap)))) + (setq keep-going t)) + ;; + ;; X: varref-Y ... varset-Y goto-X --> + ;; X: varref-Y Z: ... dup varset-Y goto-Z + ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) + ;; (This is so usual for while loops that it is worth handling). + ;; + ((and (eq (car lap1) 'byte-varset) + (eq (car lap2) 'byte-goto) + (not (memq (cdr lap2) rest)) ;Backwards jump + (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) + 'byte-varref) + (eq (cdr (car tmp)) (cdr lap1)) + (not (memq (car (cdr lap1)) byte-boolean-vars))) + ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s" + (nth 1 (cdr lap2)) (car tmp) + lap1 lap2 + (nth 1 (cdr lap2)) (car tmp) + (nth 1 newtag) 'byte-dup lap1 + (cons 'byte-goto newtag) + ) + (setcdr rest (cons (cons 'byte-dup 0) (cdr rest))) + (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp)))) + (setq add-depth 1) + (setq keep-going t)) + ;; + ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y: + ;; (This can pull the loop test to the end of the loop) + ;; + ((and (eq (car lap0) 'byte-goto) + (eq (car lap1) 'TAG) + (eq lap1 + (cdr (car (setq tmp (cdr (memq (cdr lap0) lap)))))) + (memq (car (car tmp)) + '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop))) +;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional" +;; lap0 lap1 (cdr lap0) (car tmp)) + (let ((newtag (byte-compile-make-tag))) + (byte-compile-log-lap + "%s %s: ... %s: %s\t-->\t%s ... %s:" + lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp) + (cons (cdr (assq (car (car tmp)) + '((byte-goto-if-nil . byte-goto-if-not-nil) + (byte-goto-if-not-nil . byte-goto-if-nil) + (byte-goto-if-nil-else-pop . + byte-goto-if-not-nil-else-pop) + (byte-goto-if-not-nil-else-pop . + byte-goto-if-nil-else-pop)))) + newtag) + + (nth 1 newtag) + ) + (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) + (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) + ;; We can handle this case but not the -if-not-nil case, + ;; because we won't know which non-nil constant to push. + (setcdr rest (cons (cons 'byte-constant + (byte-compile-get-constant nil)) + (cdr rest)))) + (setcar lap0 (nth 1 (memq (car (car tmp)) + '(byte-goto-if-nil-else-pop + byte-goto-if-not-nil + byte-goto-if-nil + byte-goto-if-not-nil + byte-goto byte-goto)))) + ) + (setq keep-going t)) + ) + (setq rest (cdr rest))) + ) + ;; Cleanup stage: + ;; Rebuild byte-compile-constants / byte-compile-variables. + ;; Simple optimizations that would inhibit other optimizations if they + ;; were done in the optimizing loop, and optimizations which there is no + ;; need to do more than once. + (setq byte-compile-constants nil + byte-compile-variables nil) + (setq rest lap) + (while rest + (setq lap0 (car rest) + lap1 (nth 1 rest)) + (if (memq (car lap0) byte-constref-ops) + (if (eq (cdr lap0) 'byte-constant) + (or (memq (cdr lap0) byte-compile-variables) + (setq byte-compile-variables (cons (cdr lap0) + byte-compile-variables))) + (or (memq (cdr lap0) byte-compile-constants) + (setq byte-compile-constants (cons (cdr lap0) + byte-compile-constants))))) + (cond (;; + ;; const-C varset-X const-C --> const-C dup varset-X + ;; const-C varbind-X const-C --> const-C dup varbind-X + ;; + (and (eq (car lap0) 'byte-constant) + (eq (car (nth 2 rest)) 'byte-constant) + (eq (cdr lap0) (car (nth 2 rest))) + (memq (car lap1) '(byte-varbind byte-varset))) + (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" + lap0 lap1 lap0 lap0 lap1) + (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1))) + (setcar (cdr rest) (cons 'byte-dup 0)) + (setq add-depth 1)) + ;; + ;; const-X [dup/const-X ...] --> const-X [dup ...] dup + ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup + ;; + ((memq (car lap0) '(byte-constant byte-varref)) + (setq tmp rest + tmp2 nil) + (while (progn + (while (eq 'byte-dup (car (car (setq tmp (cdr tmp)))))) + (and (eq (cdr lap0) (cdr (car tmp))) + (eq (car lap0) (car (car tmp))))) + (setcar tmp (cons 'byte-dup 0)) + (setq tmp2 t)) + (if tmp2 + (byte-compile-log-lap + " %s [dup/%s]... %s\t-->\t%s dup..." lap0 lap0 lap0))) + ;; + ;; unbind-N unbind-M --> unbind-(N+M) + ;; + ((and (eq 'byte-unbind (car lap0)) + (eq 'byte-unbind (car lap1))) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 + (cons 'byte-unbind + (+ (cdr lap0) (cdr lap1)))) + (setq keep-going t) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + ) + (setq rest (cdr rest))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) + lap) + +(provide 'byte-optimize) + + +;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles +;; itself, compile some of its most used recursive functions (at load time). +;; +(eval-when-compile + (or (compiled-function-p (symbol-function 'byte-optimize-form)) + (assq 'byte-code (symbol-function 'byte-optimize-form)) + (let ((byte-optimize nil) + (byte-compile-warnings nil)) + (mapcar '(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-optimize-form + byte-optimize-body + byte-optimize-predicate + byte-optimize-binary-predicate + ;; Inserted some more than necessary, to speed it up. + byte-optimize-form-code-walker + byte-optimize-lapcode)))) + nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/bytecomp.el Fri Jul 10 22:06:47 1992 +0000 @@ -0,0 +1,3000 @@ +;;; -*- Mode: Emacs-Lisp -*- +;;; Compilation of Lisp code into byte code. +;;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. + +;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>. + +(defconst byte-compile-version "2.04; 5-feb-92.") + +;; 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. + +;;; ======================================================================== +;;; Entry points: +;;; byte-recompile-directory, byte-compile-file, +;;; byte-compile-and-load-file byte-compile-buffer, batch-byte-compile, +;;; byte-compile, byte-compile-sexp, elisp-compile-defun, +;;; byte-compile-report-call-tree + +;;; This version of the elisp byte compiler has the following improvements: +;;; + optimization of compiled code: +;;; - removal of unreachable code; +;;; - removal of calls to side-effectless functions whose return-value +;;; is unused; +;;; - compile-time evaluation of safe constant forms, such as (consp nil) +;;; and (ash 1 6); +;;; - open-coding of literal lambdas; +;;; - peephole optimization of emitted code; +;;; - trivial functions are left uncompiled for speed. +;;; + support for inline functions; +;;; + compile-time evaluation of arbitrary expressions; +;;; + compile-time warning messages for: +;;; - functions being redefined with incompatible arglists; +;;; - functions being redefined as macros, or vice-versa; +;;; - functions or macros defined multiple times in the same file; +;;; - functions being called with the incorrect number of arguments; +;;; - functions being called which are not defined globally, in the +;;; file, or as autoloads; +;;; - assignment and reference of undeclared free variables; +;;; - various syntax errors; +;;; + correct compilation of nested defuns, defmacros, defvars and defsubsts; +;;; + correct compilation of top-level uses of macros; +;;; + the ability to generate a histogram of functions called. + +;;; User customization variables: +;;; +;;; byte-compile-verbose Whether to report the function currently being +;;; compiled in the minibuffer; +;;; byte-optimize Whether to do optimizations; this may be +;;; t, nil, 'source, or 'byte; +;;; byte-optimize-log Whether to report (in excruciating detail) +;;; exactly which optimizations have been made. +;;; This may be t, nil, 'source, or 'byte; +;;; byte-compile-error-on-warn Whether to stop compilation when a warning is +;;; produced; +;;; byte-compile-delete-errors Whether the optimizer may delete calls or +;;; variable references that are side-effect-free +;;; except that they may return an error. +;;; byte-compile-generate-call-tree Whether to generate a histogram of +;;; function calls. This can be useful for +;;; finding unused functions, as well as simple +;;; performance metering. +;;; byte-compile-warnings List of warnings to issue, or t. May contain +;;; 'free-vars (references to variables not in the +;;; current lexical scope) +;;; 'unresolved (calls to unknown functions) +;;; 'callargs (lambda calls with args that don't +;;; match the lambda's definition) +;;; 'redefine (function cell redefined from +;;; a macro to a lambda or vice versa, +;;; or redefined to take other args) +;;; This defaults to nil in -batch mode, which is +;;; slightly faster. +;;; byte-compile-emacs18-compatibility Whether the compiler should +;;; generate .elc files which can be loaded into +;;; generic emacs 18's which don't have the file +;;; bytecomp-runtime.el loaded as well; +;;; byte-compile-generate-emacs19-bytecodes Whether to generate bytecodes +;;; which exist only in emacs19. This is a more +;;; extreme step than setting emacs18-compatibility +;;; to nil, because there is no elisp you can load +;;; into an emacs18 to make files compiled this +;;; way work. +;;; byte-compile-single-version Normally the byte-compiler will consult the +;;; above two variables at runtime, but if this +;;; variable is true when the compiler itself is +;;; compiled, then the runtime checks will not be +;;; made, and compilation will be slightly faster. +;;; elisp-source-extention-re Regexp for the extention of elisp source-files; +;;; see also the function byte-compile-dest-file. +;;; byte-compile-overwrite-file If nil, delete old .elc files before saving. +;;; +;;; Most of the above parameters can also be set on a file-by-file basis; see +;;; the documentation of the `byte-compiler-options' macro. + +;;; New Features: +;;; +;;; o The form `defsubst' is just like `defun', except that the function +;;; generated will be open-coded in compiled code which uses it. This +;;; means that no function call will be generated, it will simply be +;;; spliced in. Elisp functions calls are very slow, so this can be a +;;; big win. +;;; +;;; You can generally accomplish the same thing with `defmacro', but in +;;; that case, the defined procedure can't be used as an argument to +;;; mapcar, etc. +;;; +;;; o You can make a given function be inline even if it has already been +;;; defined with `defun' by using the `proclaim-inline' form like so: +;;; (proclaim-inline my-function) +;;; This is, in fact, exactly what `defsubst' does. To make a function no +;;; longer be inline, you must use `proclaim-notinline'. Beware that if +;;; you define a function with `defsubst' and later redefine it with +;;; `defun', it will still be open-coded until you use proclaim-notinline. +;;; +;;; o You can also open-code one particular call to a function without +;;; open-coding all calls. Use the 'inline' form to do this, like so: +;;; +;;; (inline (foo 1 2 3)) ;; `foo' will be open-coded +;;; or... +;;; (inline ;; `foo' and `baz' will be +;;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not. +;;; (baz 0)) +;;; +;;; o It is possible to open-code a function in the same file it is defined +;;; in without having to load that file before compiling it. the +;;; byte-compiler has been modified to remember function definitions in +;;; the compilation environment in the same way that it remembers macro +;;; definitions. +;;; +;;; o Forms like ((lambda ...) ...) are open-coded. +;;; +;;; o The form `eval-when-compile' is like progn, except that the body +;;; is evaluated at compile-time. When it appears at top-level, this +;;; is analagous to the Common Lisp idiom (eval-when (compile) ...). +;;; When it does not appear at top-level, it is similar to the +;;; Common Lisp #. reader macro (but not in interpreted code.) +;;; +;;; o The form `eval-and-compile' is similar to eval-when-compile, but +;;; the whole form is evalled both at compile-time and at run-time. +;;; +;;; o The command Meta-X byte-compile-and-load-file does what you'd think. +;;; +;;; o The command elisp-compile-defun is analogous to eval-defun. +;;; +;;; o If you run byte-compile-file on a filename which is visited in a +;;; buffer, and that buffer is modified, you are asked whether you want +;;; to save the buffer before compiling. + +(or (fboundp 'defsubst) + ;; This really ought to be loaded already! + (load-library "bytecomp-runtime")) + +(eval-when-compile + (defvar byte-compile-single-version nil + "If this is true, the choice of emacs version (v18 or v19) byte-codes will +be hard-coded into bytecomp when it compiles itself. If the compiler itself +is compiled with optimization, this causes a speedup.") + + (cond (byte-compile-single-version + (defmacro byte-compile-single-version () t) + (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond)))) + (t + (defmacro byte-compile-single-version () nil) + (defmacro byte-compile-version-cond (cond) cond))) + ) + +;;; The crud you see scattered through this file of the form +;;; (or (and (boundp 'epoch::version) epoch::version) +;;; (string-lessp emacs-version "19")) +;;; is because the Epoch folks couldn't be bothered to follow the +;;; normal emacs version numbering convention. + +(if (byte-compile-version-cond + (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19"))) + (progn + ;; emacs-18 compatibility. + (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined + + (if (byte-compile-single-version) + (defmacro compiled-function-p (x) "Emacs 18 doesn't have these." nil) + (defun compiled-function-p (x) "Emacs 18 doesn't have these." nil)) + + (or (and (fboundp 'member) + ;; avoid using someone else's possibly bogus definition of this. + (subrp (symbol-function 'member))) + (defun member (elt list) + "like memq, but uses equal instead of eq. In v19, this is a subr." + (while (and list (not (equal elt (car list)))) + (setq list (cdr list))) + list)) + )) + + +(defvar elisp-source-extention-re (if (eq system-type 'vax-vms) + "\\.EL\\(;[0-9]+\\)?$" + "\\.el$") + "*Regexp which matches the extention of elisp source-files. +You may want to redefine defun byte-compile-dest-file to match this.") + +(or (fboundp 'byte-compile-dest-file) + ;; The user may want to redefine this along with elisp-source-extention-re, + ;; so only define it if it is undefined. + (defun byte-compile-dest-file (filename) + "Converts an emacs-lisp source-filename to a compiled-filename." + (setq filename (file-name-sans-versions filename)) + (cond ((eq system-type 'vax-vms) + (concat (substring filename 0 (string-match ";" filename)) "c")) + ((string-match elisp-source-extention-re filename) + (concat (substring filename 0 (match-beginning 0)) ".elc")) + (t (concat filename "c"))))) + +;; This can be the 'byte-compile property of any symbol. +(autoload 'byte-compile-inline-expand "byte-optimize") + +;; This is the entrypoint to the lapcode optimizer pass1. +(autoload 'byte-optimize-form "byte-optimize") +;; This is the entrypoint to the lapcode optimizer pass2. +(autoload 'byte-optimize-lapcode "byte-optimize") +(autoload 'byte-compile-unfold-lambda "byte-optimize") + +(defvar byte-compile-verbose + (and (not noninteractive) (> baud-rate search-slow-speed)) + "*Non-nil means print messages describing progress of byte-compiler.") + +(defvar byte-compile-emacs18-compatibility + (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19")) + "*If this is true, then the byte compiler will generate .elc files which will +work in generic version 18 emacses without having bytecomp-runtime.el loaded. +If this is false, the generated code will be more efficient in emacs 19, and +will be loadable in emacs 18 only if bytecomp-runtime.el is loaded. +See also byte-compile-generate-emacs19-bytecodes.") + +(defvar byte-compile-generate-emacs19-bytecodes + (not (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19"))) + "*If this is true, then the byte-compiler will generate bytecode which +makes use of byte-ops which are present only in emacs19. Code generated +this way can never be run in emacs18, and may even cause it to crash.") + +(defvar byte-optimize t + "*If nil, no compile-optimizations will be done. +Compilation will be faster, generated code will be slower and larger. +This may be nil, t, 'byte, or 'source. If it is 'byte, then only byte-level +optimizations will be done; if it is 'source, then only source-level +optimizations will be done.") + +(defvar byte-compile-delete-errors t + "*If non-nil, the optimizer may delete forms that may signal an error +(variable references and side-effect-free functions such as CAR).") + +(defvar byte-optimize-log nil + "*If true, the byte-compiler will log its optimizations into *Compile-Log*. +If this is 'source, then only source-level optimizations will be logged. +If it is 'byte, then only byte-level optimizations will be logged.") + +(defvar byte-compile-error-on-warn nil + "*If true, the byte-compiler will report warnings with `error' instead +of `message.'") + +(defconst byte-compile-warning-types '(redefine callargs free-vars unresolved)) +(defvar byte-compile-warnings (not noninteractive) + "*List of warnings that the byte-compiler should issue (t for all). +See doc of macro byte-compiler-options.") + +(defvar byte-compile-generate-call-tree nil + "*If this is true, then the compiler will collect statistics on what +functions were called and from where. This will be displayed after the +compilation completes. If it is non-nil, but not t, you will be asked +for whether to display this. + +The call tree only lists functions called, not macros used. Those functions +which the byte-code interpreter knows about directly (eq, cons, etc.) are +not reported. + +The call tree also lists those functions which are not known to be called +(that is, to which no calls have been compiled.) Functions which can be +invoked interactively are excluded from this list.") + +(defconst byte-compile-call-tree nil "Alist of functions and their call tree. +Each element looks like + + \(FUNCTION CALLERS CALLS\) + +where CALLERS is a list of functions that call FUNCTION, and CALLS +is a list of functions for which calls were generated while compiling +FUNCTION.") + +(defvar byte-compile-call-tree-sort 'name + "*If non nil, the call tree is sorted. +The values 'name, 'callers, 'calls, 'calls+callers means to sort on +the those fields.") + +(defvar byte-compile-overwrite-file t + "If nil, old .elc files are deleted before the new is saved, and .elc +files will have the same modes as the corresponding .el file. Otherwise, +existing .elc files will simply be overwritten, and the existing modes +will not be changed. If this variable is nil, then an .elc file which +is a symbolic link will be turned into a normal file, instead of the file +which the link points to being overwritten.") + +(defvar byte-compile-constants nil + "list of all constants encountered during compilation of this form") +(defvar byte-compile-variables nil + "list of all variables encountered during compilation of this form") +(defvar byte-compile-bound-variables nil + "list of variables bound in the context of the current form; this list +lives partly on the stack.") +(defvar byte-compile-free-references) +(defvar byte-compile-free-assignments) + +(defconst byte-compile-initial-macro-environment + '((byte-compiler-options . (lambda (&rest forms) + (apply 'byte-compiler-options-handler forms))) + (eval-when-compile . (lambda (&rest body) + (list 'quote (eval (byte-compile-top-level + (cons 'progn body)))))) + (eval-and-compile . (lambda (&rest body) + (eval (cons 'progn body)) + (cons 'progn body)))) + "The default macro-environment passed to macroexpand by the compiler. +Placing a macro here will cause a macro to have different semantics when +expanded by the compiler as when expanded by the interpreter.") + +(defvar byte-compile-macro-environment byte-compile-initial-macro-environment + "Alist of (MACRONAME . DEFINITION) macros defined in the file which is being +compiled. It is (MACRONAME . nil) when a macro is redefined as a function.") + +(defvar byte-compile-function-environment nil + "Alist of (FUNCTIONNAME . DEFINITION) functions defined in the file which +is being compiled (this is so we can inline them if necessary). It is +(FUNCTIONNAME . nil) when a function is redefined as a macro.") + +(defvar byte-compile-unresolved-functions nil + "Alist of undefined functions to which calls have been compiled (used for +warnings when the function is later defined with incorrect args).") + +(defvar byte-compile-tag-number 0) +(defvar byte-compile-output nil + "Alist describing contents to put in byte code string. +Each element is (INDEX . VALUE)") +(defvar byte-compile-depth 0 "Current depth of execution stack.") +(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.") + + +;;; The byte codes; this information is duplicated in bytecomp.c + +(defconst byte-code-vector nil + "An array containing byte-code names indexed by byte-code values.") + +(defconst byte-stack+-info nil + "An array with the stack adjustment for each byte-code.") + +(defmacro byte-defop (opcode stack-adjust opname &optional docstring) + ;; This is a speed-hack for building the byte-code-vector at compile-time. + ;; We fill in the vector at macroexpand-time, and then after the last call + ;; to byte-defop, we write the vector out as a constant instead of writing + ;; out a bunch of calls to aset. + ;; Actually, we don't fill in the vector itself, because that could make + ;; it problematic to compile big changes to this compiler; we store the + ;; values on its plist, and remove them later in -extrude. + (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value) + (put 'byte-code-vector 'tmp-compile-time-value + (make-vector 256 nil)))) + (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value) + (put 'byte-stack+-info 'tmp-compile-time-value + (make-vector 256 nil))))) + (aset v1 opcode opname) + (aset v2 opcode stack-adjust)) + (if docstring + (list 'defconst opname opcode (concat "Byte code opcode " docstring ".")) + (list 'defconst opname opcode))) + +(defmacro byte-extrude-byte-code-vectors () + (prog1 (list 'setq 'byte-code-vector + (get 'byte-code-vector 'tmp-compile-time-value) + 'byte-stack+-info + (get 'byte-stack+-info 'tmp-compile-time-value)) + ;; emacs-18 has no REMPROP. + (put 'byte-code-vector 'tmp-compile-time-value nil) + (put 'byte-stack+-info 'tmp-compile-time-value nil))) + + +;; unused: 0-7 + +;; These opcodes are special in that they pack their argument into the +;; opcode word. +;; +(byte-defop 8 1 byte-varref "for variable reference") +(byte-defop 16 -1 byte-varset "for setting a variable") +(byte-defop 24 -1 byte-varbind "for binding a variable") +(byte-defop 32 0 byte-call "for calling a function") +(byte-defop 40 0 byte-unbind "for unbinding special bindings") +;; codes 41-47 are consumed by the preceeding opcodes + +;; unused: 48-55 + +(byte-defop 56 -1 byte-nth) +(byte-defop 57 0 byte-symbolp) +(byte-defop 58 0 byte-consp) +(byte-defop 59 0 byte-stringp) +(byte-defop 60 0 byte-listp) +(byte-defop 61 -1 byte-eq) +(byte-defop 62 -1 byte-memq) +(byte-defop 63 0 byte-not) +(byte-defop 64 0 byte-car) +(byte-defop 65 0 byte-cdr) +(byte-defop 66 -1 byte-cons) +(byte-defop 67 0 byte-list1) +(byte-defop 68 -1 byte-list2) +(byte-defop 69 -2 byte-list3) +(byte-defop 70 -3 byte-list4) +(byte-defop 71 0 byte-length) +(byte-defop 72 -1 byte-aref) +(byte-defop 73 -2 byte-aset) +(byte-defop 74 0 byte-symbol-value) +(byte-defop 75 0 byte-symbol-function) ; this was commented out +(byte-defop 76 -1 byte-set) +(byte-defop 77 -1 byte-fset) ; this was commented out +(byte-defop 78 -1 byte-get) +(byte-defop 79 -2 byte-substring) +(byte-defop 80 -1 byte-concat2) +(byte-defop 81 -2 byte-concat3) +(byte-defop 82 -3 byte-concat4) +(byte-defop 83 0 byte-sub1) +(byte-defop 84 0 byte-add1) +(byte-defop 85 -1 byte-eqlsign) +(byte-defop 86 -1 byte-gtr) +(byte-defop 87 -1 byte-lss) +(byte-defop 88 -1 byte-leq) +(byte-defop 89 -1 byte-geq) +(byte-defop 90 -1 byte-diff) +(byte-defop 91 0 byte-negate) +(byte-defop 92 -1 byte-plus) +(byte-defop 93 -1 byte-max) +(byte-defop 94 -1 byte-min) +(byte-defop 95 -1 byte-mult) ; v19 only +(byte-defop 96 1 byte-point) +(byte-defop 97 1 byte-mark-OBSOLETE) ; no longer generated as of v18 +(byte-defop 98 0 byte-goto-char) +(byte-defop 99 0 byte-insert) +(byte-defop 100 1 byte-point-max) +(byte-defop 101 1 byte-point-min) +(byte-defop 102 0 byte-char-after) +(byte-defop 103 1 byte-following-char) +(byte-defop 104 1 byte-preceding-char) +(byte-defop 105 1 byte-current-column) +(byte-defop 106 0 byte-indent-to) +(byte-defop 107 0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18 +(byte-defop 108 1 byte-eolp) +(byte-defop 109 1 byte-eobp) +(byte-defop 110 1 byte-bolp) +(byte-defop 111 1 byte-bobp) +(byte-defop 112 1 byte-current-buffer) +(byte-defop 113 0 byte-set-buffer) +(byte-defop 114 1 byte-read-char-OBSOLETE) +(byte-defop 115 0 byte-set-mark-OBSOLETE) +(byte-defop 116 1 byte-interactive-p) + +;; These ops are new to v19 +(byte-defop 117 0 byte-forward-char) +(byte-defop 118 0 byte-forward-word) +(byte-defop 119 -1 byte-skip-chars-forward) +(byte-defop 120 -1 byte-skip-chars-backward) +(byte-defop 121 0 byte-forward-line) +(byte-defop 122 0 byte-char-syntax) +(byte-defop 123 -1 byte-buffer-substring) +(byte-defop 124 -1 byte-delete-region) +(byte-defop 125 -1 byte-narrow-to-region) +(byte-defop 126 1 byte-widen) +(byte-defop 127 0 byte-end-of-line) + +;; unused: 128 + +;; These store their argument in the next two bytes +(byte-defop 129 1 byte-constant2 + "for reference to a constant with vector index >= byte-constant-limit") +(byte-defop 130 0 byte-goto "for unconditional jump") +(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil") +(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil") +(byte-defop 133 -1 byte-goto-if-nil-else-pop + "to examine top-of-stack, jump and don't pop it if it's nil, +otherwise pop it") +(byte-defop 134 -1 byte-goto-if-not-nil-else-pop + "to examine top-of-stack, jump and don't pop it if it's non nil, +otherwise pop it") + +(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'") +(byte-defop 136 -1 byte-discard "to discard one value from stack") +(byte-defop 137 1 byte-dup "to duplicate the top of the stack") + +(byte-defop 138 0 byte-save-excursion + "to make a binding to record the buffer, point and mark") +(byte-defop 139 0 byte-save-window-excursion + "to make a binding to record entire window configuration") +(byte-defop 140 0 byte-save-restriction + "to make a binding to record the current buffer clipping restrictions") +(byte-defop 141 -1 byte-catch + "for catch. Takes, on stack, the tag and an expression for the body") +(byte-defop 142 -1 byte-unwind-protect + "for unwind-protect. Takes, on stack, an expression for the unwind-action") + +(byte-defop 143 -2 byte-condition-case + "for condition-case. Takes, on stack, the variable to bind, +an expression for the body, and a list of clauses") + +(byte-defop 144 0 byte-temp-output-buffer-setup + "for entry to with-output-to-temp-buffer. +Takes, on stack, the buffer name. +Binds standard-output and does some other things. +Returns with temp buffer on the stack in place of buffer name") + +(byte-defop 145 -1 byte-temp-output-buffer-show + "for exit from with-output-to-temp-buffer. +Expects the temp buffer on the stack underneath value to return. +Pops them both, then pushes the value back on. +Unbinds standard-output and makes the temp buffer visible") + +;; these ops are new to v19 +(byte-defop 146 0 byte-unbind-all "to unbind back to the beginning of +this frame. Not used yet, but wil be needed for tail-recursion elimination.") + +;; these ops are new to v19 +(byte-defop 147 -2 byte-set-marker) +(byte-defop 148 0 byte-match-beginning) +(byte-defop 149 0 byte-match-end) +(byte-defop 150 0 byte-upcase) +(byte-defop 151 0 byte-downcase) +(byte-defop 152 -1 byte-string=) +(byte-defop 153 -1 byte-string<) +(byte-defop 154 -1 byte-equal) +(byte-defop 155 -1 byte-nthcdr) +(byte-defop 156 -1 byte-elt) +(byte-defop 157 -1 byte-member) +(byte-defop 158 -1 byte-assq) +(byte-defop 159 0 byte-nreverse) +(byte-defop 160 -1 byte-setcar) +(byte-defop 161 -1 byte-setcdr) +(byte-defop 162 0 byte-car-safe) +(byte-defop 163 0 byte-cdr-safe) +(byte-defop 164 -1 byte-nconc) +(byte-defop 165 -1 byte-quo) +(byte-defop 166 -1 byte-rem) +(byte-defop 167 0 byte-numberp) +(byte-defop 168 0 byte-integerp) + +;; unused: 169 + +;; New to v19. These store their arg in the next byte. +(byte-defop 170 0 byte-rel-goto) +(byte-defop 171 -1 byte-rel-goto-if-nil) +(byte-defop 172 -1 byte-rel-goto-if-not-nil) +(byte-defop 173 -1 byte-rel-goto-if-nil-else-pop) +(byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop) + +(byte-defop 175 nil byte-listN) +(byte-defop 176 nil byte-concatN) +(byte-defop 177 nil byte-insertN) + +;; unused: 178-191 + +(byte-defop 192 1 byte-constant "for reference to a constant") +;; codes 193-255 are consumed by byte-constant. +(defconst byte-constant-limit 64 + "Exclusive maximum index usable in the `byte-constant' opcode.") + +(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil + byte-goto-if-nil-else-pop + byte-goto-if-not-nil-else-pop) + "those byte-codes whose offset is a pc.") + +(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) + +(defconst byte-rel-goto-ops '(byte-rel-goto + byte-rel-goto-if-nil byte-rel-goto-if-not-nil + byte-rel-goto-if-nil-else-pop + byte-rel-goto-if-not-nil-else-pop) + "byte-codes for relative jumps.") + +(byte-extrude-byte-code-vectors) + +;;; lapcode generator +;;; +;;; the byte-compiler now does source -> lapcode -> bytecode instead of +;;; source -> bytecode, because it's a lot easier to make optimizations +;;; on lapcode than on bytecode. +;;; +;;; Elements of the lapcode list are of the form (<instruction> . <parameter>) +;;; where instruction is a symbol naming a byte-code instruction, +;;; and parameter is an argument to that instruction, if any. +;;; +;;; The instruction can be the pseudo-op TAG, which means that this position +;;; in the instruction stream is a target of a goto. (car PARAMETER) will be +;;; the PC for this location, and the whole instruction "(TAG pc)" will be the +;;; parameter for some goto op. +;;; +;;; If the operation is varbind, varref, varset or push-constant, then the +;;; parameter is (variable/constant . index_in_constant_vector). +;;; +;;; First, the source code is macroexpanded and optimized in various ways. +;;; Then the resultant code is compiled into lapcode. Another set of +;;; optimizations are then run over the lapcode. Then the variables and +;;; constants referenced by the lapcode are collected and placed in the +;;; constants-vector. (This happens now so that variables referenced by dead +;;; code don't consume space.) And finally, the lapcode is transformed into +;;; compacted byte-code. +;;; +;;; A distinction is made between variables and constants because the variable- +;;; referencing instructions are more sensitive to the variables being near the +;;; front of the constants-vector than the constant-referencing instructions. +;;; Also, this lets us notice references to free variables. + +(defun byte-compile-lapcode (lap) + "Turns lapcode into bytecode. The lapcode is destroyed." + ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. + (let ((pc 0) ; Program counter + op off ; Operation & offset + (bytes '()) ; Put the output bytes here + (patchlist nil) ; List of tags and goto's to patch + rest rel tmp) + (while lap + (setq op (car (car lap)) + off (cdr (car lap))) + (cond ((not (symbolp op)) + (error "non-symbolic opcode %s" op)) + ((eq op 'TAG) + (setcar off pc) + (setq patchlist (cons off patchlist))) + ((memq op byte-goto-ops) + (setq pc (+ pc 3)) + (setq bytes (cons (cons pc (cdr off)) + (cons nil + (cons (symbol-value op) bytes)))) + (setq patchlist (cons bytes patchlist))) + (t + (setq bytes + (cond ((cond ((consp off) + ;; Variable or constant reference + (setq off (cdr off)) + (eq op 'byte-constant))) + (cond ((< off byte-constant-limit) + (setq pc (1+ pc)) + (cons (+ byte-constant off) bytes)) + (t + (setq pc (+ 3 pc)) + (cons (lsh off -8) + (cons (logand off 255) + (cons byte-constant2 bytes)))))) + ((<= byte-listN (symbol-value op)) + (setq pc (+ 2 pc)) + (cons off (cons (symbol-value op) bytes))) + ((< off 6) + (setq pc (1+ pc)) + (cons (+ (symbol-value op) off) bytes)) + ((< off 256) + (setq pc (+ 2 pc)) + (cons off (cons (+ (symbol-value op) 6) bytes))) + (t + (setq pc (+ 3 pc)) + (cons (lsh off -8) + (cons (logand off 255) + (cons (+ (symbol-value op) 7) + bytes)))))))) + (setq lap (cdr lap))) + ;;(if (not (= pc (length bytes))) + ;; (error "compiler error: pc mismatch - %s %s" pc (length bytes))) + (cond ((byte-compile-version-cond byte-compile-generate-emacs19-bytecodes) + ;; Make relative jumps + (setq patchlist (nreverse patchlist)) + (while (progn + (setq off 0) ; PC change because of deleted bytes + (setq rest patchlist) + (while rest + (setq tmp (car rest)) + (and (consp (car tmp)) ; Jump + (prog1 (null (nth 1 tmp)) ; Absolute jump + (setq tmp (car tmp))) + (progn + (setq rel (- (car (cdr tmp)) (car tmp))) + (and (<= -129 rel) (< rel 128))) + (progn + ;; Convert to relative jump. + (setcdr (car rest) (cdr (cdr (car rest)))) + (setcar (cdr (car rest)) + (+ (car (cdr (car rest))) + (- byte-rel-goto byte-goto))) + (setq off (1- off)))) + (setcar tmp (+ (car tmp) off)) ; Adjust PC + (setq rest (cdr rest))) + ;; If optimizing, repeat until no change. + (and byte-optimize + (not (zerop off))))))) + ;; Patch PC into jumps + (let (bytes) + (while patchlist + (setq bytes (car patchlist)) + (cond ((atom (car bytes))) ; Tag + ((nth 1 bytes) ; Relative jump + (setcar bytes (+ (- (car (cdr (car bytes))) (car (car bytes))) + 128))) + (t ; Absolute jump + (setq pc (car (cdr (car bytes)))) ; Pick PC from tag + (setcar (cdr bytes) (logand pc 255)) + (setcar bytes (lsh pc -8)))) + (setq patchlist (cdr patchlist)))) + (concat (nreverse bytes)))) + + +;;; byte compiler messages + +(defconst byte-compile-current-form nil) +(defconst byte-compile-current-file nil) + +(defmacro byte-compile-log (format-string &rest args) + (list 'and + 'byte-optimize + '(memq byte-optimize-log '(t source)) + (list 'let '((print-escape-newlines t) + (print-level 4) + (print-length 4)) + (list 'byte-compile-log-1 + (cons 'format + (cons format-string + (mapcar + '(lambda (x) + (if (symbolp x) (list 'prin1-to-string x) x)) + args))))))) + +(defconst byte-compile-last-warned-form nil) + +(defun byte-compile-log-1 (string) + (cond (noninteractive + (if (or byte-compile-current-file + (and byte-compile-last-warned-form + (not (eq byte-compile-current-form + byte-compile-last-warned-form)))) + (message (format "While compiling %s%s:" + (or byte-compile-current-form "toplevel forms") + (if byte-compile-current-file + (if (stringp byte-compile-current-file) + (concat " in file " byte-compile-current-file) + (concat " in buffer " + (buffer-name byte-compile-current-file))) + "")))) + (message " %s" string)) + (t + (save-excursion + (set-buffer (get-buffer-create "*Compile-Log*")) + (goto-char (point-max)) + (cond ((or byte-compile-current-file + (and byte-compile-last-warned-form + (not (eq byte-compile-current-form + byte-compile-last-warned-form)))) + (if byte-compile-current-file + (insert "\n\^L\n" (current-time-string) "\n")) + (insert "While compiling " + (if byte-compile-current-form + (format "%s" byte-compile-current-form) + "toplevel forms")) + (if byte-compile-current-file + (if (stringp byte-compile-current-file) + (insert " in file " byte-compile-current-file) + (insert " in buffer " + (buffer-name byte-compile-current-file)))) + (insert ":\n"))) + (insert " " string "\n")))) + (setq byte-compile-current-file nil + byte-compile-last-warned-form byte-compile-current-form)) + +(defun byte-compile-warn (format &rest args) + (setq format (apply 'format format args)) + (if byte-compile-error-on-warn + (error "%s" format) ; byte-compile-file catches and logs it + (byte-compile-log-1 (concat "** " format)) + (or noninteractive ; already written on stdout. + (message "Warning: %s" format)))) + +;;; Used by make-obsolete. +(defun byte-compile-obsolete (form) + (let ((new (get (car form) 'byte-obsolete-info))) + (byte-compile-warn "%s is an obsolete function; %s" (car form) + (if (stringp (car new)) + (car new) + (format "use %s instead." (car new)))) + (funcall (or (cdr new) 'byte-compile-normal-call) form))) + +;; Compiler options + +(defvar byte-compiler-legal-options + '((optimize byte-optimize (t nil source byte) val) + (file-format byte-compile-emacs18-compatibility (emacs18 emacs19) + (eq val 'emacs18)) + (new-bytecodes byte-compile-generate-emacs19-bytecodes (t nil) val) + (delete-errors byte-compile-delete-errors (t nil) val) + (verbose byte-compile-verbose (t nil) val) + (warnings byte-compile-warnings ((callargs redefine free-vars unresolved)) + val))) + +;; Inhibit v18/v19 selectors if the version is hardcoded. +;; #### This should print a warning if the user tries to change something +;; than can't be changed because the running compiler doesn't support it. +(cond + ((byte-compile-single-version) + (setcar (cdr (cdr (assq 'new-bytecodes byte-compiler-legal-options))) + (list (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes))) + (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options))) + (if (byte-compile-version-cond byte-compile-emacs18-compatibility) + '(emacs18) '(emacs19))))) + +(defun byte-compiler-options-handler (&rest args) + (let (key val desc choices) + (while args + (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args)))) + (error "malformed byte-compiler-option %s" (car args))) + (setq key (car (car args)) + val (car (cdr (car args))) + desc (assq key byte-compiler-legal-options)) + (or desc + (error "unknown byte-compiler option %s" key)) + (setq choices (nth 2 desc)) + (if (consp (car choices)) + (let (this + (handler 'cons) + (ret (and (memq (car val) '(+ -)) + (copy-sequence (if (eq t (symbol-value (nth 1 desc))) + choices + (symbol-value (nth 1 desc))))))) + (setq choices (car choices)) + (while val + (setq this (car val)) + (cond ((memq this choices) + (setq ret (funcall handler this ret))) + ((eq this '+) (setq handler 'cons)) + ((eq this '-) (setq handler 'delq)) + ((error "%s only accepts %s." key choices))) + (setq val (cdr val))) + (set (nth 1 desc) ret)) + (or (memq val choices) + (error "%s must be one of %s." key choices)) + (set (nth 1 desc) (eval (nth 3 desc)))) + (setq args (cdr args))) + nil)) + +;;; sanity-checking arglists + +(defun byte-compile-fdefinition (name macro-p) + (let* ((list (if macro-p + byte-compile-macro-environment + byte-compile-function-environment)) + (env (cdr (assq name list)))) + (or env + (let ((fn name)) + (while (and (symbolp fn) + (fboundp fn) + (or (symbolp (symbol-function fn)) + (consp (symbol-function fn)) + (and (not macro-p) + (compiled-function-p (symbol-function fn))))) + (setq fn (symbol-function fn))) + (if (and (not macro-p) (compiled-function-p fn)) + fn + (and (consp fn) + (if (eq 'macro (car fn)) + (cdr fn) + (if macro-p + nil + (if (eq 'autoload (car fn)) + nil + fn))))))))) + +(defun byte-compile-arglist-signature (arglist) + (let ((args 0) + opts + restp) + (while arglist + (cond ((eq (car arglist) '&optional) + (or opts (setq opts 0))) + ((eq (car arglist) '&rest) + (if (cdr arglist) + (setq restp t + arglist nil))) + (t + (if opts + (setq opts (1+ opts)) + (setq args (1+ args))))) + (setq arglist (cdr arglist))) + (cons args (if restp nil (if opts (+ args opts) args))))) + + +(defun byte-compile-arglist-signatures-congruent-p (old new) + (not (or + (> (car new) (car old)) ; requires more args now + (and (null (cdr old)) ; tooks rest-args, doesn't any more + (cdr new)) + (and (cdr new) (cdr old) ; can't take as many args now + (< (cdr new) (cdr old))) + ))) + +(defun byte-compile-arglist-signature-string (signature) + (cond ((null (cdr signature)) + (format "%d+" (car signature))) + ((= (car signature) (cdr signature)) + (format "%d" (car signature))) + (t (format "%d-%d" (car signature) (cdr signature))))) + + +(defun byte-compile-callargs-warn (form) + "warn if the form is calling a function with the wrong number of arguments." + (let* ((def (or (byte-compile-fdefinition (car form) nil) + (byte-compile-fdefinition (car form) t))) + (sig (and def (byte-compile-arglist-signature + (if (eq 'lambda (car-safe def)) + (nth 1 def) + (aref def 0))))) + (ncall (length (cdr form)))) + (if sig + (if (or (< ncall (car sig)) + (and (cdr sig) (> ncall (cdr sig)))) + (byte-compile-warn + "%s called with %d argument%s, but %s %s" + (car form) ncall + (if (= 1 ncall) "" "s") + (if (< ncall (car sig)) + "requires" + "accepts only") + (byte-compile-arglist-signature-string sig))) + (or (fboundp (car form)) ; might be a subr or autoload. + (eq (car form) byte-compile-current-form) ; ## this doesn't work with recursion. + ;; It's a currently-undefined function. Remember number of args in call. + (let ((cons (assq (car form) byte-compile-unresolved-functions)) + (n (length (cdr form)))) + (if cons + (or (memq n (cdr cons)) + (setcdr cons (cons n (cdr cons)))) + (setq byte-compile-unresolved-functions + (cons (list (car form) n) + byte-compile-unresolved-functions)))))))) + +(defun byte-compile-arglist-warn (form macrop) + "warn if the function or macro is being redefined with a different +number of arguments." + (let ((old (byte-compile-fdefinition (nth 1 form) macrop))) + (if old + (let ((sig1 (byte-compile-arglist-signature + (if (eq 'lambda (car-safe old)) + (nth 1 old) + (aref old 0)))) + (sig2 (byte-compile-arglist-signature (nth 2 form)))) + (or (byte-compile-arglist-signatures-congruent-p sig1 sig2) + (byte-compile-warn "%s %s used to take %s %s, now takes %s" + (if (eq (car form) 'defun) "function" "macro") + (nth 1 form) + (byte-compile-arglist-signature-string sig1) + (if (equal sig1 '(1 . 1)) "argument" "arguments") + (byte-compile-arglist-signature-string sig2)))) + ;; This is the first definition. See if previous calls are compatible. + (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions)) + nums sig min max) + (if calls + (progn + (setq sig (byte-compile-arglist-signature (nth 2 form)) + nums (sort (copy-sequence (cdr calls)) (function <)) + min (car nums) + max (car (nreverse nums))) + (if (or (< min (car sig)) + (and (cdr sig) (> max (cdr sig)))) + (byte-compile-warn + "%s being defined to take %s%s, but was previously called with %s" + (nth 1 form) + (byte-compile-arglist-signature-string sig) + (if (equal sig '(1 . 1)) " arg" " args") + (byte-compile-arglist-signature-string (cons min max)))) + + (setq byte-compile-unresolved-functions + (delq calls byte-compile-unresolved-functions))))) + ))) + +(defun byte-compile-warn-about-unresolved-functions () + "If we have compiled any calls to functions which are not known to be +defined, issue a warning enumerating them. You can disable this by including +'unresolved in variable byte-compile-warnings." + (if (memq 'unresolved byte-compile-warnings) + (let ((byte-compile-current-form "the end of the data")) + (if (cdr byte-compile-unresolved-functions) + (let* ((str "The following functions are not known to be defined: ") + (L (length str)) + (rest (reverse byte-compile-unresolved-functions)) + s) + (while rest + (setq s (symbol-name (car (car rest))) + L (+ L (length s) 2) + rest (cdr rest)) + (if (< L (1- fill-column)) + (setq str (concat str " " s (and rest ","))) + (setq str (concat str "\n " s (and rest ",")) + L (+ (length s) 4)))) + (byte-compile-warn "%s" str)) + (if byte-compile-unresolved-functions + (byte-compile-warn "the function %s is not known to be defined." + (car (car byte-compile-unresolved-functions))))))) + nil) + + +(defmacro byte-compile-constp (form) + ;; Returns non-nil if FORM is a constant. + (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) + ((not (symbolp (, form)))) + ((memq (, form) '(nil t)))))) + +(defmacro byte-compile-close-variables (&rest body) + (cons 'let + (cons '(;; + ;; Close over these variables to encapsulate the + ;; compilation state + ;; + (byte-compile-macro-environment + ;; Copy it because the compiler may patch into the + ;; macroenvironment. + (copy-alist byte-compile-initial-macro-environment)) + (byte-compile-function-environment nil) + (byte-compile-bound-variables nil) + (byte-compile-free-references nil) + (byte-compile-free-assignments nil) + ;; + ;; Close over these variables so that `byte-compiler-options' + ;; can change them on a per-file basis. + ;; + (byte-compile-verbose byte-compile-verbose) + (byte-optimize byte-optimize) + (byte-compile-generate-emacs19-bytecodes + byte-compile-generate-emacs19-bytecodes) + (byte-compile-warnings (if (eq byte-compile-warnings t) + byte-compile-warning-types + byte-compile-warnings)) + ) + body))) + +(defvar byte-compile-warnings-point-max) +(defmacro displaying-byte-compile-warnings (&rest body) + (list 'let + '((byte-compile-warnings-point-max + (if (boundp 'byte-compile-warnings-point-max) + byte-compile-warnings-point-max + (save-excursion + (set-buffer (get-buffer-create "*Compile-Log*")) + (point-max))))) + (list 'unwind-protect (cons 'progn body) + '(save-excursion + ;; If there were compilation warnings, display them. + (set-buffer "*Compile-Log*") + (if (= byte-compile-warnings-point-max (point-max)) + nil + (select-window + (prog1 (selected-window) + (select-window (display-buffer (current-buffer))) + (goto-char byte-compile-warnings-point-max) + (recenter 1)))))))) + + +(defun byte-recompile-directory (directory &optional arg) + "Recompile every `.el' file in DIRECTORY that needs recompilation. +This is if a `.elc' file exists but is older than the `.el' file. + +If the `.elc' file does not exist, normally the `.el' file is *not* compiled. +But a prefix argument (optional second arg) means ask user, +for each such `.el' file, whether to compile it." + (interactive "DByte recompile directory: \nP") + (save-some-buffers) + (set-buffer-modified-p (buffer-modified-p)) ;Update the mode line. + (setq directory (expand-file-name directory)) + (let ((files (directory-files directory nil elisp-source-extention-re)) + (count 0) + source dest) + (while files + (if (and (not (auto-save-file-name-p (car files))) + (setq source (expand-file-name (car files) directory)) + (setq dest (byte-compile-dest-file source)) + (if (file-exists-p dest) + (file-newer-than-file-p source dest) + (and arg (y-or-n-p (concat "Compile " source "? "))))) + (progn (byte-compile-file source) + (setq count (1+ count)))) + (setq files (cdr files))) + (message "Done (Total of %d file%s compiled)" + count (if (= count 1) "" "s")))) + +(defun byte-compile-file (filename &optional load) + "Compile a file of Lisp code named FILENAME into a file of byte code. +The output file's name is made by appending `c' to the end of FILENAME. +With prefix arg (noninteractively: 2nd arg), load the file after compiling." +;; (interactive "fByte compile file: \nP") + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (eq (cdr (assq 'major-mode (buffer-local-variables))) + 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (if (byte-compile-version-cond + (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19"))) + (read-file-name (if current-prefix-arg + "Byte compile and load file: " + "Byte compile file: ") + file-dir file-name nil) + (read-file-name (if current-prefix-arg + "Byte compile and load file: " + "Byte compile file: ") + file-dir nil nil file-name)) + current-prefix-arg))) + ;; Expand now so we get the current buffer's defaults + (setq filename (expand-file-name filename)) + + ;; If we're compiling a file that's in a buffer and is modified, offer + ;; to save it first. + (or noninteractive + (let ((b (get-file-buffer (expand-file-name filename)))) + (if (and b (buffer-modified-p b) + (y-or-n-p (format "save buffer %s first? " (buffer-name b)))) + (save-excursion (set-buffer b) (save-buffer))))) + + (if byte-compile-verbose + (message "Compiling %s..." filename)) + (let ((byte-compile-current-file (file-name-nondirectory filename)) + target-file) + (save-excursion + (set-buffer (get-buffer-create " *Compiler Input*")) + (erase-buffer) + (insert-file-contents filename) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename)) + (set-auto-mode) + (setq filename buffer-file-name)) + (kill-buffer (prog1 (current-buffer) + (set-buffer (byte-compile-from-buffer (current-buffer))))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (let ((vms-stmlf-recfm t)) + (setq target-file (byte-compile-dest-file filename)) + (or byte-compile-overwrite-file + (condition-case () + (delete-file target-file) + (error nil))) + (if (file-writable-p target-file) + (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki + (write-region 1 (point-max) target-file)) + ;; This is just to give a better error message than write-region + (signal 'file-error (list "Opening output file" + (if (file-exists-p target-file) + "cannot overwrite file" + "directory not writable or nonexistent") + target-file))) + (or byte-compile-overwrite-file + (condition-case () + (set-file-modes target-file (file-modes filename)) + (error nil)))) + (kill-buffer (current-buffer))) + (if (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " filename)))) + (save-excursion + (byte-compile-report-call-tree filename))) + (if load + (load target-file))) + t) + +(defun byte-compile-and-load-file (&optional filename) + "Compile a file of Lisp code named FILENAME into a file of byte code, +and then load it. The output file's name is made by appending \"c\" to +the end of FILENAME." + (interactive) + (if filename ; I don't get it, (interactive-p) doesn't always work + (byte-compile-file filename t) + (let ((current-prefix-arg '(4))) + (call-interactively 'byte-compile-file)))) + + +(defun byte-compile-buffer (&optional buffer) + "Byte-compile and evaluate contents of BUFFER (default: the current buffer)." + (interactive "bByte compile buffer: ") + (setq buffer (if buffer (get-buffer buffer) (current-buffer))) + (message "Compiling %s..." (buffer-name buffer)) + (let* ((filename (or (buffer-file-name buffer) + (concat "#<buffer " (buffer-name buffer) ">"))) + (byte-compile-current-file buffer)) + (byte-compile-from-buffer buffer t)) + (message "Compiling %s...done" (buffer-name buffer)) + t) + +;;; compiling a single function +(defun elisp-compile-defun (&optional arg) + "Compile and evaluate the current top-level form. +Print the result in the minibuffer. +With argument, insert value in current buffer after the form." + (interactive "P") + (save-excursion + (end-of-defun) + (beginning-of-defun) + (let* ((byte-compile-current-file nil) + (byte-compile-last-warned-form 'nothing) + (value (eval (byte-compile-sexp (read (current-buffer)))))) + (cond (arg + (message "Compiling from buffer... done.") + (prin1 value (current-buffer)) + (insert "\n")) + ((message "%s" (prin1-to-string value))))))) + + +(defun byte-compile-from-buffer (inbuffer &optional eval) + ;; buffer --> output-buffer, or buffer --> eval form, return nil + (let (outbuffer) + (let (;; Prevent truncation of flonums and lists as we read and print them + (float-output-format "%20e") + (case-fold-search nil) + (print-length nil) + ;; Simulate entry to byte-compile-top-level + (byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil) + ;; #### This is bound in b-c-close-variables. + ;;(byte-compile-warnings (if (eq byte-compile-warnings t) + ;; byte-compile-warning-types + ;; byte-compile-warnings)) + ) + (byte-compile-close-variables + (save-excursion + (setq outbuffer + (set-buffer (get-buffer-create " *Compiler Output*"))) + (erase-buffer) +;; (emacs-lisp-mode) + (setq case-fold-search nil)) + (displaying-byte-compile-warnings + (save-excursion + (set-buffer inbuffer) + (goto-char 1) + (while (progn + (while (progn (skip-chars-forward " \t\n\^l") + (looking-at ";")) + (forward-line 1)) + (not (eobp))) + (byte-compile-file-form (read inbuffer))) + ;; Compile pending forms at end of file. + (byte-compile-flush-pending) + (and (not eval) (byte-compile-insert-header)) + (byte-compile-warn-about-unresolved-functions) + ;; always do this? When calling multiple files, it would be useful + ;; to delay this warning until all have been compiled. + (setq byte-compile-unresolved-functions nil))) + (save-excursion + (set-buffer outbuffer) + (goto-char (point-min))))) + (if (not eval) + outbuffer + (while (condition-case nil + (progn (setq form (read outbuffer)) + t) + (end-of-file nil)) + (eval form)) + (kill-buffer outbuffer) + nil))) + +(defun byte-compile-insert-header () + (save-excursion + (set-buffer outbuffer) + (goto-char 1) + (insert ";;; compiled by " (user-login-name) "@" (system-name) " on " + (current-time-string) "\n;;; from file " filename "\n") + (insert ";;; emacs version " emacs-version ".\n") + (insert ";;; bytecomp version " byte-compile-version "\n;;; " + (cond + ((eq byte-optimize 'source) "source-level optimization only") + ((eq byte-optimize 'byte) "byte-level optimization only") + (byte-optimize "optimization is on") + (t "optimization is off")) + (if (byte-compile-version-cond byte-compile-emacs18-compatibility) + "; compiled with emacs18 compatibility.\n" + ".\n")) + (if (byte-compile-version-cond byte-compile-generate-emacs19-bytecodes) + (insert ";;; this file uses opcodes which do not exist in Emacs18.\n" + ;; Have to check if emacs-version is bound so that this works + ;; in files loaded early in loadup.el. + "\n(if (and (boundp 'emacs-version)\n" + "\t (or (and (boundp 'epoch::version) epoch::version)\n" + "\t (string-lessp emacs-version \"19\")))\n" + " (error \"This file was compiled for Emacs19.\"))\n" + )) + )) + + +(defun byte-compile-output-file-form (form) + ;; writes the given form to the output buffer, being careful of docstrings + ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is + ;; so amazingly stupid. + ;; fset's are output directly by byte-compile-file-form-defmumble; it does + ;; not pay to first build the fset in defmumble and then parse it here. + (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload)) + (stringp (nth 3 form))) + (byte-compile-output-docform '("\n(" 3 ")") form) + (let ((print-escape-newlines t) + (print-readably t)) + (princ "\n" outbuffer) + (prin1 form outbuffer) + nil))) + +(defun byte-compile-output-docform (info form) + ;; Print a form with a doc string. INFO is (prefix doc-index postfix). + (set-buffer + (prog1 (current-buffer) + (set-buffer outbuffer) + (insert (car info)) + (let ((docl (nthcdr (nth 1 info) form)) + (print-escape-newlines t) + (print-readably t)) + (prin1 (car form) outbuffer) + (while (setq form (cdr form)) + (insert " ") + (if (eq form docl) + (let ((print-escape-newlines nil)) + (goto-char (prog1 (1+ (point)) + (prin1 (car form) outbuffer))) + (insert "\\\n") + (goto-char (point-max))) + (prin1 (car form) outbuffer)))) + (insert (nth 2 info)))) + nil) + +(defun byte-compile-keep-pending (form &optional handler) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form t))) + (if handler + (let ((for-effect t)) + ;; To avoid consing up monstrously large forms at load time, we split + ;; the output regularly. + (and (eq (car-safe form) 'fset) (nthcdr 300 byte-compile-output) + (byte-compile-flush-pending)) + (funcall handler form) + (if for-effect + (byte-compile-discard))) + (byte-compile-form form t)) + nil) + +(defun byte-compile-flush-pending () + (if byte-compile-output + (let ((form (byte-compile-out-toplevel t 'file))) + (cond ((eq (car-safe form) 'progn) + (mapcar 'byte-compile-output-file-form (cdr form))) + (form + (byte-compile-output-file-form form))) + (setq byte-compile-constants nil + byte-compile-variables nil + byte-compile-depth 0 + byte-compile-maxdepth 0 + byte-compile-output nil)))) + +(defun byte-compile-file-form (form) + (let ((byte-compile-current-form nil) ; close over this for warnings. + handler) + (cond + ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + ((eq form (setq form (macroexpand form byte-compile-macro-environment))) + (byte-compile-keep-pending form)) + (t + (byte-compile-file-form form))))) + +;; Functions and variables with doc strings must be output separately, +;; so make-docfile can recognise them. Most other things can be output +;; as byte-code. + +(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst) +(defun byte-compile-file-form-defsubst (form) + (cond ((assq (nth 1 form) byte-compile-unresolved-functions) + (setq byte-compile-current-form (nth 1 form)) + (byte-compile-warn "defsubst %s was used before it was defined" + (nth 1 form)))) + (byte-compile-file-form + (macroexpand form byte-compile-macro-environment)) + ;; Return nil so the form is not output twice. + nil) + +(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload) +(defun byte-compile-file-form-autoload (form) + (and (let ((form form)) + (while (if (setq form (cdr form)) (byte-compile-constp (car form)))) + (null form)) ;Constants only + (eval (nth 5 form)) ;Macro + (eval form)) ;Define the autoload. + (if (stringp (nth 3 form)) + form + ;; No doc string, so we can compile this as a normal form. + (byte-compile-keep-pending form 'byte-compile-normal-call))) + +(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar) +(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar) +(defun byte-compile-file-form-defvar (form) + (if (null (nth 3 form)) + ;; Since there is no doc string, we can compile this as a normal form, + ;; and not do a file-boundary. + (byte-compile-keep-pending form) + (if (memq 'free-vars byte-compile-warnings) + (setq byte-compile-bound-variables + (cons (nth 1 form) byte-compile-bound-variables))) + (cond ((consp (nth 2 form)) + (setq form (copy-sequence form)) + (setcar (cdr (cdr form)) + (byte-compile-top-level (nth 2 form) nil 'file)))) + form)) + +(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary) +(defun byte-compile-file-form-eval-boundary (form) + (eval form) + (byte-compile-keep-pending form 'byte-compile-normal-call)) + +(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn) +(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn) +(defun byte-compile-file-form-progn (form) + (mapcar 'byte-compile-file-form (cdr form)) + ;; Return nil so the forms are not output twice. + nil) + +;; This handler is not necessary, but it makes the output from dont-compile +;; and similar macros cleaner. +(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) +(defun byte-compile-file-form-eval (form) + (if (eq (car-safe (nth 1 form)) 'quote) + (nth 1 (nth 1 form)) + (byte-compile-keep-pending form))) + +(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun) +(defun byte-compile-file-form-defun (form) + (byte-compile-file-form-defmumble form nil)) + +(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro) +(defun byte-compile-file-form-defmacro (form) + (byte-compile-file-form-defmumble form t)) + +(defun byte-compile-file-form-defmumble (form macrop) + (let* ((name (car (cdr form))) + (this-kind (if macrop 'byte-compile-macro-environment + 'byte-compile-function-environment)) + (that-kind (if macrop 'byte-compile-function-environment + 'byte-compile-macro-environment)) + (this-one (assq name (symbol-value this-kind))) + (that-one (assq name (symbol-value that-kind))) + (byte-compile-free-references nil) + (byte-compile-free-assignments nil)) + + ;; When a function or macro is defined, add it to the call tree so that + ;; we can tell when functions are not used. + (if byte-compile-generate-call-tree + (or (assq name byte-compile-call-tree) + (setq byte-compile-call-tree + (cons (list name nil nil) byte-compile-call-tree)))) + + (setq byte-compile-current-form name) ; for warnings + (if (memq 'redefine byte-compile-warnings) + (byte-compile-arglist-warn form macrop)) + (if byte-compile-verbose + (message "Compiling %s (%s)..." (or filename "") (nth 1 form))) + (cond (that-one + (if (and (memq 'redefine byte-compile-warnings) + ;; don't warn when compiling the stubs in bytecomp-runtime... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn + "%s defined multiple times, as both function and macro" + (nth 1 form))) + (setcdr that-one nil)) + (this-one + (if (and (memq 'redefine byte-compile-warnings) + ;; hack: don't warn when compiling the magic internal + ;; byte-compiler macros in bytecomp-runtime.el... + (not (assq (nth 1 form) + byte-compile-initial-macro-environment))) + (byte-compile-warn "%s %s defined multiple times in this file" + (if macrop "macro" "function") + (nth 1 form)))) + ((and (fboundp name) + (eq (car-safe (symbol-function name)) + (if macrop 'lambda 'macro))) + (if (memq 'redefine byte-compile-warnings) + (byte-compile-warn "%s %s being redefined as a %s" + (if macrop "function" "macro") + (nth 1 form) + (if macrop "macro" "function"))) + ;; shadow existing definition + (set this-kind + (cons (cons name nil) (symbol-value this-kind)))) + ) + (let ((body (nthcdr 3 form))) + (if (and (stringp (car body)) + (symbolp (car-safe (cdr-safe body))) + (car-safe (cdr-safe body)) + (stringp (car-safe (cdr-safe (cdr-safe body))))) + (byte-compile-warn "Probable `\"' without `\\' in doc string of %s" + (nth 1 form)))) + (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) + (code (byte-compile-byte-code-maker new-one))) + (if this-one + (setcdr this-one new-one) + (set this-kind + (cons (cons name new-one) (symbol-value this-kind)))) + (if (and (stringp (nth 3 form)) + (eq 'quote (car-safe code)) + (eq 'lambda (car-safe (nth 1 code)))) + (cons (car form) + (cons name (cdr (nth 1 code)))) + (if (not (stringp (nth 3 form))) + ;; No doc string to make-docfile; insert form in normal code. + (byte-compile-keep-pending + (list 'fset (list 'quote name) + (cond ((not macrop) + code) + ((eq 'make-byte-code (car-safe code)) + (list 'cons ''macro code)) + ((list 'quote (if macrop + (cons 'macro new-one) + new-one))))) + 'byte-compile-two-args) + ;; Output the form by hand, that's much simpler than having + ;; b-c-output-file-form analyze the fset. + (byte-compile-flush-pending) + (princ "\n(fset '" outbuffer) + (prin1 name outbuffer) + (byte-compile-output-docform + (cond ((atom code) + (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) + ((eq (car code) 'quote) + (setq code new-one) + (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) + ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) + (append code nil)) + (princ ")" outbuffer) + nil))))) + + +(defun byte-compile (form) + "If FORM is a symbol, byte-compile its function definition. +If FORM is a lambda or a macro, byte-compile it as a function." + (displaying-byte-compile-warnings + (byte-compile-close-variables + (let* ((fun (if (symbolp form) + (and (fboundp form) (symbol-function form)) + form)) + (macro (eq (car-safe fun) 'macro))) + (if macro + (setq fun (cdr fun))) + (cond ((eq (car-safe fun) 'lambda) + (setq fun (if macro + (cons 'macro (byte-compile-lambda fun)) + (byte-compile-lambda fun))) + (if (symbolp form) + (fset form fun) + fun))))))) + +(defun byte-compile-sexp (sexp) + "Compile and return SEXP." + (displaying-byte-compile-warnings + (byte-compile-close-variables + (byte-compile-top-level sexp)))) + +;; Given a function made by byte-compile-lambda, make a form which produces it. +(defun byte-compile-byte-code-maker (fun) + (cond + ((byte-compile-version-cond byte-compile-emacs18-compatibility) + ;; Return (quote (lambda ...)). + (list 'quote (byte-compile-byte-code-unmake fun))) + ;; ## atom is faster than compiled-func-p. + ((atom fun) ; compiled function. + ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda + ;; would have produced a lambda. + fun) + ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial + ;; function, or this is emacs18, or generate-emacs19-bytecodes is off. + ((let (tmp) + (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun)))) + (null (cdr (memq tmp fun)))) + ;; Generate a make-byte-code call. + (let* ((interactive (assq 'interactive (cdr (cdr fun))))) + (nconc (list 'make-byte-code + (list 'quote (nth 1 fun)) ;arglist + (nth 1 tmp) ;bytes + (nth 2 tmp) ;consts + (nth 3 tmp)) ;depth + (cond ((stringp (nth 2 fun)) + (list (nth 2 fun))) ;doc + (interactive + (list nil))) + (cond (interactive + (list (if (or (null (nth 1 interactive)) + (stringp (nth 1 interactive))) + (nth 1 interactive) + ;; Interactive spec is a list or a variable + ;; (if it is correct). + (list 'quote (nth 1 interactive)))))))) + ;; a non-compiled function (probably trivial) + (list 'quote fun)))))) + +;; Turn a function into an ordinary lambda. Needed for v18 files. +(defun byte-compile-byte-code-unmake (function) + (if (consp function) + function;;It already is a lambda. + (setq function (append function nil)) ; turn it into a list + (nconc (list 'lambda (nth 0 function)) + (and (nth 4 function) (list (nth 4 function))) + (if (nthcdr 5 function) + (list (cons 'interactive (if (nth 5 function) + (nthcdr 5 function))))) + (list (list 'byte-code + (nth 1 function) (nth 2 function) + (nth 3 function)))))) + + +;; Byte-compile a lambda-expression and return a valid function. +;; The value is usually a compiled function but may be the original +;; lambda-expression. +(defun byte-compile-lambda (fun) + (let* ((arglist (nth 1 fun)) + (byte-compile-bound-variables + (nconc (and (memq 'free-vars byte-compile-warnings) + (delq '&rest (delq '&optional (copy-sequence arglist)))) + byte-compile-bound-variables)) + (body (cdr (cdr fun))) + (doc (if (stringp (car body)) + (prog1 (car body) + (setq body (cdr body))))) + (int (assq 'interactive body))) + (cond (int + ;; Skip (interactive) if it is in front (the most usual location). + (if (eq int (car body)) + (setq body (cdr body))) + (cond ((cdr int) + (if (cdr (cdr int)) + (byte-compile-warn "malformed interactive spec: %s" + (prin1-to-string int))) + (setq int (list 'interactive (byte-compile-top-level + (nth 1 int)))))))) + (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda))) + (if (and (eq 'byte-code (car-safe compiled)) + (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes)) + (apply 'make-byte-code + (append (list arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or doc int) + (list doc)) + ;; optionally, the interactive spec. + (if int + (list (nth 1 int))))) + (setq compiled + (nconc (if int (list int)) + (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) + (compiled (list compiled))))) + (nconc (list 'lambda arglist) + (if (or doc (stringp (car compiled))) + (cons doc (cond (compiled) + (body (list nil)))) + compiled)))))) + +(defun byte-compile-constants-vector () + ;; Builds the constants-vector from the current variables and constants. + ;; This modifies the constants from (const . nil) to (const . offset). + ;; To keep the byte-codes to look up the vector as short as possible: + ;; First 6 elements are vars, as there are one-byte varref codes for those. + ;; Next up to byte-constant-limit are constants, still with one-byte codes. + ;; Next variables again, to get 2-byte codes for variable lookup. + ;; The rest of the constants and variables need 3-byte byte-codes. + (let* ((i -1) + (rest (nreverse byte-compile-variables)) ; nreverse because the first + (other (nreverse byte-compile-constants)) ; vars often are used most. + ret tmp + (limits '(5 ; Use the 1-byte varref codes, + 63 ; 1-constlim ; 1-byte byte-constant codes, + 255 ; 2-byte varref codes, + 65535)) ; 3-byte codes for the rest. + limit) + (while (or rest other) + (setq limit (car limits)) + (while (and rest (not (eq i limit))) + (if (setq tmp (assq (car (car rest)) ret)) + (setcdr (car rest) (cdr tmp)) + (setcdr (car rest) (setq i (1+ i))) + (setq ret (cons (car rest) ret))) + (setq rest (cdr rest))) + (setq limits (cdr limits) + rest (prog1 other + (setq other rest)))) + (apply 'vector (nreverse (mapcar 'car ret))))) + +;; Given an expression FORM, compile it and return an equivalent byte-code +;; expression (a call to the function byte-code). +(defun byte-compile-top-level (form &optional for-effect output-type) + ;; OUTPUT-TYPE advises about how form is expected to be used: + ;; 'eval or nil -> a single form, + ;; 'progn or t -> a list of forms, + ;; 'lambda -> body of a lambda, + ;; 'file -> used at file-level. + (let ((byte-compile-constants nil) + (byte-compile-variables nil) + (byte-compile-tag-number 0) + (byte-compile-depth 0) + (byte-compile-maxdepth 0) + (byte-compile-output nil)) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) + +(defun byte-compile-out-toplevel (&optional for-effect output-type) + (if for-effect + ;; The stack is empty. Push a value to be returned from (byte-code ..). + (if (eq (car (car byte-compile-output)) 'byte-discard) + (setq byte-compile-output (cdr byte-compile-output)) + (byte-compile-push-constant + ;; Push any constant - preferably one which already is used, and + ;; a number or symbol - ie not some big sequence. The return value + ;; isn't returned, but it would be a shame if some textually large + ;; constant was not optimized away because we chose to return it. + (and (not (assq nil byte-compile-constants)) ; Nil is often there. + (let ((tmp (reverse byte-compile-constants))) + (while (and tmp (not (or (symbolp (car (car tmp))) + (numberp (car (car tmp)))))) + (setq tmp (cdr tmp))) + (car (car tmp))))))) + (byte-compile-out 'byte-return 0) + (setq byte-compile-output (nreverse byte-compile-output)) + (if (memq byte-optimize '(t byte)) + (setq byte-compile-output + (byte-optimize-lapcode byte-compile-output for-effect))) + + ;; Decompile trivial functions: + ;; only constants and variables, or a single funcall except in lambdas. + ;; Except for Lisp_Compiled objects, forms like (foo "hi") + ;; are still quicker than (byte-code "..." [foo "hi"] 2). + ;; Note that even (quote foo) must be parsed just as any subr by the + ;; interpreter, so quote should be compiled into byte-code in some contexts. + ;; What to leave uncompiled: + ;; lambda -> a single atom. + ;; eval -> atom, quote or (function atom atom atom) + ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom) + ;; file -> as progn, but takes both quotes and atoms, and longer forms. + (let (rest + (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall. + tmp body) + (cond + ;; #### This should be split out into byte-compile-nontrivial-function-p. + ((or (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output) + (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit. + (not (setq tmp (assq 'byte-return byte-compile-output))) + (progn + (setq rest (nreverse + (cdr (memq tmp (reverse byte-compile-output))))) + (while (cond + ((memq (car (car rest)) '(byte-varref byte-constant)) + (setq tmp (car (cdr (car rest)))) + (if (if (eq (car (car rest)) 'byte-constant) + (or (consp tmp) + (and (symbolp tmp) + (not (memq tmp '(nil t)))))) + (if maycall + (setq body (cons (list 'quote tmp) body))) + (setq body (cons tmp body)))) + ((and maycall + ;; Allow a funcall if at most one atom follows it. + (null (nthcdr 3 rest)) + (setq tmp (get (car (car rest)) 'byte-opcode-invert)) + (or (null (cdr rest)) + (and (memq output-type '(file progn t)) + (cdr (cdr rest)) + (eq (car (nth 1 rest)) 'byte-discard) + (progn (setq rest (cdr rest)) t)))) + (setq maycall nil) ; Only allow one real function call. + (setq body (nreverse body)) + (setq body (list + (if (and (eq tmp 'funcall) + (eq (car-safe (car body)) 'quote)) + (cons (nth 1 (car body)) (cdr body)) + (cons tmp body)))) + (or (eq output-type 'file) + (not (delq nil (mapcar 'consp (cdr (car body)))))))) + (setq rest (cdr rest))) + rest) + (and (consp (car body)) (eq output-type 'lambda))) + (let ((byte-compile-vector (byte-compile-constants-vector))) + (list 'byte-code (byte-compile-lapcode byte-compile-output) + byte-compile-vector byte-compile-maxdepth))) + ;; it's a trivial function + ((cdr body) (cons 'progn (nreverse body))) + ((car body))))) + +;; Given BODY, compile it and return a new body. +(defun byte-compile-top-level-body (body &optional for-effect) + (setq body (byte-compile-top-level (cons 'progn body) for-effect t)) + (cond ((eq (car-safe body) 'progn) + (cdr body)) + (body + (list body)))) + +;; This is the recursive entry point for compiling each subform of an +;; expression. +;; If for-effect is non-nil, byte-compile-form will output a byte-discard +;; before terminating (ie no value will be left on the stack). +;; A byte-compile handler may, when for-effect is non-nil, choose output code +;; which does not leave a value on the stack, and then set for-effect to nil +;; (to prevent byte-compile-form from outputting the byte-discard). +;; If a handler wants to call another handler, it should do so via +;; byte-compile-form, or take extreme care to handle for-effect correctly. +;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) +;; +(defun byte-compile-form (form &optional for-effect) + (setq form (macroexpand form byte-compile-macro-environment)) + (cond ((not (consp form)) + (cond ((or (not (symbolp form)) (memq form '(nil t))) + (byte-compile-constant form)) + ((and for-effect byte-compile-delete-errors) + (setq for-effect nil)) + (t (byte-compile-variable-ref 'byte-varref form)))) + ((symbolp (car form)) + (let* ((fn (car form)) + (handler (get fn 'byte-compile))) + (if (and handler + (or (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes) + (not (get (get fn 'byte-opcode) 'emacs19-opcode)))) + (funcall handler form) + (if (memq 'callargs byte-compile-warnings) + (byte-compile-callargs-warn form)) + (byte-compile-normal-call form)))) + ((and (or (compiled-function-p (car form)) + (eq (car-safe (car form)) 'lambda)) + ;; if the form comes out the same way it went in, that's + ;; because it was malformed, and we couldn't unfold it. + (not (eq form (setq form (byte-compile-unfold-lambda form))))) + (byte-compile-form form for-effect) + (setq for-effect nil)) + ((byte-compile-normal-call form))) + (if for-effect + (byte-compile-discard))) + +(defun byte-compile-normal-call (form) + (if byte-compile-generate-call-tree + (byte-compile-annotate-call-tree form)) + (byte-compile-push-constant (car form)) + (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster. + (byte-compile-out 'byte-call (length (cdr form)))) + +(defun byte-compile-variable-ref (base-op var) + (if (or (not (symbolp var)) (memq var '(nil t))) + (byte-compile-warn (if (eq base-op 'byte-varbind) + "Attempt to let-bind %s %s" + "Variable reference to %s %s") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)) + (if (memq 'free-vars byte-compile-warnings) + (if (eq base-op 'byte-varbind) + (setq byte-compile-bound-variables + (cons var byte-compile-bound-variables)) + (or (boundp var) + (memq var byte-compile-bound-variables) + (if (eq base-op 'byte-varset) + (or (memq var byte-compile-free-assignments) + (progn + (byte-compile-warn "assignment to free variable %s" var) + (setq byte-compile-free-assignments + (cons var byte-compile-free-assignments)))) + (or (memq var byte-compile-free-references) + (progn + (byte-compile-warn "reference to free variable %s" var) + (setq byte-compile-free-references + (cons var byte-compile-free-references))))))))) + (let ((tmp (assq var byte-compile-variables))) + (or tmp + (setq tmp (list var) + byte-compile-variables (cons tmp byte-compile-variables))) + (byte-compile-out base-op tmp))) + +(defmacro byte-compile-get-constant (const) + (` (or (if (stringp (, const)) + (assoc (, const) byte-compile-constants) + (assq (, const) byte-compile-constants)) + (car (setq byte-compile-constants + (cons (list (, const)) byte-compile-constants)))))) + +;; Use this when the value of a form is a constant. This obeys for-effect. +(defun byte-compile-constant (const) + (if for-effect + (setq for-effect nil) + (byte-compile-out 'byte-constant (byte-compile-get-constant const)))) + +;; Use this for a constant that is not the value of its containing form. +;; This ignores for-effect. +(defun byte-compile-push-constant (const) + (let ((for-effect nil)) + (inline (byte-compile-constant const)))) + + +;; Compile those primitive ordinary functions +;; which have special byte codes just for speed. + +(defmacro byte-defop-compiler (function &optional compile-handler) + ;; add a compiler-form for FUNCTION. + ;; If function is a symbol, then the variable "byte-SYMBOL" must name + ;; the opcode to be used. If function is a list, the first element + ;; is the function and the second element is the bytecode-symbol. + ;; COMPILE-HANDLER is the function to use to compile this byte-op, or + ;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2. + ;; If it is nil, then the handler is "byte-compile-SYMBOL." + (let (opcode) + (if (symbolp function) + (setq opcode (intern (concat "byte-" (symbol-name function)))) + (setq opcode (car (cdr function)) + function (car function))) + (let ((fnform + (list 'put (list 'quote function) ''byte-compile + (list 'quote + (or (cdr (assq compile-handler + '((0 . byte-compile-no-args) + (1 . byte-compile-one-arg) + (2 . byte-compile-two-args) + (3 . byte-compile-three-args) + (0-1 . byte-compile-zero-or-one-arg) + (1-2 . byte-compile-one-or-two-args) + (2-3 . byte-compile-two-or-three-args) + ))) + compile-handler + (intern (concat "byte-compile-" + (symbol-name function)))))))) + (if opcode + (list 'progn fnform + (list 'put (list 'quote function) + ''byte-opcode (list 'quote opcode)) + (list 'put (list 'quote opcode) + ''byte-opcode-invert (list 'quote function))) + fnform)))) + +(defmacro byte-defop-compiler19 (function &optional compile-handler) + ;; Just like byte-defop-compiler, but defines an opcode that will only + ;; be used when byte-compile-generate-emacs19-bytecodes is true. + (if (and (byte-compile-single-version) + (not byte-compile-generate-emacs19-bytecodes)) + nil + (list 'progn + (list 'put + (list 'quote + (or (car (cdr-safe function)) + (intern (concat "byte-" + (symbol-name (or (car-safe function) function)))))) + ''emacs19-opcode t) + (list 'byte-defop-compiler function compile-handler)))) + +(defmacro byte-defop-compiler-1 (function &optional compile-handler) + (list 'byte-defop-compiler (list function nil) compile-handler)) + + +(put 'byte-call 'byte-opcode-invert 'funcall) +(put 'byte-list1 'byte-opcode-invert 'list) +(put 'byte-list2 'byte-opcode-invert 'list) +(put 'byte-list3 'byte-opcode-invert 'list) +(put 'byte-list4 'byte-opcode-invert 'list) +(put 'byte-listN 'byte-opcode-invert 'list) +(put 'byte-concat2 'byte-opcode-invert 'concat) +(put 'byte-concat3 'byte-opcode-invert 'concat) +(put 'byte-concat4 'byte-opcode-invert 'concat) +(put 'byte-concatN 'byte-opcode-invert 'concat) +(put 'byte-insertN 'byte-opcode-invert 'insert) + +(byte-defop-compiler (dot byte-point) 0) +(byte-defop-compiler (dot-max byte-point-max) 0) +(byte-defop-compiler (dot-min byte-point-min) 0) +(byte-defop-compiler point 0) +;;(byte-defop-compiler mark 0) ;; obsolete +(byte-defop-compiler point-max 0) +(byte-defop-compiler point-min 0) +(byte-defop-compiler following-char 0) +(byte-defop-compiler preceding-char 0) +(byte-defop-compiler current-column 0) +(byte-defop-compiler eolp 0) +(byte-defop-compiler eobp 0) +(byte-defop-compiler bolp 0) +(byte-defop-compiler bobp 0) +(byte-defop-compiler current-buffer 0) +;;(byte-defop-compiler read-char 0) ;; obsolete +(byte-defop-compiler interactive-p 0) +(byte-defop-compiler19 widen 0) +(byte-defop-compiler19 end-of-line 0-1) +(byte-defop-compiler19 forward-char 0-1) +(byte-defop-compiler19 forward-line 0-1) +(byte-defop-compiler symbolp 1) +(byte-defop-compiler consp 1) +(byte-defop-compiler stringp 1) +(byte-defop-compiler listp 1) +(byte-defop-compiler not 1) +(byte-defop-compiler (null byte-not) 1) +(byte-defop-compiler car 1) +(byte-defop-compiler cdr 1) +(byte-defop-compiler length 1) +(byte-defop-compiler symbol-value 1) +(byte-defop-compiler symbol-function 1) +(byte-defop-compiler (1+ byte-add1) 1) +(byte-defop-compiler (1- byte-sub1) 1) +(byte-defop-compiler goto-char 1) +(byte-defop-compiler char-after 1) +(byte-defop-compiler set-buffer 1) +;;(byte-defop-compiler set-mark 1) ;; obsolete +(byte-defop-compiler19 forward-word 1) +(byte-defop-compiler19 char-syntax 1) +(byte-defop-compiler19 nreverse 1) +(byte-defop-compiler19 car-safe 1) +(byte-defop-compiler19 cdr-safe 1) +(byte-defop-compiler19 numberp 1) +(byte-defop-compiler19 integerp 1) +(byte-defop-compiler19 skip-chars-forward 1-2) +(byte-defop-compiler19 skip-chars-backward 1-2) +(byte-defop-compiler (eql byte-eq) 2) +(byte-defop-compiler eq 2) +(byte-defop-compiler memq 2) +(byte-defop-compiler cons 2) +(byte-defop-compiler aref 2) +(byte-defop-compiler set 2) +(byte-defop-compiler (= byte-eqlsign) 2) +(byte-defop-compiler (< byte-lss) 2) +(byte-defop-compiler (> byte-gtr) 2) +(byte-defop-compiler (<= byte-leq) 2) +(byte-defop-compiler (>= byte-geq) 2) +(byte-defop-compiler get 2) +(byte-defop-compiler nth 2) +(byte-defop-compiler substring 2-3) +(byte-defop-compiler (move-marker byte-set-marker) 2-3) +(byte-defop-compiler19 set-marker 2-3) +(byte-defop-compiler19 match-beginning 1) +(byte-defop-compiler19 match-end 1) +(byte-defop-compiler19 upcase 1) +(byte-defop-compiler19 downcase 1) +(byte-defop-compiler19 string= 2) +(byte-defop-compiler19 string< 2) +(byte-defop-compiler (string-equal byte-string=) 2) +(byte-defop-compiler (string-lessp byte-string<) 2) +(byte-defop-compiler19 equal 2) +(byte-defop-compiler19 nthcdr 2) +(byte-defop-compiler19 elt 2) +(byte-defop-compiler19 member 2) +(byte-defop-compiler19 assq 2) +(byte-defop-compiler (rplaca byte-setcar) 2) +(byte-defop-compiler (rplacd byte-setcdr) 2) +(byte-defop-compiler19 setcar 2) +(byte-defop-compiler19 setcdr 2) +(byte-defop-compiler19 buffer-substring 2) +(byte-defop-compiler19 delete-region 2) +(byte-defop-compiler19 narrow-to-region 2) +(byte-defop-compiler (mod byte-rem) 2) +(byte-defop-compiler19 (% byte-rem) 2) +(byte-defop-compiler aset 3) + +(byte-defop-compiler max byte-compile-associative) +(byte-defop-compiler min byte-compile-associative) +(byte-defop-compiler (+ byte-plus) byte-compile-associative) +(byte-defop-compiler19 (* byte-mult) byte-compile-associative) + +;;####(byte-defop-compiler19 move-to-column 1) +(byte-defop-compiler-1 interactive byte-compile-noop) + + +(defun byte-compile-subr-wrong-args (form n) + (byte-compile-warn "%s called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) + ;; get run-time wrong-number-of-args error. + (byte-compile-normal-call form)) + +(defun byte-compile-no-args (form) + (if (not (= (length form) 1)) + (byte-compile-subr-wrong-args form "none") + (byte-compile-out (get (car form) 'byte-opcode) 0))) + +(defun byte-compile-one-arg (form) + (if (not (= (length form) 2)) + (byte-compile-subr-wrong-args form 1) + (byte-compile-form (car (cdr form))) ;; Push the argument + (byte-compile-out (get (car form) 'byte-opcode) 0))) + +(defun byte-compile-two-args (form) + (if (not (= (length form) 3)) + (byte-compile-subr-wrong-args form 2) + (byte-compile-form (car (cdr form))) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0))) + +(defun byte-compile-three-args (form) + (if (not (= (length form) 4)) + (byte-compile-subr-wrong-args form 3) + (byte-compile-form (car (cdr form))) ;; Push the arguments + (byte-compile-form (nth 2 form)) + (byte-compile-form (nth 3 form)) + (byte-compile-out (get (car form) 'byte-opcode) 0))) + +(defun byte-compile-zero-or-one-arg (form) + (let ((len (length form))) + (cond ((= len 1) (byte-compile-one-arg (append form '(nil)))) + ((= len 2) (byte-compile-one-arg form)) + (t (byte-compile-subr-wrong-args form "0-1"))))) + +(defun byte-compile-one-or-two-args (form) + (let ((len (length form))) + (cond ((= len 2) (byte-compile-two-args (append form '(nil)))) + ((= len 3) (byte-compile-two-args form)) + (t (byte-compile-subr-wrong-args form "1-2"))))) + +(defun byte-compile-two-or-three-args (form) + (let ((len (length form))) + (cond ((= len 3) (byte-compile-three-args (append form '(nil)))) + ((= len 4) (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "2-3"))))) + +(defun byte-compile-noop (form) + (byte-compile-constant nil)) + +(defun byte-compile-discard () + (byte-compile-out 'byte-discard 0)) + + +;; Compile a function that accepts one or more args and is right-associative. +(defun byte-compile-associative (form) + (if (cdr form) + (let ((opcode (get (car form) 'byte-opcode))) + ;; To compile all the args first may enable some optimizaions. + (mapcar 'byte-compile-form (setq form (cdr form))) + (while (setq form (cdr form)) + (byte-compile-out opcode 0))) + (byte-compile-constant (eval form)))) + + +;; more complicated compiler macros + +(byte-defop-compiler list) +(byte-defop-compiler concat) +(byte-defop-compiler fset) +(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to) +(byte-defop-compiler indent-to) +(byte-defop-compiler insert) +(byte-defop-compiler-1 function byte-compile-function-form) +(byte-defop-compiler-1 - byte-compile-minus) +(byte-defop-compiler19 (/ byte-quo) byte-compile-quo) +(byte-defop-compiler19 nconc) +(byte-defop-compiler-1 beginning-of-line) + +(defun byte-compile-list (form) + (let ((count (length (cdr form)))) + (cond ((= count 0) + (byte-compile-constant nil)) + ((< count 5) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out + (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0)) + ((and (< count 256) (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes)) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-listN count)) + (t (byte-compile-normal-call form))))) + +(defun byte-compile-concat (form) + (let ((count (length (cdr form)))) + (cond ((and (< 1 count) (< count 5)) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out + (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2)) + 0)) + ;; Concat of one arg is not a no-op if arg is not a string. + ((= count 0) + (byte-compile-form "")) + ((and (< count 256) (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes)) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-concatN count)) + ((byte-compile-normal-call form))))) + +(defun byte-compile-minus (form) + (if (null (setq form (cdr form))) + (byte-compile-constant 0) + (byte-compile-form (car form)) + (if (cdr form) + (while (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-out 'byte-diff 0)) + (byte-compile-out 'byte-negate 0)))) + +(defun byte-compile-quo (form) + (let ((len (length form))) + (cond ((<= len 2) + (byte-compile-subr-wrong-args form "2 or more")) + (t + (byte-compile-form (car (setq form (cdr form)))) + (while (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-out 'byte-quo 0)))))) + +(defun byte-compile-nconc (form) + (let ((len (length form))) + (cond ((= len 1) + (byte-compile-constant nil)) + ((= len 2) + ;; nconc of one arg is a noop, even if that arg isn't a list. + (byte-compile-form (nth 1 form))) + (t + (byte-compile-form (car (setq form (cdr form)))) + (while (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-out 'byte-nconc 0)))))) + +(defun byte-compile-fset (form) + ;; warn about forms like (fset 'foo '(lambda () ...)) + ;; (where the lambda expression is non-trivial...) + (let ((fn (nth 2 form)) + body) + (if (and (eq (car-safe fn) 'quote) + (eq (car-safe (setq fn (nth 1 fn))) 'lambda)) + (progn + (setq body (cdr (cdr fn))) + (if (stringp (car body)) (setq body (cdr body))) + (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) + (if (and (consp (car body)) + (not (eq 'byte-code (car (car body))))) + (byte-compile-warn + "A quoted lambda form is the second argument of fset. This is probably + not what you want, as that lambda cannot be compiled. Consider using + the syntax (function (lambda (...) ...)) instead."))))) + (byte-compile-two-args form)) + +(defun byte-compile-funarg (form) + ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) + ;; for cases where it's guarenteed that first arg will be used as a lambda. + (byte-compile-normal-call + (let ((fn (nth 1 form))) + (if (and (eq (car-safe fn) 'quote) + (eq (car-safe (nth 1 fn)) 'lambda)) + (cons (car form) + (cons (cons 'function (cdr fn)) + (cdr (cdr form)))) + form)))) + +;; (function foo) must compile like 'foo, not like (symbol-function 'foo). +;; Otherwise it will be incompatible with the interpreter, +;; and (funcall (function foo)) will lose with autoloads. + +(defun byte-compile-function-form (form) + (byte-compile-constant + (cond ((symbolp (nth 1 form)) + (nth 1 form)) + ;; If we're not allowed to use #[] syntax, then output a form like + ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code. + ;; In this situation, calling make-byte-code at run-time will usually + ;; be less efficient than processing a call to byte-code. + ((byte-compile-version-cond byte-compile-emacs18-compatibility) + (byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form)))) + ((byte-compile-lambda (nth 1 form)))))) + +(defun byte-compile-indent-to (form) + (let ((len (length form))) + (cond ((= len 2) + (byte-compile-form (car (cdr form))) + (byte-compile-out 'byte-indent-to 0)) + ((= len 3) + ;; no opcode for 2-arg case. + (byte-compile-normal-call form)) + (t + (byte-compile-subr-wrong-args form "1-2"))))) + +(defun byte-compile-insert (form) + (cond ((null (cdr form)) + (byte-compile-constant nil)) + ((and (byte-compile-version-cond + byte-compile-generate-emacs19-bytecodes) + (<= (length form) 256)) + (mapcar 'byte-compile-form (cdr form)) + (if (cdr (cdr form)) + (byte-compile-out 'byte-insertN (length (cdr form))) + (byte-compile-out 'byte-insert 0))) + ((memq t (mapcar 'consp (cdr (cdr form)))) + (byte-compile-normal-call form)) + ;; We can split it; there is no function call after inserting 1st arg. + (t + (while (setq form (cdr form)) + (byte-compile-form (car form)) + (byte-compile-out 'byte-insert 0) + (if (cdr form) + (byte-compile-discard)))))) + +(defun byte-compile-beginning-of-line (form) + (if (not (byte-compile-constp (nth 1 form))) + (byte-compile-normal-call form) + (byte-compile-form + (list 'forward-line + (if (integerp (setq form (or (eval (nth 1 form)) 1))) + (1- form) + (byte-compile-warn "Non-numeric arg to beginning-of-line: %s" + form) + (list '1- (list 'quote form)))) + t) + (byte-compile-constant nil))) + + +(byte-defop-compiler-1 setq) +(byte-defop-compiler-1 setq-default) +(byte-defop-compiler-1 quote) +(byte-defop-compiler-1 quote-form) + +(defun byte-compile-setq (form) + (let ((args (cdr form))) + (if args + (while args + (byte-compile-form (car (cdr args))) + (or for-effect (cdr (cdr args)) + (byte-compile-out 'byte-dup 0)) + (byte-compile-variable-ref 'byte-varset (car args)) + (setq args (cdr (cdr args)))) + ;; (setq), with no arguments. + (byte-compile-form nil for-effect)) + (setq for-effect nil))) + +(defun byte-compile-setq-default (form) + (byte-compile-form + (cons 'set-default (cons (list 'quote (nth 1 form)) + (nthcdr 2 form))))) + +(defun byte-compile-quote (form) + (byte-compile-constant (car (cdr form)))) + +(defun byte-compile-quote-form (form) + (byte-compile-constant (byte-compile-top-level (nth 1 form)))) + + +;;; control structures + +(defun byte-compile-body (body &optional for-effect) + (while (cdr body) + (byte-compile-form (car body) t) + (setq body (cdr body))) + (byte-compile-form (car body) for-effect)) + +(proclaim-inline byte-compile-body-do-effect) +(defun byte-compile-body-do-effect (body) + (byte-compile-body body for-effect) + (setq for-effect nil)) + +(proclaim-inline byte-compile-form-do-effect) +(defun byte-compile-form-do-effect (form) + (byte-compile-form form for-effect) + (setq for-effect nil)) + +(byte-defop-compiler-1 inline byte-compile-progn) +(byte-defop-compiler-1 progn) +(byte-defop-compiler-1 prog1) +(byte-defop-compiler-1 prog2) +(byte-defop-compiler-1 if) +(byte-defop-compiler-1 cond) +(byte-defop-compiler-1 and) +(byte-defop-compiler-1 or) +(byte-defop-compiler-1 while) +(byte-defop-compiler-1 funcall) +(byte-defop-compiler-1 apply byte-compile-funarg) +(byte-defop-compiler-1 mapcar byte-compile-funarg) +(byte-defop-compiler-1 mapatoms byte-compile-funarg) +(byte-defop-compiler-1 mapconcat byte-compile-funarg) +(byte-defop-compiler-1 let) +(byte-defop-compiler-1 let*) + +(defun byte-compile-progn (form) + (byte-compile-body-do-effect (cdr form))) + +(defun byte-compile-prog1 (form) + (byte-compile-form-do-effect (car (cdr form))) + (byte-compile-body (cdr (cdr form)) t)) + +(defun byte-compile-prog2 (form) + (byte-compile-form (nth 1 form) t) + (byte-compile-form-do-effect (nth 2 form)) + (byte-compile-body (cdr (cdr (cdr form))) t)) + +(defmacro byte-compile-goto-if (cond discard tag) + (` (byte-compile-goto + (if (, cond) + (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop) + (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop)) + (, tag)))) + +(defun byte-compile-if (form) + (byte-compile-form (car (cdr form))) + (if (null (nthcdr 3 form)) + ;; No else-forms + (let ((donetag (byte-compile-make-tag))) + (byte-compile-goto-if nil for-effect donetag) + (byte-compile-form (nth 2 form) for-effect) + (byte-compile-out-tag donetag)) + (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag))) + (byte-compile-goto 'byte-goto-if-nil elsetag) + (byte-compile-form (nth 2 form) for-effect) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag elsetag) + (byte-compile-body (cdr (cdr (cdr form))) for-effect) + (byte-compile-out-tag donetag))) + (setq for-effect nil)) + +(defun byte-compile-cond (clauses) + (let ((donetag (byte-compile-make-tag)) + nexttag clause) + (while (setq clauses (cdr clauses)) + (setq clause (car clauses)) + (cond ((or (eq (car clause) t) + (and (eq (car-safe (car clause)) 'quote) + (car-safe (cdr-safe (car clause))))) + ;; Unconditional clause + (setq clause (cons t clause) + clauses nil)) + ((cdr clauses) + (byte-compile-form (car clause)) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t for-effect donetag) + (setq nexttag (byte-compile-make-tag)) + (byte-compile-goto 'byte-goto-if-nil nexttag) + (byte-compile-body (cdr clause) for-effect) + (byte-compile-goto 'byte-goto donetag) + (byte-compile-out-tag nexttag))))) + ;; Last clause + (and (cdr clause) (not (eq (car clause) t)) + (progn (byte-compile-form (car clause)) + (byte-compile-goto-if nil for-effect donetag) + (setq clause (cdr clause)))) + (byte-compile-body-do-effect clause) + (byte-compile-out-tag donetag))) + +(defun byte-compile-and (form) + (let ((failtag (byte-compile-make-tag)) + (args (cdr form))) + (if (null args) + (byte-compile-form-do-effect t) + (while (cdr args) + (byte-compile-form (car args)) + (byte-compile-goto-if nil for-effect failtag) + (setq args (cdr args))) + (byte-compile-form-do-effect (car args)) + (byte-compile-out-tag failtag)))) + +(defun byte-compile-or (form) + (let ((wintag (byte-compile-make-tag)) + (args (cdr form))) + (if (null args) + (byte-compile-form-do-effect nil) + (while (cdr args) + (byte-compile-form (car args)) + (byte-compile-goto-if t for-effect wintag) + (setq args (cdr args))) + (byte-compile-form-do-effect (car args)) + (byte-compile-out-tag wintag)))) + +(defun byte-compile-while (form) + (let ((endtag (byte-compile-make-tag)) + (looptag (byte-compile-make-tag))) + (byte-compile-out-tag looptag) + (byte-compile-form (car (cdr form))) + (byte-compile-goto-if nil for-effect endtag) + (byte-compile-body (cdr (cdr form)) t) + (byte-compile-goto 'byte-goto looptag) + (byte-compile-out-tag endtag) + (setq for-effect nil))) + +(defun byte-compile-funcall (form) + (mapcar 'byte-compile-form (cdr form)) + (byte-compile-out 'byte-call (length (cdr (cdr form))))) + + +(defun byte-compile-let (form) + ;; First compute the binding values in the old scope. + (let ((varlist (car (cdr form)))) + (while varlist + (if (consp (car varlist)) + (byte-compile-form (car (cdr (car varlist)))) + (byte-compile-push-constant nil)) + (setq varlist (cdr varlist)))) + (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope + (varlist (reverse (car (cdr form))))) + (while varlist + (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist)) + (car (car varlist)) + (car varlist))) + (setq varlist (cdr varlist))) + (byte-compile-body-do-effect (cdr (cdr form))) + (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + +(defun byte-compile-let* (form) + (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope + (varlist (copy-sequence (car (cdr form))))) + (while varlist + (if (atom (car varlist)) + (byte-compile-push-constant nil) + (byte-compile-form (car (cdr (car varlist)))) + (setcar varlist (car (car varlist)))) + (byte-compile-variable-ref 'byte-varbind (car varlist)) + (setq varlist (cdr varlist))) + (byte-compile-body-do-effect (cdr (cdr form))) + (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + + +(byte-defop-compiler-1 /= byte-compile-negated) +(byte-defop-compiler-1 atom byte-compile-negated) +(byte-defop-compiler-1 nlistp byte-compile-negated) + +(put '/= 'byte-compile-negated-op '=) +(put 'atom 'byte-compile-negated-op 'consp) +(put 'nlistp 'byte-compile-negated-op 'listp) + +(defun byte-compile-negated (form) + (byte-compile-form-do-effect (byte-compile-negation-optimizer form))) + +;; Even when optimization is off, /= is optimized to (not (= ...)). +(defun byte-compile-negation-optimizer (form) + ;; an optimizer for forms where <form1> is less efficient than (not <form2>) + (list 'not + (cons (or (get (car form) 'byte-compile-negated-op) + (error + "compiler error: %s has no byte-compile-negated-op property" + (car form))) + (cdr form)))) + +;;; other tricky macro-like special-forms + +(byte-defop-compiler-1 catch) +(byte-defop-compiler-1 unwind-protect) +(byte-defop-compiler-1 condition-case) +(byte-defop-compiler-1 save-excursion) +(byte-defop-compiler-1 save-restriction) +(byte-defop-compiler-1 save-window-excursion) +(byte-defop-compiler-1 with-output-to-temp-buffer) + +(defun byte-compile-catch (form) + (byte-compile-form (car (cdr form))) + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) + (byte-compile-out 'byte-catch 0)) + +(defun byte-compile-unwind-protect (form) + (byte-compile-push-constant + (byte-compile-top-level-body (cdr (cdr form)) t)) + (byte-compile-out 'byte-unwind-protect 0) + (byte-compile-form-do-effect (car (cdr form))) + (byte-compile-out 'byte-unbind 1)) + +(defun byte-compile-condition-case (form) + (let* ((var (nth 1 form)) + (byte-compile-bound-variables + (if var (cons var byte-compile-bound-variables) + byte-compile-bound-variables))) + (or (symbolp var) + (byte-compile-warn + "%s is not a variable-name or nil (in condition-case)" var)) + (byte-compile-push-constant var) + (byte-compile-push-constant (byte-compile-top-level + (nth 2 form) for-effect)) + (let ((clauses (cdr (cdr (cdr form)))) + compiled-clauses) + (while clauses + (let ((clause (car clauses))) + (setq compiled-clauses + (cons (cons (car clause) + (byte-compile-top-level-body + (cdr clause) for-effect)) + compiled-clauses))) + (setq clauses (cdr clauses))) + (byte-compile-push-constant (nreverse compiled-clauses))) + (byte-compile-out 'byte-condition-case 0))) + + +(defun byte-compile-save-excursion (form) + (byte-compile-out 'byte-save-excursion 0) + (byte-compile-body-do-effect (cdr form)) + (byte-compile-out 'byte-unbind 1)) + +(defun byte-compile-save-restriction (form) + (byte-compile-out 'byte-save-restriction 0) + (byte-compile-body-do-effect (cdr form)) + (byte-compile-out 'byte-unbind 1)) + +(defun byte-compile-save-window-excursion (form) + (byte-compile-push-constant + (byte-compile-top-level-body (cdr form) for-effect)) + (byte-compile-out 'byte-save-window-excursion 0)) + +(defun byte-compile-with-output-to-temp-buffer (form) + (byte-compile-form (car (cdr form))) + (byte-compile-out 'byte-temp-output-buffer-setup 0) + (byte-compile-body (cdr (cdr form))) + (byte-compile-out 'byte-temp-output-buffer-show 0)) + + +;;; top-level forms elsewhere + +(byte-defop-compiler-1 defun) +(byte-defop-compiler-1 defmacro) +(byte-defop-compiler-1 defvar) +(byte-defop-compiler-1 defconst byte-compile-defvar) +(byte-defop-compiler-1 autoload) +(byte-defop-compiler-1 lambda byte-compile-lambda-form) + +(defun byte-compile-defun (form) + ;; This is not used for file-level defuns with doc strings. + (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning. + (list 'fset (list 'quote (nth 1 form)) + (byte-compile-byte-code-maker + (byte-compile-lambda (cons 'lambda (cdr (cdr form))))))) + (byte-compile-discard) + (byte-compile-constant (nth 1 form))) + +(defun byte-compile-defmacro (form) + ;; This is not used for file-level defmacros with doc strings. + (byte-compile-body-do-effect + (list (list 'fset (list 'quote (nth 1 form)) + (let ((code (byte-compile-byte-code-maker + (byte-compile-lambda + (cons 'lambda (cdr (cdr form))))))) + (if (eq (car-safe code) 'make-byte-code) + (list 'cons ''macro code) + (list 'quote (cons 'macro (eval code)))))) + (list 'quote (nth 1 form))))) + +(defun byte-compile-defvar (form) + ;; This is not used for file-level defvar/consts with doc strings. + (let ((var (nth 1 form)) + (value (nth 2 form)) + (string (nth 3 form))) + (if (memq 'free-vars byte-compile-warnings) + (setq byte-compile-bound-variables + (cons var byte-compile-bound-variables))) + (byte-compile-body-do-effect + (list (if (cdr (cdr form)) + (if (eq (car form) 'defconst) + (list 'setq var value) + (list 'or (list 'boundp (list 'quote var)) + (list 'setq var value)))) + (if string + (list 'put (list 'quote var) ''variable-documentation string)) + (list 'quote var))))) + +(defun byte-compile-autoload (form) + (and (byte-compile-constp (nth 1 form)) + (byte-compile-constp (nth 5 form)) + (eval (nth 5 form)) ; macro-p + (not (fboundp (eval (nth 1 form)))) + (byte-compile-warn + "The compiler ignores `autoload' except at top level. You should + probably put the autoload of the macro `%s' at top-level." + (eval (nth 1 form)))) + (byte-compile-normal-call form)) + +;; Lambda's in valid places are handled as special cases by various code. +;; The ones that remain are errors. +(defun byte-compile-lambda-form (form) + (error "`lambda' used as function name is invalid")) + + +;;; tags + +;; Note: Most operations will strip off the 'TAG, but it speeds up +;; optimization to have the 'TAG as a part of the tag. +;; Tags will be (TAG . (tag-number . stack-depth)). +(defun byte-compile-make-tag () + (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number)))) + + +(defun byte-compile-out-tag (tag) + (setq byte-compile-output (cons tag byte-compile-output)) + (if (cdr (cdr tag)) + (progn + ;; ## remove this someday + (and byte-compile-depth + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "bytecomp bug: depth conflict at tag %d" (car (cdr tag)))) + (setq byte-compile-depth (cdr (cdr tag)))) + (setcdr (cdr tag) byte-compile-depth))) + +(defun byte-compile-goto (opcode tag) + (setq byte-compile-output (cons (cons opcode tag) byte-compile-output)) + (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) + (1- byte-compile-depth) + byte-compile-depth)) + (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) + (1- byte-compile-depth)))) + +(defun byte-compile-out (opcode offset) + (setq byte-compile-output (cons (cons opcode offset) byte-compile-output)) + (cond ((eq opcode 'byte-call) + (setq byte-compile-depth (- byte-compile-depth offset))) + ((eq opcode 'byte-return) + ;; This is actually an unnecessary case, because there should be + ;; no more opcodes behind byte-return. + (setq byte-compile-depth nil)) + (t + (setq byte-compile-depth (+ byte-compile-depth + (or (aref byte-stack+-info + (symbol-value opcode)) + (- (1- offset)))) + byte-compile-maxdepth (max byte-compile-depth + byte-compile-maxdepth)))) + ;;(if (< byte-compile-depth 0) (error "compiler error: stack underflow")) + ) + + +;;; call tree stuff + +(defun byte-compile-annotate-call-tree (form) + (let (entry) + ;; annotate the current call + (if (setq entry (assq (car form) byte-compile-call-tree)) + (or (memq byte-compile-current-form (nth 1 entry)) ;callers + (setcar (cdr entry) + (cons byte-compile-current-form (nth 1 entry)))) + (setq byte-compile-call-tree + (cons (list (car form) (list byte-compile-current-form) nil) + byte-compile-call-tree))) + ;; annotate the current function + (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) + (or (memq (car form) (nth 2 entry)) ;called + (setcar (cdr (cdr entry)) + (cons (car form) (nth 2 entry)))) + (setq byte-compile-call-tree + (cons (list byte-compile-current-form nil (list (car form))) + byte-compile-call-tree))) + )) + +(defun byte-compile-report-call-tree (&optional filename) + "Display a buffer describing which functions have been called, what functions +called them, and what functions they call. This buffer will list all functions +whose definitions have been compiled since this emacs session was started, as +well as all functions called by those functions. + +The call tree only lists functions called, not macros or inline functions +expanded. Those functions which the byte-code interpreter knows about directly +\(eq, cons, etc.\) are not reported. + +The call tree also lists those functions which are not known to be called +\(that is, to which no calls have been compiled.\) Functions which can be +invoked interactively are excluded from this list." + (interactive) + (message "Generating call tree...") + (with-output-to-temp-buffer "*Call-Tree*" + (set-buffer "*Call-Tree*") + (erase-buffer) + (message "Generating call tree (sorting on %s)..." + byte-compile-call-tree-sort) + (insert "Call tree for " + (cond ((null byte-compile-current-file) (or filename "???")) + ((stringp byte-compile-current-file) + byte-compile-current-file) + (t (buffer-name byte-compile-current-file))) + " sorted on " + (prin1-to-string byte-compile-call-tree-sort) + ":\n\n") + (if byte-compile-call-tree-sort + (setq byte-compile-call-tree + (sort byte-compile-call-tree + (cond ((eq byte-compile-call-tree-sort 'callers) + (function (lambda (x y) (< (length (nth 1 x)) + (length (nth 1 y)))))) + ((eq byte-compile-call-tree-sort 'calls) + (function (lambda (x y) (< (length (nth 2 x)) + (length (nth 2 y)))))) + ((eq byte-compile-call-tree-sort 'calls+callers) + (function (lambda (x y) (< (+ (length (nth 1 x)) + (length (nth 2 x))) + (+ (length (nth 1 y)) + (length (nth 2 y))))))) + ((eq byte-compile-call-tree-sort 'name) + (function (lambda (x y) (string< (car x) + (car y))))) + (t (error "byte-compile-call-tree-sort: %s - unknown sort mode" + byte-compile-call-tree-sort)))))) + (message "Generating call tree...") + (let ((rest byte-compile-call-tree) + (b (current-buffer)) + f p + callers calls) + (while rest + (prin1 (car (car rest)) b) + (setq callers (nth 1 (car rest)) + calls (nth 2 (car rest))) + (insert "\t" + (cond ((not (fboundp (setq f (car (car rest))))) + (if (null f) + " <top level>";; shouldn't insert nil then, actually -sk + " <not defined>")) + ((subrp (setq f (symbol-function f))) + " <subr>") + ((symbolp f) + (format " ==> %s" f)) + ((compiled-function-p f) + "<compiled function>") + ((not (consp f)) + "<malformed function>") + ((eq 'macro (car f)) + (if (or (compiled-function-p (cdr f)) + (assq 'byte-code (cdr (cdr (cdr f))))) + " <compiled macro>" + " <macro>")) + ((assq 'byte-code (cdr (cdr f))) + "<compiled lambda>") + ((eq 'lambda (car f)) + "<function>") + (t "???")) + (format " (%d callers + %d calls = %d)" + ;; Does the optimizer eliminate common subexpressions?-sk + (length callers) + (length calls) + (+ (length callers) (length calls))) + "\n") + (if callers + (progn + (insert " called by:\n") + (setq p (point)) + (insert " " (if (car callers) + (mapconcat 'symbol-name callers ", ") + "<top level>")) + (let ((fill-prefix " ")) + (fill-region-as-paragraph p (point))))) + (if calls + (progn + (insert " calls:\n") + (setq p (point)) + (insert " " (mapconcat 'symbol-name calls ", ")) + (let ((fill-prefix " ")) + (fill-region-as-paragraph p (point))))) + (insert "\n") + (setq rest (cdr rest))) + + (message "Generating call tree...(finding uncalled functions...)") + (setq rest byte-compile-call-tree) + (let ((uncalled nil)) + (while rest + (or (nth 1 (car rest)) + (null (setq f (car (car rest)))) + (byte-compile-fdefinition f t) + (commandp (byte-compile-fdefinition f nil)) + (setq uncalled (cons f uncalled))) + (setq rest (cdr rest))) + (if uncalled + (let ((fill-prefix " ")) + (insert "Noninteractive functions not known to be called:\n ") + (setq p (point)) + (insert (mapconcat 'symbol-name (nreverse uncalled) ", ")) + (fill-region-as-paragraph p (point))))) + ) + (message "Generating call tree...done.") + )) + + +;;; by crl@newton.purdue.edu +;;; Only works noninteractively. +(defun batch-byte-compile () + "Runs `byte-compile-file' on the files remaining on the command line. +Must be used only with -batch, and kills emacs on completion. +Each file will be processed even if an error occurred previously. +For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\"" + ;; command-line-args-left is what is left of the command line (from startup.el) + (defvar command-line-args-left) ;Avoid 'free variable' warning + (if (not noninteractive) + (error "batch-byte-compile is to be used only with -batch")) + (let ((error nil)) + (while command-line-args-left + (if (file-directory-p (expand-file-name (car command-line-args-left))) + (let ((files (directory-files (car command-line-args-left))) + source dest) + (while files + (if (and (string-match elisp-source-extention-re (car files)) + (not (auto-save-file-name-p (car files))) + (setq source (expand-file-name (car files) + (car command-line-args-left))) + (setq dest (byte-compile-dest-file source)) + (file-exists-p dest) + (file-newer-than-file-p source dest)) + (if (null (batch-byte-compile-file source)) + (setq error t))) + (setq files (cdr files)))) + (if (null (batch-byte-compile-file (car command-line-args-left))) + (setq error t))) + (setq command-line-args-left (cdr command-line-args-left))) + (message "Done") + (kill-emacs (if error 1 0)))) + +(defun batch-byte-compile-file (file) + (condition-case err + (progn (byte-compile-file file) t) + (error + (message (if (cdr err) + ">>Error occurred processing %s: %s (%s)" + ">>Error occurred processing %s: %s") + file + (get (car err) 'error-message) + (prin1-to-string (cdr err))) + nil))) + + +(make-obsolete 'mod '%) +(make-obsolete 'dot 'point) +(make-obsolete 'dot-max 'point-max) +(make-obsolete 'dot-min 'point-min) +(make-obsolete 'dot-marker 'point-marker) + +(cond ((not (or (and (boundp 'epoch::version) epoch::version) + (string-lessp emacs-version "19"))) + (make-obsolete 'buffer-flush-undo 'buffer-disable-undo) + (make-obsolete 'baud-rate "use the baud-rate variable instead") + )) + +(provide 'byte-compile) + + +;;; report metering (see the hacks in bytecode.c) + +(if (boundp 'byte-code-meter) + (defun byte-compile-report-ops () + (defvar byte-code-meter) + (with-output-to-temp-buffer "*Meter*" + (set-buffer "*Meter*") + (let ((i 0) n op off) + (while (< i 256) + (setq n (aref (aref byte-code-meter 0) i) + off nil) + (if t ;(not (zerop n)) + (progn + (setq op i) + (setq off nil) + (cond ((< op byte-nth) + (setq off (logand op 7)) + (setq op (logand op 248))) + ((>= op byte-constant) + (setq off (- op byte-constant) + op byte-constant))) + (setq op (aref byte-code-vector op)) + (insert (format "%-4d" i)) + (insert (symbol-name op)) + (if off (insert " [" (int-to-string off) "]")) + (indent-to 40) + (insert (int-to-string n) "\n"))) + (setq i (1+ i))))))) + + +;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles +;; itself, compile some of its most used recursive functions (at load time). +;; +(eval-when-compile + (or (compiled-function-p (symbol-function 'byte-compile-form)) + (assq 'byte-code (symbol-function 'byte-compile-form)) + (let ((byte-optimize nil) ; do it fast + (byte-compile-warnings nil)) + (mapcar '(lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) + '(byte-compile-normal-call + byte-compile-form + byte-compile-body + ;; Inserted some more than necessary, to speed it up. + byte-compile-top-level + byte-compile-out-toplevel + byte-compile-constant + byte-compile-variable-ref)))) + nil)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/emacs-lisp/disass.el Fri Jul 10 22:06:47 1992 +0000 @@ -0,0 +1,224 @@ +;;; Disassembler for compiled Emacs Lisp code +;;; Copyright (C) 1986 Free Software Foundation, Inc. +;;; Original version by Doug Cutting (doug@csli.stanford.edu) +;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for +;;; the new lapcode-based byte compiler. +;;; Last modified 22-oct-91. + +;; 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. + + +;;; The variable byte-code-vector is defined by the new bytecomp.el. +;;; The function byte-decompile-lapcode is defined in byte-optimize.el. +(require 'byte-optimize) + +(defvar disassemble-column-1-indent 5 "*") +(defvar disassemble-column-2-indent 10 "*") + +(defvar disassemble-recursive-indent 3 "*") + +(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)) + (if (eq (car-safe object) 'byte-code) + (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)) + (if (eq (car-safe obj) 'macro) ;handle macros + (setq macro t + obj (cdr obj))) + (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))) + (t + (setq args (aref obj 0)))) + (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)) + (and (> (length obj) 4) (aref obj 4))))) + (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)) + ((compiled-function-p obj) + (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 + (setq bytes (aref obj 1) + constvec (aref obj 2))) + (let ((lap (byte-decompile-bytecode bytes constvec)) + op arg opname) + (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 + (setq op (car (car lap)) + arg (cdr (car lap))) + (indent-to indent) + (if (eq 'TAG op) + (insert (int-to-string (car arg)) ":") + + (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 + byte-listN byte-concatN byte-insertN)) + (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. + (cond ((or (compiled-function-p arg) + (and (eq (car-safe arg) 'lambda) + (assq 'byte-code arg)) + (and (eq (car-safe arg) 'macro) + (or (compiled-function-p (cdr arg)) + (and (eq (car-safe (cdr arg)) 'lambda) + (assq 'byte-code (cdr arg)))))) + (cond ((compiled-function-p arg) + (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") + (mapcar ;recurse on list of byte-code objects + '(lambda (obj) + (disassemble-1 + obj + (+ indent disassemble-recursive-indent))) + arg)) + (t + ;; really just a constant + (let ((print-escape-newlines t)) + (prin1 arg (current-buffer)))))) + ) + (insert "\n")) + (setq lap (cdr lap))))) + nil)