aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJim Blandy1992-07-10 22:06:47 +0000
committerJim Blandy1992-07-10 22:06:47 +0000
commit1c393159a24ae0c5891c7f6367db53459f76d2e0 (patch)
tree9dac588dc566f724c3e5ba5825a6f960e92488a3
parent06b1a5ef11625ecec550c540b4fbbe5730fac312 (diff)
downloademacs-1c393159a24ae0c5891c7f6367db53459f76d2e0.tar.gz
emacs-1c393159a24ae0c5891c7f6367db53459f76d2e0.zip
Initial revision
Diffstat
-rw-r--r--lisp/byte-run.el173
-rw-r--r--lisp/emacs-lisp/byte-opt.el1730
-rw-r--r--lisp/emacs-lisp/bytecomp.el3000
-rw-r--r--lisp/emacs-lisp/disass.el224
4 files changed, 5127 insertions, 0 deletions
diff --git a/lisp/byte-run.el b/lisp/byte-run.el
new file mode 100644
index 00000000000..05063058b1e
--- /dev/null
+++ b/lisp/byte-run.el
@@ -0,0 +1,173 @@
1;;; -*- Mode:Emacs-Lisp -*-
2
3;; Runtime support for the new optimizing byte compiler.
4;; By Jamie Zawinski <jwz@lucid.com>.
5;; Last Modified: 27-jul-91.
6;;
7;; The code in this file should always be loaded, because it defines things
8;; like "defsubst" which should work interpreted as well. The code in
9;; bytecomp.el and byte-optimize.el can be loaded as needed.
10;;
11;; This should be loaded by loadup.el or startup.el. If you can't modify
12;; those files, load this from your .emacs file. But if you are using
13;; emacs18, this file must be loaded before any .elc files which were
14;; generated by the new compiler without emacs18 compatibility turned on.
15;; If this file is loaded, certain emacs19 binaries will run in emacs18.
16;; Meditate on the meanings of byte-compile-generate-emacs19-bytecodes and
17;; byte-compile-emacs18-compatibility.
18
19
20;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
21
22;; This file is part of GNU Emacs.
23
24;; GNU Emacs is free software; you can redistribute it and/or modify
25;; it under the terms of the GNU General Public License as published by
26;; the Free Software Foundation; either version 1, or (at your option)
27;; any later version.
28
29;; GNU Emacs is distributed in the hope that it will be useful,
30;; but WITHOUT ANY WARRANTY; without even the implied warranty of
31;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
32;; GNU General Public License for more details.
33
34;; You should have received a copy of the GNU General Public License
35;; along with GNU Emacs; see the file COPYING. If not, write to
36;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
37
38
39;; emacs-18 compatibility.
40
41(if (fboundp 'make-byte-code)
42 nil
43 ;;
44 ;; To avoid compiler bootstrapping problems, this temporary uncompiled
45 ;; make-byte-code is needed to load the compiled one. Ignore the warnings.
46 (fset 'make-byte-code
47 '(lambda (arglist bytestring constants stackdepth doc)
48 (list 'lambda arglist doc
49 (list 'byte-code bytestring constants stackdepth))))
50 ;;
51 ;; Now get a compiled version.
52 (defun make-byte-code (arglist bytestring constants stackdepth
53 &optional doc &rest interactive)
54 "For compatibility with Emacs19 ``.elc'' files."
55 (nconc (list 'lambda arglist)
56 ;; #### Removed the (stringp doc) for speed. Because the V19
57 ;; make-byte-code depends on the args being correct, it won't
58 ;; help to make a smarter version for V18 alone.
59 ;; Btw, it should have been (or (stringp doc) (natnump doc)).
60 (if doc (list doc))
61 (if interactive
62 (list (cons 'interactive (if (car interactive) interactive))))
63 (list (list 'byte-code bytestring constants stackdepth)))))
64
65
66;;; interface to selectively inlining functions.
67;;; This only happens when source-code optimization is turned on.
68
69;; Redefined in byte-optimize.el.
70(fset 'inline 'progn)
71(put 'inline 'lisp-indent-hook 0)
72
73
74;;; Interface to inline functions.
75
76(defmacro proclaim-inline (&rest fns)
77 "Cause the named functions to be open-coded when called from compiled code.
78They will only be compiled open-coded when byte-compile-optimize is true."
79 (cons 'eval-and-compile
80 (mapcar '(lambda (x)
81 (or (memq (get x 'byte-optimizer)
82 '(nil byte-compile-inline-expand))
83 (error
84 "%s already has a byte-optimizer, can't make it inline"
85 x))
86 (list 'put (list 'quote x)
87 ''byte-optimizer ''byte-compile-inline-expand))
88 fns)))
89
90
91(defmacro proclaim-notinline (&rest fns)
92 "Cause the named functions to no longer be open-coded."
93 (cons 'eval-and-compile
94 (mapcar '(lambda (x)
95 (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand)
96 (put x 'byte-optimizer nil))
97 (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer)
98 ''byte-compile-inline-expand)
99 (list 'put x ''byte-optimizer nil)))
100 fns)))
101
102;; This has a special byte-hunk-handler in bytecomp.el.
103(defmacro defsubst (name arglist &rest body)
104 "Same syntax as defun, but the defined function will always be open-coded,
105so long as byte-compile-optimize is true."
106 (list 'prog1
107 (cons 'defun (cons name (cons arglist body)))
108 (list 'proclaim-inline name)))
109
110(defun make-obsolete (fn new)
111 "Make the byte-compiler warn that FUNCTION is obsolete and NEW should be
112used instead. If NEW is a string, that is the `use instead' message."
113 (interactive "aMake function obsolete: \nxObsoletion replacement: ")
114 (let ((handler (get fn 'byte-compile)))
115 (if (eq 'byte-compile-obsolete handler)
116 (setcar (get fn 'byte-obsolete-info) new)
117 (put fn 'byte-obsolete-info (cons new handler))
118 (put fn 'byte-compile 'byte-compile-obsolete)))
119 fn)
120
121(put 'dont-compile 'lisp-indent-hook 0)
122(defmacro dont-compile (&rest body)
123 "Like progn, but the body will always run interpreted (not compiled)."
124 (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
125
126
127;;; interface to evaluating things at compile time and/or load time
128;;; these macro must come after any uses of them in this file, as their
129;;; definition in the file overrides the magic definitions on the
130;;; byte-compile-macro-environment.
131
132(put 'eval-when-compile 'lisp-indent-hook 0)
133(defmacro eval-when-compile (&rest body)
134 "Like progn, but evaluates the body at compile-time. The result of the
135body appears to the compiler as a quoted constant."
136 ;; Not necessary because we have it in b-c-initial-macro-environment
137 ;; (list 'quote (eval (cons 'progn body)))
138 (cons 'progn body))
139
140(put 'eval-and-compile 'lisp-indent-hook 0)
141(defmacro eval-and-compile (&rest body)
142 "Like progn, but evaluates the body at compile-time as well as at load-time."
143 ;; Remember, it's magic.
144 (cons 'progn body))
145
146
147;;; Interface to file-local byte-compiler parameters.
148;;; Redefined in bytecomp.el.
149
150(put 'byte-compiler-options 'lisp-indent-hook 0)
151(defmacro byte-compiler-options (&rest args)
152 "Set some compilation-parameters for this file. This will affect only the
153file in which it appears; this does nothing when evaluated, and when loaded
154from a .el file.
155
156Each argument to this macro must be a list of a key and a value.
157
158 Keys: Values: Corresponding variable:
159
160 verbose t, nil byte-compile-verbose
161 optimize t, nil, source, byte byte-compile-optimize
162 warnings list of warnings byte-compile-warnings
163 Legal elements: (callargs redefine free-vars unresolved)
164 file-format emacs18, emacs19 byte-compile-emacs18-compatibility
165 new-bytecodes t, nil byte-compile-generate-emacs19-bytecodes
166
167For example, this might appear at the top of a source file:
168
169 (byte-compiler-options
170 (optimize t)
171 (warnings (- free-vars)) ; Don't warn about free variables
172 (file-format emacs19))"
173 nil)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
new file mode 100644
index 00000000000..b595d6699d9
--- /dev/null
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -0,0 +1,1730 @@
1;;; -*- Mode:Emacs-Lisp -*-
2;;; The optimization passes of the emacs-lisp byte compiler.
3
4;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>.
5;; last modified 29-oct-91.
6
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 1, or (at your option)
12;; any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING. If not, write to
21;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23;;; ========================================================================
24;;; "No matter how hard you try, you can't make a racehorse out of a pig.
25;;; you can, however, make a faster pig."
26;;;
27;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code
28;;; makes it be a VW Bug with fuel injection and a turbocharger... You're
29;;; still not going to make it go faster than 70 mph, but it might be easier
30;;; to get it there.
31;;;
32
33;;; TO DO:
34;;;
35;;; (apply '(lambda (x &rest y) ...) 1 (foo))
36;;;
37;;; collapse common subexpressions
38;;;
39;;; maintain a list of functions known not to access any global variables
40;;; (actually, give them a 'dynamically-safe property) and then
41;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==>
42;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> )
43;;; by recursing on this, we might be able to eliminate the entire let.
44;;; However certain variables should never have their bindings optimized
45;;; away, because they affect everything.
46;;; (put 'debug-on-error 'binding-is-magic t)
47;;; (put 'debug-on-abort 'binding-is-magic t)
48;;; (put 'inhibit-quit 'binding-is-magic t)
49;;; (put 'quit-flag 'binding-is-magic t)
50;;; others?
51;;;
52;;; Simple defsubsts often produce forms like
53;;; (let ((v1 (f1)) (v2 (f2)) ...)
54;;; (FN v1 v2 ...))
55;;; It would be nice if we could optimize this to
56;;; (FN (f1) (f2) ...)
57;;; but we can't unless FN is dynamically-safe (it might be dynamically
58;;; referring to the bindings that the lambda arglist established.)
59;;; One of the uncountable lossages introduced by dynamic scope...
60;;;
61;;; Maybe there should be a control-structure that says "turn on
62;;; fast-and-loose type-assumptive optimizations here." Then when
63;;; we see a form like (car foo) we can from then on assume that
64;;; the variable foo is of type cons, and optimize based on that.
65;;; But, this won't win much because of (you guessed it) dynamic
66;;; scope. Anything down the stack could change the value.
67;;;
68;;; It would be nice if redundant sequences could be factored out as well,
69;;; when they are known to have no side-effects:
70;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2
71;;; but beware of traps like
72;;; (cons (list x y) (list x y))
73;;;
74;;; Tail-recursion elimination is not really possible in elisp. Tail-recursion
75;;; elimination is almost always impossible when all variables have dynamic
76;;; scope, but given that the "return" byteop requires the binding stack to be
77;;; empty (rather than emptying it itself), there can be no truly tail-
78;;; recursive elisp functions that take any arguments or make any bindings.
79;;;
80;;; Here is an example of an elisp function which could safely be
81;;; byte-compiled tail-recursively:
82;;;
83;;; (defun tail-map (fn list)
84;;; (cond (list
85;;; (funcall fn (car list))
86;;; (tail-map fn (cdr list)))))
87;;;
88;;; However, if there was even a single let-binding around the COND,
89;;; it could not be byte-compiled, because there would be an "unbind"
90;;; byte-op between the final "call" and "return." Adding a
91;;; Bunbind_all byteop would fix this.
92;;;
93;;; (defun foo (x y z) ... (foo a b c))
94;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return)
95;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return)
96;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return)
97;;;
98;;; this also can be considered tail recursion:
99;;;
100;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return)
101;;; could generalize this by doing the optimization
102;;; (goto X) ... X: (return) --> (return)
103;;;
104;;; But this doesn't solve all of the problems: although by doing tail-
105;;; recursion elimination in this way, the call-stack does not grow, the
106;;; binding-stack would grow with each recursive step, and would eventually
107;;; overflow. I don't believe there is any way around this without lexical
108;;; scope.
109;;;
110;;; Wouldn't it be nice if elisp had lexical scope.
111;;;
112;;; Idea: the form (lexical-scope) in a file means that the file may be
113;;; compiled lexically. This proclamation is file-local. Then, within
114;;; that file, "let" would establish lexical bindings, and "let-dynamic"
115;;; would do things the old way. (Or we could use CL "declare" forms.)
116;;; We'd have to notice defvars and defconsts, since those variables should
117;;; always be dynamic, and attempting to do a lexical binding of them
118;;; should simply do a dynamic binding instead.
119;;; But! We need to know about variables that were not necessarily defvarred
120;;; in the file being compiled (doing a boundp check isn't good enough.)
121;;; Fdefvar() would have to be modified to add something to the plist.
122;;;
123;;; A major disadvantage of this scheme is that the interpreter and compiler
124;;; would have different semantics for files compiled with (dynamic-scope).
125;;; Since this would be a file-local optimization, there would be no way to
126;;; modify the interpreter to obey this (unless the loader was hacked
127;;; in some grody way, but that's a really bad idea.)
128;;;
129;;; Really the Right Thing is to make lexical scope the default across
130;;; the board, in the interpreter and compiler, and just FIX all of
131;;; the code that relies on dynamic scope of non-defvarred variables.
132
133
134(require 'byte-compile "bytecomp")
135
136(or (fboundp 'byte-compile-lapcode)
137 (error "loading bytecomp got the wrong version of the compiler."))
138
139(defun byte-compile-log-lap-1 (format &rest args)
140 (if (aref byte-code-vector 0)
141 (error "The old version of the disassembler is loaded. Reload new-bytecomp as well."))
142 (byte-compile-log-1
143 (apply 'format format
144 (let (c a)
145 (mapcar '(lambda (arg)
146 (if (not (consp arg))
147 (if (and (symbolp arg)
148 (string-match "^byte-" (symbol-name arg)))
149 (intern (substring (symbol-name arg) 5))
150 arg)
151 (if (integerp (setq c (car arg)))
152 (error "non-symbolic byte-op %s" c))
153 (if (eq c 'TAG)
154 (setq c arg)
155 (setq a (cond ((memq c byte-goto-ops)
156 (car (cdr (cdr arg))))
157 ((memq c byte-constref-ops)
158 (car (cdr arg)))
159 (t (cdr arg))))
160 (setq c (symbol-name c))
161 (if (string-match "^byte-." c)
162 (setq c (intern (substring c 5)))))
163 (if (eq c 'constant) (setq c 'const))
164 (if (and (eq (cdr arg) 0)
165 (not (memq c '(unbind call const))))
166 c
167 (format "(%s %s)" c a))))
168 args)))))
169
170(defmacro byte-compile-log-lap (format-string &rest args)
171 (list 'and
172 '(memq byte-optimize-log '(t byte))
173 (cons 'byte-compile-log-lap-1
174 (cons format-string args))))
175
176
177;;; byte-compile optimizers to support inlining
178
179(put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
180
181(defun byte-optimize-inline-handler (form)
182 "byte-optimize-handler for the `inline' special-form."
183 (cons 'progn
184 (mapcar
185 '(lambda (sexp)
186 (let ((fn (car-safe sexp)))
187 (if (and (symbolp fn)
188 (or (cdr (assq fn byte-compile-function-environment))
189 (and (fboundp fn)
190 (not (or (cdr (assq fn byte-compile-macro-environment))
191 (and (consp (setq fn (symbol-function fn)))
192 (eq (car fn) 'macro))
193 (subrp fn))))))
194 (byte-compile-inline-expand sexp)
195 sexp)))
196 (cdr form))))
197
198
199(defun byte-inline-lapcode (lap)
200 "splice the given lap code into the current instruction stream.
201If it has any labels in it, you're responsible for making sure there
202are no collisions, and that byte-compile-tag-number is reasonable
203after this is spliced in. the provided list is destroyed."
204 (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
205
206
207(defun byte-compile-inline-expand (form)
208 (let* ((name (car form))
209 (fn (or (cdr (assq name byte-compile-function-environment))
210 (and (fboundp name) (symbol-function name)))))
211 (if (null fn)
212 (progn
213 (byte-compile-warn "attempt to inline %s before it was defined" name)
214 form)
215 ;; else
216 (if (and (consp fn) (eq (car fn) 'autoload))
217 (load (nth 1 fn)))
218 (if (and (consp fn) (eq (car fn) 'autoload))
219 (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
220 (if (symbolp fn)
221 (byte-compile-inline-expand (cons fn (cdr form)))
222 (if (compiled-function-p fn)
223 (cons (list 'lambda (aref fn 0)
224 (list 'byte-code (aref fn 1) (aref fn 2) (aref fn 3)))
225 (cdr form))
226 (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
227 (cons fn (cdr form)))))))
228
229;;; ((lambda ...) ...)
230;;;
231(defun byte-compile-unfold-lambda (form &optional name)
232 (or name (setq name "anonymous lambda"))
233 (let ((lambda (car form))
234 (values (cdr form)))
235 (if (compiled-function-p lambda)
236 (setq lambda (list 'lambda (nth 0 form)
237 (list 'byte-code
238 (nth 1 form) (nth 2 form) (nth 3 form)))))
239 (let ((arglist (nth 1 lambda))
240 (body (cdr (cdr lambda)))
241 optionalp restp
242 bindings)
243 (if (and (stringp (car body)) (cdr body))
244 (setq body (cdr body)))
245 (if (and (consp (car body)) (eq 'interactive (car (car body))))
246 (setq body (cdr body)))
247 (while arglist
248 (cond ((eq (car arglist) '&optional)
249 ;; ok, I'll let this slide because funcall_lambda() does...
250 ;; (if optionalp (error "multiple &optional keywords in %s" name))
251 (if restp (error "&optional found after &rest in %s" name))
252 (if (null (cdr arglist))
253 (error "nothing after &optional in %s" name))
254 (setq optionalp t))
255 ((eq (car arglist) '&rest)
256 ;; ...but it is by no stretch of the imagination a reasonable
257 ;; thing that funcall_lambda() allows (&rest x y) and
258 ;; (&rest x &optional y) in arglists.
259 (if (null (cdr arglist))
260 (error "nothing after &rest in %s" name))
261 (if (cdr (cdr arglist))
262 (error "multiple vars after &rest in %s" name))
263 (setq restp t))
264 (restp
265 (setq bindings (cons (list (car arglist)
266 (and values (cons 'list values)))
267 bindings)
268 values nil))
269 ((and (not optionalp) (null values))
270 (byte-compile-warn "attempt to open-code %s with too few arguments" name)
271 (setq arglist nil values 'too-few))
272 (t
273 (setq bindings (cons (list (car arglist) (car values))
274 bindings)
275 values (cdr values))))
276 (setq arglist (cdr arglist)))
277 (if values
278 (progn
279 (or (eq values 'too-few)
280 (byte-compile-warn
281 "attempt to open-code %s with too many arguments" name))
282 form)
283 (let ((newform
284 (if bindings
285 (cons 'let (cons (nreverse bindings) body))
286 (cons 'progn body))))
287 (byte-compile-log " %s\t==>\t%s" form newform)
288 newform)))))
289
290
291;;; implementing source-level optimizers
292
293(defun byte-optimize-form-code-walker (form for-effect)
294 ;;
295 ;; For normal function calls, We can just mapcar the optimizer the cdr. But
296 ;; we need to have special knowledge of the syntax of the special forms
297 ;; like let and defun (that's why they're special forms :-). (Actually,
298 ;; the important aspect is that they are subrs that don't evaluate all of
299 ;; their args.)
300 ;;
301 (let ((fn (car-safe form))
302 tmp)
303 (cond ((not (consp form))
304 (if (not (and for-effect
305 (or byte-compile-delete-errors
306 (not (symbolp form))
307 (eq form t))))
308 form))
309 ((eq fn 'quote)
310 (if (cdr (cdr form))
311 (byte-compile-warn "malformed quote form: %s"
312 (prin1-to-string form)))
313 ;; map (quote nil) to nil to simplify optimizer logic.
314 ;; map quoted constants to nil if for-effect (just because).
315 (and (nth 1 form)
316 (not for-effect)
317 form))
318 ((or (compiled-function-p fn)
319 (eq 'lambda (car-safe fn)))
320 (byte-compile-unfold-lambda form))
321 ((memq fn '(let let*))
322 ;; recursively enter the optimizer for the bindings and body
323 ;; of a let or let*. This for depth-firstness: forms that
324 ;; are more deeply nested are optimized first.
325 (cons fn
326 (cons
327 (mapcar '(lambda (binding)
328 (if (symbolp binding)
329 binding
330 (if (cdr (cdr binding))
331 (byte-compile-warn "malformed let binding: %s"
332 (prin1-to-string binding)))
333 (list (car binding)
334 (byte-optimize-form (nth 1 binding) nil))))
335 (nth 1 form))
336 (byte-optimize-body (cdr (cdr form)) for-effect))))
337 ((eq fn 'cond)
338 (cons fn
339 (mapcar '(lambda (clause)
340 (if (consp clause)
341 (cons
342 (byte-optimize-form (car clause) nil)
343 (byte-optimize-body (cdr clause) for-effect))
344 (byte-compile-warn "malformed cond form: %s"
345 (prin1-to-string clause))
346 clause))
347 (cdr form))))
348 ((eq fn 'progn)
349 ;; as an extra added bonus, this simplifies (progn <x>) --> <x>
350 (if (cdr (cdr form))
351 (progn
352 (setq tmp (byte-optimize-body (cdr form) for-effect))
353 (if (cdr tmp) (cons 'progn tmp) (car tmp)))
354 (byte-optimize-form (nth 1 form) for-effect)))
355 ((eq fn 'prog1)
356 (if (cdr (cdr form))
357 (cons 'prog1
358 (cons (byte-optimize-form (nth 1 form) for-effect)
359 (byte-optimize-body (cdr (cdr form)) t)))
360 (byte-optimize-form (nth 1 form) for-effect)))
361 ((eq fn 'prog2)
362 (cons 'prog2
363 (cons (byte-optimize-form (nth 1 form) t)
364 (cons (byte-optimize-form (nth 2 form) for-effect)
365 (byte-optimize-body (cdr (cdr (cdr form))) t)))))
366
367 ((memq fn '(save-excursion save-restriction))
368 ;; those subrs which have an implicit progn; it's not quite good
369 ;; enough to treat these like normal function calls.
370 ;; This can turn (save-excursion ...) into (save-excursion) which
371 ;; will be optimized away in the lap-optimize pass.
372 (cons fn (byte-optimize-body (cdr form) for-effect)))
373
374 ((eq fn 'with-output-to-temp-buffer)
375 ;; this is just like the above, except for the first argument.
376 (cons fn
377 (cons
378 (byte-optimize-form (nth 1 form) nil)
379 (byte-optimize-body (cdr (cdr form)) for-effect))))
380
381 ((eq fn 'if)
382 (cons fn
383 (cons (byte-optimize-form (nth 1 form) nil)
384 (cons
385 (byte-optimize-form (nth 2 form) for-effect)
386 (byte-optimize-body (nthcdr 3 form) for-effect)))))
387
388 ((memq fn '(and or)) ; remember, and/or are control structures.
389 ;; take forms off the back until we can't any more.
390 ;; In the future it could concievably be a problem that the
391 ;; subexpressions of these forms are optimized in the reverse
392 ;; order, but it's ok for now.
393 (if for-effect
394 (let ((backwards (reverse (cdr form))))
395 (while (and backwards
396 (null (setcar backwards
397 (byte-optimize-form (car backwards)
398 for-effect))))
399 (setq backwards (cdr backwards)))
400 (if (and (cdr form) (null backwards))
401 (byte-compile-log
402 " all subforms of %s called for effect; deleted" form))
403 (and backwards
404 (cons fn (nreverse backwards))))
405 (cons fn (mapcar 'byte-optimize-form (cdr form)))))
406
407 ((eq fn 'interactive)
408 (byte-compile-warn "misplaced interactive spec: %s"
409 (prin1-to-string form))
410 nil)
411
412 ((memq fn '(defun defmacro function
413 condition-case save-window-excursion))
414 ;; These forms are compiled as constants or by breaking out
415 ;; all the subexpressions and compiling them separately.
416 form)
417
418 ((eq fn 'unwind-protect)
419 ;; the "protected" part of an unwind-protect is compiled (and thus
420 ;; optimized) as a top-level form, so don't do it here. But the
421 ;; non-protected part has the same for-effect status as the
422 ;; unwind-protect itself. (The protected part is always for effect,
423 ;; but that isn't handled properly yet.)
424 (cons fn
425 (cons (byte-optimize-form (nth 1 form) for-effect)
426 (cdr (cdr form)))))
427
428 ((eq fn 'catch)
429 ;; the body of a catch is compiled (and thus optimized) as a
430 ;; top-level form, so don't do it here. The tag is never
431 ;; for-effect. The body should have the same for-effect status
432 ;; as the catch form itself, but that isn't handled properly yet.
433 (cons fn
434 (cons (byte-optimize-form (nth 1 form) nil)
435 (cdr (cdr form)))))
436
437 ;; If optimization is on, this is the only place that macros are
438 ;; expanded. If optimization is off, then macroexpansion happens
439 ;; in byte-compile-form. Otherwise, the macros are already expanded
440 ;; by the time that is reached.
441 ((not (eq form
442 (setq form (macroexpand form
443 byte-compile-macro-environment))))
444 (byte-optimize-form form for-effect))
445
446 ((not (symbolp fn))
447 (or (eq 'mocklisp (car-safe fn)) ; ha!
448 (byte-compile-warn "%s is a malformed function"
449 (prin1-to-string fn)))
450 form)
451
452 ((and for-effect (setq tmp (get fn 'side-effect-free))
453 (or byte-compile-delete-errors
454 (eq tmp 'error-free)
455 (progn
456 (byte-compile-warn "%s called for effect"
457 (prin1-to-string form))
458 nil)))
459 (byte-compile-log " %s called for effect; deleted" fn)
460 ;; appending a nil here might not be necessary, but it can't hurt.
461 (byte-optimize-form
462 (cons 'progn (append (cdr form) '(nil))) t))
463
464 (t
465 ;; Otherwise, no args can be considered to be for-effect,
466 ;; even if the called function is for-effect, because we
467 ;; don't know anything about that function.
468 (cons fn (mapcar 'byte-optimize-form (cdr form)))))))
469
470
471(defun byte-optimize-form (form &optional for-effect)
472 "The source-level pass of the optimizer."
473 ;;
474 ;; First, optimize all sub-forms of this one.
475 (setq form (byte-optimize-form-code-walker form for-effect))
476 ;;
477 ;; after optimizing all subforms, optimize this form until it doesn't
478 ;; optimize any further. This means that some forms will be passed through
479 ;; the optimizer many times, but that's necessary to make the for-effect
480 ;; processing do as much as possible.
481 ;;
482 (let (opt new)
483 (if (and (consp form)
484 (symbolp (car form))
485 (or (and for-effect
486 ;; we don't have any of these yet, but we might.
487 (setq opt (get (car form) 'byte-for-effect-optimizer)))
488 (setq opt (get (car form) 'byte-optimizer)))
489 (not (eq form (setq new (funcall opt form)))))
490 (progn
491;; (if (equal form new) (error "bogus optimizer -- %s" opt))
492 (byte-compile-log " %s\t==>\t%s" form new)
493 (setq new (byte-optimize-form new for-effect))
494 new)
495 form)))
496
497
498(defun byte-optimize-body (forms all-for-effect)
499 ;; optimize the cdr of a progn or implicit progn; all forms is a list of
500 ;; forms, all but the last of which are optimized with the assumption that
501 ;; they are being called for effect. the last is for-effect as well if
502 ;; all-for-effect is true. returns a new list of forms.
503 (let ((rest forms)
504 (result nil)
505 fe new)
506 (while rest
507 (setq fe (or all-for-effect (cdr rest)))
508 (setq new (and (car rest) (byte-optimize-form (car rest) fe)))
509 (if (or new (not fe))
510 (setq result (cons new result)))
511 (setq rest (cdr rest)))
512 (nreverse result)))
513
514
515;;; some source-level optimizers
516;;;
517;;; when writing optimizers, be VERY careful that the optimizer returns
518;;; something not EQ to its argument if and ONLY if it has made a change.
519;;; This implies that you cannot simply destructively modify the list;
520;;; you must return something not EQ to it if you make an optimization.
521;;;
522;;; It is now safe to optimize code such that it introduces new bindings.
523
524;; I'd like this to be a defsubst, but let's not be self-referental...
525(defmacro byte-compile-trueconstp (form)
526 ;; Returns non-nil if FORM is a non-nil constant.
527 (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
528 ((not (symbolp (, form))))
529 ((eq (, form) t)))))
530
531(defun byte-optimize-associative-math (form)
532 "If the function is being called with constant numeric args,
533evaluate as much as possible at compile-time. This optimizer
534assumes that the function is associative, like + or *."
535 (let ((args nil)
536 (constants nil)
537 (rest (cdr form)))
538 (while rest
539 (if (numberp (car rest))
540 (setq constants (cons (car rest) constants))
541 (setq args (cons (car rest) args)))
542 (setq rest (cdr rest)))
543 (if (cdr constants)
544 (if args
545 (list (car form)
546 (apply (car form) constants)
547 (if (cdr args)
548 (cons (car form) (nreverse args))
549 (car args)))
550 (apply (car form) constants))
551 form)))
552
553(defun byte-optimize-nonassociative-math (form)
554 "If the function is being called with constant numeric args,
555evaluate as much as possible at compile-time. This optimizer
556assumes that the function is nonassociative, like - or /."
557 (if (or (not (numberp (car (cdr form))))
558 (not (numberp (car (cdr (cdr form))))))
559 form
560 (let ((constant (car (cdr form)))
561 (rest (cdr (cdr form))))
562 (while (numberp (car rest))
563 (setq constant (funcall (car form) constant (car rest))
564 rest (cdr rest)))
565 (if rest
566 (cons (car form) (cons constant rest))
567 constant))))
568
569;;(defun byte-optimize-associative-two-args-math (form)
570;; (setq form (byte-optimize-associative-math form))
571;; (if (consp form)
572;; (byte-optimize-two-args-left form)
573;; form))
574
575;;(defun byte-optimize-nonassociative-two-args-math (form)
576;; (setq form (byte-optimize-nonassociative-math form))
577;; (if (consp form)
578;; (byte-optimize-two-args-right form)
579;; form))
580
581(defun byte-optimize-delay-constants-math (form start fun)
582 ;; Merge all FORM's constants from number START, call FUN on them
583 ;; and put the result at the end.
584 (let ((rest (nthcdr (1- start) form)))
585 (while (cdr (setq rest (cdr rest)))
586 (if (numberp (car rest))
587 (let (constants)
588 (setq form (copy-sequence form)
589 rest (nthcdr (1- start) form))
590 (while (setq rest (cdr rest))
591 (cond ((numberp (car rest))
592 (setq constants (cons (car rest) constants))
593 (setcar rest nil))))
594 (setq form (nconc (delq nil form)
595 (list (apply fun (nreverse constants))))))))
596 form))
597
598(defun byte-optimize-plus (form)
599 (setq form (byte-optimize-delay-constants-math form 1 '+))
600 (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
601 ;;(setq form (byte-optimize-associative-two-args-math form))
602 (cond ((null (cdr form))
603 (condition-case ()
604 (eval form)
605 (error form)))
606 ((null (cdr (cdr form))) (nth 1 form))
607 (t form)))
608
609(defun byte-optimize-minus (form)
610 ;; Put constants at the end, except the last constant.
611 (setq form (byte-optimize-delay-constants-math form 2 '+))
612 ;; Now only first and last element can be a number.
613 (let ((last (car (reverse (nthcdr 3 form)))))
614 (cond ((eq 0 last)
615 ;; (- x y ... 0) --> (- x y ...)
616 (setq form (copy-sequence form))
617 (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
618 ;; If form is (- CONST foo... CONST), merge first and last.
619 ((and (numberp (nth 1 form))
620 (numberp last))
621 (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
622 (delq last (copy-sequence (nthcdr 3 form))))))))
623 (if (eq (nth 2 form) 0)
624 (nth 1 form) ; (- x 0) --> x
625 (byte-optimize-predicate
626 (if (and (null (cdr (cdr (cdr form))))
627 (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
628 (cons (car form) (cdr (cdr form)))
629 form))))
630
631(defun byte-optimize-multiply (form)
632 (setq form (byte-optimize-delay-constants-math form 1 '*))
633 ;; If there is a constant in FORM, it is now the last element.
634 (cond ((null (cdr form)) 1)
635 ((null (cdr (cdr form))) (nth 1 form))
636 ((let ((last (car (reverse form))))
637 (cond ((eq 0 last) (list 'progn (cdr form)))
638 ((eq 1 last) (delq 1 (copy-sequence form)))
639 ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
640 ((and (eq 2 last)
641 (memq t (mapcar 'symbolp (cdr form))))
642 (prog1 (setq form (delq 2 (copy-sequence form)))
643 (while (not (symbolp (car (setq form (cdr form))))))
644 (setcar form (list '+ (car form) (car form)))))
645 (form))))))
646
647(defsubst byte-compile-butlast (form)
648 (nreverse (cdr (reverse form))))
649
650(defun byte-optimize-divide (form)
651 (setq form (byte-optimize-delay-constants-math form 2 '*))
652 (let ((last (car (reverse (cdr (cdr form))))))
653 (if (numberp last)
654 (cond ((= last 1)
655 (setq form (byte-compile-butlast form)))
656 ((numberp (nth 1 form))
657 (setq form (cons (car form)
658 (cons (/ (nth 1 form) last)
659 (byte-compile-butlast (cdr (cdr form)))))
660 last nil))))
661 (cond ((null (cdr (cdr form)))
662 (nth 1 form))
663 ((eq (nth 1 form) 0)
664 (append '(progn) (cdr (cdr form)) '(0)))
665 ((eq last -1)
666 (list '- (if (nthcdr 3 form)
667 (byte-compile-butlast form)
668 (nth 1 form))))
669 (form))))
670
671(defun byte-optimize-logmumble (form)
672 (setq form (byte-optimize-delay-constants-math form 1 (car form)))
673 (byte-optimize-predicate
674 (cond ((memq 0 form)
675 (setq form (if (eq (car form) 'logand)
676 (cons 'progn (cdr form))
677 (delq 0 (copy-sequence form)))))
678 ((and (eq (car-safe form) 'logior)
679 (memq -1 form))
680 (delq -1 (copy-sequence form)))
681 (form))))
682
683
684(defun byte-optimize-binary-predicate (form)
685 (if (byte-compile-constp (nth 1 form))
686 (if (byte-compile-constp (nth 2 form))
687 (condition-case ()
688 (list 'quote (eval form))
689 (error form))
690 ;; This can enable some lapcode optimizations.
691 (list (car form) (nth 2 form) (nth 1 form)))
692 form))
693
694(defun byte-optimize-predicate (form)
695 (let ((ok t)
696 (rest (cdr form)))
697 (while (and rest ok)
698 (setq ok (byte-compile-constp (car rest))
699 rest (cdr rest)))
700 (if ok
701 (condition-case ()
702 (list 'quote (eval form))
703 (error form))
704 form)))
705
706(defun byte-optimize-identity (form)
707 (if (and (cdr form) (null (cdr (cdr form))))
708 (nth 1 form)
709 (byte-compile-warn "identity called with %d arg%s, but requires 1"
710 (length (cdr form))
711 (if (= 1 (length (cdr form))) "" "s"))
712 form))
713
714(put 'identity 'byte-optimizer 'byte-optimize-identity)
715
716(put '+ 'byte-optimizer 'byte-optimize-plus)
717(put '* 'byte-optimizer 'byte-optimize-multiply)
718(put '- 'byte-optimizer 'byte-optimize-minus)
719(put '/ 'byte-optimizer 'byte-optimize-divide)
720(put 'max 'byte-optimizer 'byte-optimize-associative-math)
721(put 'min 'byte-optimizer 'byte-optimize-associative-math)
722
723(put '= 'byte-optimizer 'byte-optimize-binary-predicate)
724(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
725(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate)
726(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate)
727(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
728(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
729
730(put '< 'byte-optimizer 'byte-optimize-predicate)
731(put '> 'byte-optimizer 'byte-optimize-predicate)
732(put '<= 'byte-optimizer 'byte-optimize-predicate)
733(put '>= 'byte-optimizer 'byte-optimize-predicate)
734(put '1+ 'byte-optimizer 'byte-optimize-predicate)
735(put '1- 'byte-optimizer 'byte-optimize-predicate)
736(put 'not 'byte-optimizer 'byte-optimize-predicate)
737(put 'null 'byte-optimizer 'byte-optimize-predicate)
738(put 'memq 'byte-optimizer 'byte-optimize-predicate)
739(put 'consp 'byte-optimizer 'byte-optimize-predicate)
740(put 'listp 'byte-optimizer 'byte-optimize-predicate)
741(put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
742(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
743(put 'string< 'byte-optimizer 'byte-optimize-predicate)
744(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
745
746(put 'logand 'byte-optimizer 'byte-optimize-logmumble)
747(put 'logior 'byte-optimizer 'byte-optimize-logmumble)
748(put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
749(put 'lognot 'byte-optimizer 'byte-optimize-predicate)
750
751(put 'car 'byte-optimizer 'byte-optimize-predicate)
752(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
753(put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
754(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
755
756
757;; I'm not convinced that this is necessary. Doesn't the optimizer loop
758;; take care of this? - Jamie
759;; I think this may some times be necessary to reduce ie (quote 5) to 5,
760;; so arithmetic optimizers recognize the numerinc constant. - Hallvard
761(put 'quote 'byte-optimizer 'byte-optimize-quote)
762(defun byte-optimize-quote (form)
763 (if (or (consp (nth 1 form))
764 (and (symbolp (nth 1 form))
765 (not (memq (nth 1 form) '(nil t)))))
766 form
767 (nth 1 form)))
768
769(defun byte-optimize-zerop (form)
770 (cond ((numberp (nth 1 form))
771 (eval form))
772 (byte-compile-delete-errors
773 (list '= (nth 1 form) 0))
774 (form)))
775
776(put 'zerop 'byte-optimizer 'byte-optimize-zerop)
777
778(defun byte-optimize-and (form)
779 ;; Simplify if less than 2 args.
780 ;; if there is a literal nil in the args to `and', throw it and following
781 ;; forms away, and surround the `and' with (progn ... nil).
782 (cond ((null (cdr form)))
783 ((memq nil form)
784 (list 'progn
785 (byte-optimize-and
786 (prog1 (setq form (copy-sequence form))
787 (while (nth 1 form)
788 (setq form (cdr form)))
789 (setcdr form nil)))
790 nil))
791 ((null (cdr (cdr form)))
792 (nth 1 form))
793 ((byte-optimize-predicate form))))
794
795(defun byte-optimize-or (form)
796 ;; Throw away nil's, and simplify if less than 2 args.
797 ;; If there is a literal non-nil constant in the args to `or', throw away all
798 ;; following forms.
799 (if (memq nil form)
800 (setq form (delq nil (copy-sequence form))))
801 (let ((rest form))
802 (while (cdr (setq rest (cdr rest)))
803 (if (byte-compile-trueconstp (car rest))
804 (setq form (copy-sequence form)
805 rest (setcdr (memq (car rest) form) nil))))
806 (if (cdr (cdr form))
807 (byte-optimize-predicate form)
808 (nth 1 form))))
809
810(defun byte-optimize-cond (form)
811 ;; if any clauses have a literal nil as their test, throw them away.
812 ;; if any clause has a literal non-nil constant as its test, throw
813 ;; away all following clauses.
814 (let (rest)
815 ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
816 (while (setq rest (assq nil (cdr form)))
817 (setq form (delq rest (copy-sequence form))))
818 (if (memq nil (cdr form))
819 (setq form (delq nil (copy-sequence form))))
820 (setq rest form)
821 (while (setq rest (cdr rest))
822 (cond ((byte-compile-trueconstp (car-safe (car rest)))
823 (cond ((eq rest (cdr form))
824 (setq form
825 (if (cdr (car rest))
826 (if (cdr (cdr (car rest)))
827 (cons 'progn (cdr (car rest)))
828 (nth 1 (car rest)))
829 (car (car rest)))))
830 ((cdr rest)
831 (setq form (copy-sequence form))
832 (setcdr (memq (car rest) form) nil)))
833 (setq rest nil)))))
834 ;;
835 ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
836 (if (eq 'cond (car-safe form))
837 (let ((clauses (cdr form)))
838 (if (and (consp (car clauses))
839 (null (cdr (car clauses))))
840 (list 'or (car (car clauses))
841 (byte-optimize-cond
842 (cons (car form) (cdr (cdr form)))))
843 form))
844 form))
845
846(defun byte-optimize-if (form)
847 ;; (if <true-constant> <then> <else...>) ==> <then>
848 ;; (if <false-constant> <then> <else...>) ==> (progn <else...>)
849 ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>))
850 ;; (if <test> <then> nil) ==> (if <test> <then>)
851 (let ((clause (nth 1 form)))
852 (cond ((byte-compile-trueconstp clause)
853 (nth 2 form))
854 ((null clause)
855 (if (nthcdr 4 form)
856 (cons 'progn (nthcdr 3 form))
857 (nth 3 form)))
858 ((nth 2 form)
859 (if (equal '(nil) (nthcdr 3 form))
860 (list 'if clause (nth 2 form))
861 form))
862 ((or (nth 3 form) (nthcdr 4 form))
863 (list 'if (list 'not clause)
864 (if (nthcdr 4 form)
865 (cons 'progn (nthcdr 3 form))
866 (nth 3 form))))
867 (t
868 (list 'progn clause nil)))))
869
870(defun byte-optimize-while (form)
871 (if (nth 1 form)
872 form))
873
874(put 'and 'byte-optimizer 'byte-optimize-and)
875(put 'or 'byte-optimizer 'byte-optimize-or)
876(put 'cond 'byte-optimizer 'byte-optimize-cond)
877(put 'if 'byte-optimizer 'byte-optimize-if)
878(put 'while 'byte-optimizer 'byte-optimize-while)
879
880;; byte-compile-negation-optimizer lives in bytecomp.el
881(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
882(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
883(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
884
885
886(defun byte-optimize-funcall (form)
887 ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
888 ;; (funcall 'foo ...) ==> (foo ...)
889 (let ((fn (nth 1 form)))
890 (if (memq (car-safe fn) '(quote function))
891 (cons (nth 1 fn) (cdr (cdr form)))
892 form)))
893
894(defun byte-optimize-apply (form)
895 ;; If the last arg is a literal constant, turn this into a funcall.
896 ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
897 (let ((fn (nth 1 form))
898 (last (nth (1- (length form)) form))) ; I think this really is fastest
899 (or (if (or (null last)
900 (eq (car-safe last) 'quote))
901 (if (listp (nth 1 last))
902 (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
903 (nconc (list 'funcall fn) butlast (nth 1 last)))
904 (byte-compile-warn
905 "last arg to apply can't be a literal atom: %s"
906 (prin1-to-string last))
907 nil))
908 form)))
909
910(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
911(put 'apply 'byte-optimizer 'byte-optimize-apply)
912
913
914(put 'let 'byte-optimizer 'byte-optimize-letX)
915(put 'let* 'byte-optimizer 'byte-optimize-letX)
916(defun byte-optimize-letX (form)
917 (cond ((null (nth 1 form))
918 ;; No bindings
919 (cons 'progn (cdr (cdr form))))
920 ((or (nth 2 form) (nthcdr 3 form))
921 form)
922 ;; The body is nil
923 ((eq (car form) 'let)
924 (append '(progn) (mapcar 'car (mapcar 'cdr (nth 1 form))) '(nil)))
925 (t
926 (let ((binds (reverse (nth 1 form))))
927 (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil)))))
928
929
930(put 'nth 'byte-optimizer 'byte-optimize-nth)
931(defun byte-optimize-nth (form)
932 (if (memq (nth 1 form) '(0 1))
933 (list 'car (if (zerop (nth 1 form))
934 (nth 2 form)
935 (list 'cdr (nth 2 form))))
936 (byte-optimize-predicate form)))
937
938(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr)
939(defun byte-optimize-nthcdr (form)
940 (let ((count (nth 1 form)))
941 (if (not (memq count '(0 1 2)))
942 (byte-optimize-predicate form)
943 (setq form (nth 2 form))
944 (while (natnump (setq count (1- count)))
945 (setq form (list 'cdr form)))
946 form)))
947
948;;; enumerating those functions which need not be called if the returned
949;;; value is not used. That is, something like
950;;; (progn (list (something-with-side-effects) (yow))
951;;; (foo))
952;;; may safely be turned into
953;;; (progn (progn (something-with-side-effects) (yow))
954;;; (foo))
955;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo.
956
957;;; I wonder if I missed any :-\)
958(let ((side-effect-free-fns
959 '(% * + / /= 1+ < <= = > >= append aref ash assoc assq boundp
960 buffer-file-name buffer-local-variables buffer-modified-p
961 buffer-substring capitalize car cdr concat coordinates-in-window-p
962 copy-marker count-lines documentation downcase elt fboundp featurep
963 file-directory-p file-exists-p file-locked-p file-name-absolute-p
964 file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
965 format get get-buffer get-buffer-window getenv get-file-buffer length
966 logand logior lognot logxor lsh marker-buffer max member memq min mod
967 next-window nth nthcdr previous-window rassq regexp-quote reverse
968 string< string= string-lessp string-equal substring user-variable-p
969 window-buffer window-edges window-height window-hscroll window-width
970 zerop))
971 ;; could also add plusp, minusp, signum. If anyone ever defines
972 ;; these, they will certainly be side-effect free.
973 (side-effect-and-error-free-fns
974 '(arrayp atom bobp bolp buffer-end buffer-list buffer-size
975 buffer-string bufferp char-or-string-p commandp cons consp
976 current-buffer dot dot-marker eobp eolp eq eql equal
977 get-largest-window identity integerp integer-or-marker-p
978 interactive-p keymapp list listp make-marker mark mark-marker
979 markerp minibuffer-window natnump nlistp not null numberp
980 one-window-p point point-marker processp selected-window sequencep
981 stringp subrp symbolp syntax-table-p vector vectorp windowp)))
982 (while side-effect-free-fns
983 (put (car side-effect-free-fns) 'side-effect-free t)
984 (setq side-effect-free-fns (cdr side-effect-free-fns)))
985 (while side-effect-and-error-free-fns
986 (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
987 (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
988 nil)
989
990
991(defun byte-compile-splice-in-already-compiled-code (form)
992 ;; form is (byte-code "..." [...] n)
993 (if (not (memq byte-optimize '(t lap)))
994 (byte-compile-normal-call form)
995 (byte-inline-lapcode
996 (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
997 (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
998 byte-compile-maxdepth))
999 (setq byte-compile-depth (1+ byte-compile-depth))))
1000
1001(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
1002
1003
1004(defconst byte-constref-ops
1005 '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
1006
1007;;; This function extracts the bitfields from variable-length opcodes.
1008;;; Originally defined in disass.el (which no longer uses it.)
1009
1010(defun disassemble-offset ()
1011 "Don't call this!"
1012 ;; fetch and return the offset for the current opcode.
1013 ;; return NIL if this opcode has no offset
1014 ;; OP, PTR and BYTES are used and set dynamically
1015 (defvar op)
1016 (defvar ptr)
1017 (defvar bytes)
1018 (cond ((< op byte-nth)
1019 (let ((tem (logand op 7)))
1020 (setq op (logand op 248))
1021 (cond ((eq tem 6)
1022 (setq ptr (1+ ptr)) ;offset in next byte
1023 (aref bytes ptr))
1024 ((eq tem 7)
1025 (setq ptr (1+ ptr)) ;offset in next 2 bytes
1026 (+ (aref bytes ptr)
1027 (progn (setq ptr (1+ ptr))
1028 (lsh (aref bytes ptr) 8))))
1029 (t tem)))) ;offset was in opcode
1030 ((>= op byte-constant)
1031 (prog1 (- op byte-constant) ;offset in opcode
1032 (setq op byte-constant)))
1033 ((and (>= op byte-constant2)
1034 (<= op byte-goto-if-not-nil-else-pop))
1035 (setq ptr (1+ ptr)) ;offset in next 2 bytes
1036 (+ (aref bytes ptr)
1037 (progn (setq ptr (1+ ptr))
1038 (lsh (aref bytes ptr) 8))))
1039 ((and (>= op byte-rel-goto)
1040 (<= op byte-insertN))
1041 (setq ptr (1+ ptr)) ;offset in next byte
1042 (aref bytes ptr))))
1043
1044
1045;;; This de-compiler is used for inline expansion of compiled functions,
1046;;; and by the disassembler.
1047;;;
1048(defun byte-decompile-bytecode (bytes constvec)
1049 "Turns BYTECODE into lapcode, refering to CONSTVEC."
1050 (let ((byte-compile-constants nil)
1051 (byte-compile-variables nil)
1052 (byte-compile-tag-number 0))
1053 (byte-decompile-bytecode-1 bytes constvec)))
1054
1055(defun byte-decompile-bytecode-1 (bytes constvec &optional make-splicable)
1056 "As byte-decompile-bytecode, but updates
1057byte-compile-{constants, variables, tag-number}.
1058If the optional 3rd arg is true, then `return' opcodes are replaced
1059with `goto's destined for the end of the code."
1060 (let ((length (length bytes))
1061 (ptr 0) optr tag tags op offset
1062 lap tmp
1063 endtag
1064 (retcount 0))
1065 (while (not (= ptr length))
1066 (setq op (aref bytes ptr)
1067 optr ptr
1068 offset (disassemble-offset)) ; this does dynamic-scope magic
1069 (setq op (aref byte-code-vector op))
1070 (cond ((or (memq op byte-goto-ops)
1071 (cond ((memq op byte-rel-goto-ops)
1072 (setq op (aref byte-code-vector
1073 (- (symbol-value op)
1074 (- byte-rel-goto byte-goto))))
1075 (setq offset (+ ptr (- offset 127)))
1076 t)))
1077 ;; it's a pc
1078 (setq offset
1079 (cdr (or (assq offset tags)
1080 (car (setq tags
1081 (cons (cons offset
1082 (byte-compile-make-tag))
1083 tags)))))))
1084 ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
1085 ((memq op byte-constref-ops)))
1086 (setq tmp (aref constvec offset)
1087 offset (if (eq op 'byte-constant)
1088 (byte-compile-get-constant tmp)
1089 (or (assq tmp byte-compile-variables)
1090 (car (setq byte-compile-variables
1091 (cons (list tmp)
1092 byte-compile-variables)))))))
1093 ((and make-splicable
1094 (eq op 'byte-return))
1095 (if (= ptr (1- length))
1096 (setq op nil)
1097 (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
1098 op 'byte-goto))))
1099 ;; lap = ( [ (pc . (op . arg)) ]* )
1100 (setq lap (cons (cons optr (cons op (or offset 0)))
1101 lap))
1102 (setq ptr (1+ ptr)))
1103 ;; take off the dummy nil op that we replaced a trailing "return" with.
1104 (let ((rest lap))
1105 (while rest
1106 (cond ((setq tmp (assq (car (car rest)) tags))
1107 ;; this addr is jumped to
1108 (setcdr rest (cons (cons nil (cdr tmp))
1109 (cdr rest)))
1110 (setq tags (delq tmp tags))
1111 (setq rest (cdr rest))))
1112 (setq rest (cdr rest))))
1113 (if tags (error "optimizer error: missed tags %s" tags))
1114 (if (null (car (cdr (car lap))))
1115 (setq lap (cdr lap)))
1116 (if endtag
1117 (setq lap (cons (cons nil endtag) lap)))
1118 ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
1119 (mapcar 'cdr (nreverse lap))))
1120
1121
1122;;; peephole optimizer
1123
1124(defconst byte-tagref-ops (cons 'TAG byte-goto-ops))
1125
1126(defconst byte-conditional-ops
1127 '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
1128 byte-goto-if-not-nil-else-pop))
1129
1130(defconst byte-after-unbind-ops
1131 '(byte-constant byte-dup
1132 byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
1133 byte-eq byte-equal byte-not
1134 byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4
1135 byte-interactive-p
1136 ;; How about other side-effect-free-ops? Is it safe to move an
1137 ;; error invocation (such as from nth) out of an unwind-protect?
1138 "Byte-codes that can be moved past an unbind."))
1139
1140(defconst byte-compile-side-effect-and-error-free-ops
1141 '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
1142 byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
1143 byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
1144 byte-point-min byte-following-char byte-preceding-char
1145 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
1146 byte-current-buffer byte-interactive-p))
1147
1148(defconst byte-compile-side-effect-free-ops
1149 (nconc
1150 '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
1151 byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
1152 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
1153 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
1154 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
1155 byte-member byte-assq byte-quo byte-rem)
1156 byte-compile-side-effect-and-error-free-ops))
1157
1158;;; This piece of shit is because of the way DEFVAR_BOOL() variables work.
1159;;; Consider the code
1160;;;
1161;;; (defun foo (flag)
1162;;; (let ((old-pop-ups pop-up-windows)
1163;;; (pop-up-windows flag))
1164;;; (cond ((not (eq pop-up-windows old-pop-ups))
1165;;; (setq old-pop-ups pop-up-windows)
1166;;; ...))))
1167;;;
1168;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is
1169;;; something else. But if we optimize
1170;;;
1171;;; varref flag
1172;;; varbind pop-up-windows
1173;;; varref pop-up-windows
1174;;; not
1175;;; to
1176;;; varref flag
1177;;; dup
1178;;; varbind pop-up-windows
1179;;; not
1180;;;
1181;;; we break the program, because it will appear that pop-up-windows and
1182;;; old-pop-ups are not EQ when really they are. So we have to know what
1183;;; the BOOL variables are, and not perform this optimization on them.
1184;;;
1185(defconst byte-boolean-vars
1186 '(abbrevs-changed abbrev-all-caps inverse-video visible-bell
1187 check-protected-fields no-redraw-on-reenter cursor-in-echo-area
1188 noninteractive stack-trace-on-error debug-on-error debug-on-quit
1189 debug-on-next-call insert-default-directory vms-stmlf-recfm
1190 indent-tabs-mode meta-flag load-in-progress defining-kbd-macro
1191 completion-auto-help completion-ignore-case enable-recursive-minibuffers
1192 print-escape-newlines delete-exited-processes parse-sexp-ignore-comments
1193 words-include-escapes pop-up-windows auto-new-screen
1194 reset-terminal-on-clear truncate-partial-width-windows
1195 mode-line-inverse-video)
1196 "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t.
1197If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer
1198may generate incorrect code.")
1199
1200(defun byte-optimize-lapcode (lap &optional for-effect)
1201 "Simple peephole optimizer. LAP is both modified and returned."
1202 (let (lap0 off0
1203 lap1 off1
1204 lap2 off2
1205 (keep-going 'first-time)
1206 (add-depth 0)
1207 rest tmp tmp2 tmp3
1208 (side-effect-free (if byte-compile-delete-errors
1209 byte-compile-side-effect-free-ops
1210 byte-compile-side-effect-and-error-free-ops)))
1211 (while keep-going
1212 (or (eq keep-going 'first-time)
1213 (byte-compile-log-lap " ---- next pass"))
1214 (setq rest lap
1215 keep-going nil)
1216 (while rest
1217 (setq lap0 (car rest)
1218 lap1 (nth 1 rest)
1219 lap2 (nth 2 rest))
1220
1221 ;; You may notice that sequences like "dup varset discard" are
1222 ;; optimized but sequences like "dup varset TAG1: discard" are not.
1223 ;; You may be tempted to change this; resist that temptation.
1224 (cond ;;
1225 ;; <side-effect-free> pop --> <deleted>
1226 ;; ...including:
1227 ;; const-X pop --> <deleted>
1228 ;; varref-X pop --> <deleted>
1229 ;; dup pop --> <deleted>
1230 ;;
1231 ((and (eq 'byte-discard (car lap1))
1232 (memq (car lap0) side-effect-free))
1233 (setq keep-going t)
1234 (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
1235 (setq rest (cdr rest))
1236 (cond ((= tmp 1)
1237 (byte-compile-log-lap
1238 " %s discard\t-->\t<deleted>" lap0)
1239 (setq lap (delq lap0 (delq lap1 lap))))
1240 ((= tmp 0)
1241 (byte-compile-log-lap
1242 " %s discard\t-->\t<deleted> discard" lap0)
1243 (setq lap (delq lap0 lap)))
1244 ((= tmp -1)
1245 (byte-compile-log-lap
1246 " %s discard\t-->\tdiscard discard" lap0)
1247 (setcar lap0 'byte-discard)
1248 (setcdr lap0 0))
1249 ((error "Optimizer error: too much on the stack"))))
1250 ;;
1251 ;; goto*-X X: --> X:
1252 ;;
1253 ((and (memq (car lap0) byte-goto-ops)
1254 (eq (cdr lap0) lap1))
1255 (cond ((eq (car lap0) 'byte-goto)
1256 (setq lap (delq lap0 lap))
1257 (setq tmp "<deleted>"))
1258 ((memq (car lap0) byte-goto-always-pop-ops)
1259 (setcar lap0 (setq tmp 'byte-discard))
1260 (setcdr lap0 0))
1261 ((error "Depth conflict at tag %d" (nth 2 lap0))))
1262 (and (memq byte-optimize-log '(t byte))
1263 (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1264 (nth 1 lap1) (nth 1 lap1)
1265 tmp (nth 1 lap1)))
1266 (setq keep-going t))
1267 ;;
1268 ;; varset-X varref-X --> dup varset-X
1269 ;; varbind-X varref-X --> dup varbind-X
1270 ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1271 ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1272 ;; The latter two can enable other optimizations.
1273 ;;
1274 ((and (eq 'byte-varref (car lap2))
1275 (eq (cdr lap1) (cdr lap2))
1276 (memq (car lap1) '(byte-varset byte-varbind)))
1277 (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1278 (not (eq (car lap0) 'byte-constant)))
1279 nil
1280 (setq keep-going t)
1281 (if (memq (car lap0) '(byte-constant byte-dup))
1282 (progn
1283 (setq tmp (if (or (not tmp)
1284 (memq (car (cdr lap0)) '(nil t)))
1285 (cdr lap0)
1286 (byte-compile-get-constant t)))
1287 (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1288 lap0 lap1 lap2 lap0 lap1
1289 (cons (car lap0) tmp))
1290 (setcar lap2 (car lap0))
1291 (setcdr lap2 tmp))
1292 (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1293 (setcar lap2 (car lap1))
1294 (setcar lap1 'byte-dup)
1295 (setcdr lap1 0)
1296 ;; The stack depth gets locally increased, so we will
1297 ;; increase maxdepth in case depth = maxdepth here.
1298 ;; This can cause the third argument to byte-code to
1299 ;; be larger than necessary.
1300 (setq add-depth 1))))
1301 ;;
1302 ;; dup varset-X discard --> varset-X
1303 ;; dup varbind-X discard --> varbind-X
1304 ;; (the varbind variant can emerge from other optimizations)
1305 ;;
1306 ((and (eq 'byte-dup (car lap0))
1307 (eq 'byte-discard (car lap2))
1308 (memq (car lap1) '(byte-varset byte-varbind)))
1309 (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1310 (setq keep-going t
1311 rest (cdr rest))
1312 (setq lap (delq lap0 (delq lap2 lap))))
1313 ;;
1314 ;; not goto-X-if-nil --> goto-X-if-non-nil
1315 ;; not goto-X-if-non-nil --> goto-X-if-nil
1316 ;;
1317 ;; it is wrong to do the same thing for the -else-pop variants.
1318 ;;
1319 ((and (eq 'byte-not (car lap0))
1320 (or (eq 'byte-goto-if-nil (car lap1))
1321 (eq 'byte-goto-if-not-nil (car lap1))))
1322 (byte-compile-log-lap " not %s\t-->\t%s"
1323 lap1
1324 (cons
1325 (if (eq (car lap1) 'byte-goto-if-nil)
1326 'byte-goto-if-not-nil
1327 'byte-goto-if-nil)
1328 (cdr lap1)))
1329 (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1330 'byte-goto-if-not-nil
1331 'byte-goto-if-nil))
1332 (setq lap (delq lap0 lap))
1333 (setq keep-going t))
1334 ;;
1335 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1336 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1337 ;;
1338 ;; it is wrong to do the same thing for the -else-pop variants.
1339 ;;
1340 ((and (or (eq 'byte-goto-if-nil (car lap0))
1341 (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
1342 (eq 'byte-goto (car lap1)) ; gotoY
1343 (eq (cdr lap0) lap2)) ; TAG X
1344 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1345 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1346 (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1347 lap0 lap1 lap2
1348 (cons inverse (cdr lap1)) lap2)
1349 (setq lap (delq lap0 lap))
1350 (setcar lap1 inverse)
1351 (setq keep-going t)))
1352 ;;
1353 ;; const goto-if-* --> whatever
1354 ;;
1355 ((and (eq 'byte-constant (car lap0))
1356 (memq (car lap1) byte-conditional-ops))
1357 (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
1358 (eq (car lap1) 'byte-goto-if-nil-else-pop))
1359 (car (cdr lap0))
1360 (not (car (cdr lap0))))
1361 (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1362 lap0 lap1)
1363 (setq rest (cdr rest)
1364 lap (delq lap0 (delq lap1 lap))))
1365 (t
1366 (if (memq (car lap1) byte-goto-always-pop-ops)
1367 (progn
1368 (byte-compile-log-lap " %s %s\t-->\t%s"
1369 lap0 lap1 (cons 'byte-goto (cdr lap1)))
1370 (setq lap (delq lap0 lap)))
1371 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
1372 (cons 'byte-goto (cdr lap1))))
1373 (setcar lap1 'byte-goto)))
1374 (setq keep-going t))
1375 ;;
1376 ;; varref-X varref-X --> varref-X dup
1377 ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1378 ;; We don't optimize the const-X variations on this here,
1379 ;; because that would inhibit some goto optimizations; we
1380 ;; optimize the const-X case after all other optimizations.
1381 ;;
1382 ((and (eq 'byte-varref (car lap0))
1383 (progn
1384 (setq tmp (cdr rest))
1385 (while (eq (car (car tmp)) 'byte-dup)
1386 (setq tmp (cdr tmp)))
1387 t)
1388 (eq (cdr lap0) (cdr (car tmp)))
1389 (eq 'byte-varref (car (car tmp))))
1390 (if (memq byte-optimize-log '(t byte))
1391 (let ((str ""))
1392 (setq tmp2 (cdr rest))
1393 (while (not (eq tmp tmp2))
1394 (setq tmp2 (cdr tmp2)
1395 str (concat str " dup")))
1396 (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1397 lap0 str lap0 lap0 str)))
1398 (setq keep-going t)
1399 (setcar (car tmp) 'byte-dup)
1400 (setcdr (car tmp) 0)
1401 (setq rest tmp))
1402 ;;
1403 ;; TAG1: TAG2: --> TAG1: <deleted>
1404 ;; (and other references to TAG2 are replaced with TAG1)
1405 ;;
1406 ((and (eq (car lap0) 'TAG)
1407 (eq (car lap1) 'TAG))
1408 (and (memq byte-optimize-log '(t byte))
1409 (byte-compile-log " adjascent tags %d and %d merged"
1410 (nth 1 lap1) (nth 1 lap0)))
1411 (setq tmp3 lap)
1412 (while (setq tmp2 (rassq lap0 tmp3))
1413 (setcdr tmp2 lap1)
1414 (setq tmp3 (cdr (memq tmp2 tmp3))))
1415 (setq lap (delq lap0 lap)
1416 keep-going t))
1417 ;;
1418 ;; unused-TAG: --> <deleted>
1419 ;;
1420 ((and (eq 'TAG (car lap0))
1421 (not (rassq lap0 lap)))
1422 (and (memq byte-optimize-log '(t byte))
1423 (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1424 (setq lap (delq lap0 lap)
1425 keep-going t))
1426 ;;
1427 ;; goto ... --> goto <delete until TAG or end>
1428 ;; return ... --> return <delete until TAG or end>
1429 ;;
1430 ((and (memq (car lap0) '(byte-goto byte-return))
1431 (not (memq (car lap1) '(TAG nil))))
1432 (setq tmp rest)
1433 (let ((i 0)
1434 (opt-p (memq byte-optimize-log '(t lap)))
1435 str deleted)
1436 (while (and (setq tmp (cdr tmp))
1437 (not (eq 'TAG (car (car tmp)))))
1438 (if opt-p (setq deleted (cons (car tmp) deleted)
1439 str (concat str " %s")
1440 i (1+ i))))
1441 (if opt-p
1442 (let ((tagstr
1443 (if (eq 'TAG (car (car tmp)))
1444 (format "%d:" (cdr (car tmp)))
1445 (or (car tmp) ""))))
1446 (if (< i 6)
1447 (apply 'byte-compile-log-lap-1
1448 (concat " %s" str
1449 " %s\t-->\t%s <deleted> %s")
1450 lap0
1451 (nconc (nreverse deleted)
1452 (list tagstr lap0 tagstr)))
1453 (byte-compile-log-lap
1454 " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1455 lap0 i (if (= i 1) "" "s")
1456 tagstr lap0 tagstr))))
1457 (rplacd rest tmp))
1458 (setq keep-going t))
1459 ;;
1460 ;; <safe-op> unbind --> unbind <safe-op>
1461 ;; (this may enable other optimizations.)
1462 ;;
1463 ((and (eq 'byte-unbind (car lap1))
1464 (memq (car lap0) byte-after-unbind-ops))
1465 (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1466 (setcar rest lap1)
1467 (setcar (cdr rest) lap0)
1468 (setq keep-going t))
1469 ;;
1470 ;; varbind-X unbind-N --> discard unbind-(N-1)
1471 ;; save-excursion unbind-N --> unbind-(N-1)
1472 ;; save-restriction unbind-N --> unbind-(N-1)
1473 ;;
1474 ((and (eq 'byte-unbind (car lap1))
1475 (memq (car lap0) '(byte-varbind byte-save-excursion
1476 byte-save-restriction))
1477 (< 0 (cdr lap1)))
1478 (if (zerop (setcdr lap1 (1- (cdr lap1))))
1479 (delq lap1 rest))
1480 (if (eq (car lap0) 'byte-varbind)
1481 (setcar rest (cons 'byte-discard 0))
1482 (setq lap (delq lap0 lap)))
1483 (byte-compile-log-lap " %s %s\t-->\t%s %s"
1484 lap0 (cons (car lap1) (1+ (cdr lap1)))
1485 (if (eq (car lap0) 'byte-varbind)
1486 (car rest)
1487 (car (cdr rest)))
1488 (if (and (/= 0 (cdr lap1))
1489 (eq (car lap0) 'byte-varbind))
1490 (car (cdr rest))
1491 ""))
1492 (setq keep-going t))
1493 ;;
1494 ;; goto*-X ... X: goto-Y --> goto*-Y
1495 ;; goto-X ... X: return --> return
1496 ;;
1497 ((and (memq (car lap0) byte-goto-ops)
1498 (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
1499 '(byte-goto byte-return)))
1500 (cond ((and (not (eq tmp lap0))
1501 (or (eq (car lap0) 'byte-goto)
1502 (eq (car tmp) 'byte-goto)))
1503 (byte-compile-log-lap " %s [%s]\t-->\t%s"
1504 (car lap0) tmp tmp)
1505 (if (eq (car tmp) 'byte-return)
1506 (setcar lap0 'byte-return))
1507 (setcdr lap0 (cdr tmp))
1508 (setq keep-going t))))
1509 ;;
1510 ;; goto-*-else-pop X ... X: goto-if-* --> whatever
1511 ;; goto-*-else-pop X ... X: discard --> whatever
1512 ;;
1513 ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
1514 byte-goto-if-not-nil-else-pop))
1515 (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
1516 (eval-when-compile
1517 (cons 'byte-discard byte-conditional-ops)))
1518 (not (eq lap0 (car tmp))))
1519 (setq tmp2 (car tmp))
1520 (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
1521 byte-goto-if-nil)
1522 (byte-goto-if-not-nil-else-pop
1523 byte-goto-if-not-nil))))
1524 (if (memq (car tmp2) tmp3)
1525 (progn (setcar lap0 (car tmp2))
1526 (setcdr lap0 (cdr tmp2))
1527 (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
1528 (car lap0) tmp2 lap0))
1529 ;; Get rid of the -else-pop's and jump one step further.
1530 (or (eq 'TAG (car (nth 1 tmp)))
1531 (setcdr tmp (cons (byte-compile-make-tag)
1532 (cdr tmp))))
1533 (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
1534 (car lap0) tmp2 (nth 1 tmp3))
1535 (setcar lap0 (nth 1 tmp3))
1536 (setcdr lap0 (nth 1 tmp)))
1537 (setq keep-going t))
1538 ;;
1539 ;; const goto-X ... X: goto-if-* --> whatever
1540 ;; const goto-X ... X: discard --> whatever
1541 ;;
1542 ((and (eq (car lap0) 'byte-constant)
1543 (eq (car lap1) 'byte-goto)
1544 (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
1545 (eval-when-compile
1546 (cons 'byte-discard byte-conditional-ops)))
1547 (not (eq lap1 (car tmp))))
1548 (setq tmp2 (car tmp))
1549 (cond ((memq (car tmp2)
1550 (if (null (car (cdr lap0)))
1551 '(byte-goto-if-nil byte-goto-if-nil-else-pop)
1552 '(byte-goto-if-not-nil
1553 byte-goto-if-not-nil-else-pop)))
1554 (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
1555 lap0 tmp2 lap0 tmp2)
1556 (setcar lap1 (car tmp2))
1557 (setcdr lap1 (cdr tmp2))
1558 ;; Let next step fix the (const,goto-if*) sequence.
1559 (setq rest (cons nil rest)))
1560 (t
1561 ;; Jump one step further
1562 (byte-compile-log-lap
1563 " %s goto [%s]\t-->\t<deleted> goto <skip>"
1564 lap0 tmp2)
1565 (or (eq 'TAG (car (nth 1 tmp)))
1566 (setcdr tmp (cons (byte-compile-make-tag)
1567 (cdr tmp))))
1568 (setcdr lap1 (car (cdr tmp)))
1569 (setq lap (delq lap0 lap))))
1570 (setq keep-going t))
1571 ;;
1572 ;; X: varref-Y ... varset-Y goto-X -->
1573 ;; X: varref-Y Z: ... dup varset-Y goto-Z
1574 ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1575 ;; (This is so usual for while loops that it is worth handling).
1576 ;;
1577 ((and (eq (car lap1) 'byte-varset)
1578 (eq (car lap2) 'byte-goto)
1579 (not (memq (cdr lap2) rest)) ;Backwards jump
1580 (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
1581 'byte-varref)
1582 (eq (cdr (car tmp)) (cdr lap1))
1583 (not (memq (car (cdr lap1)) byte-boolean-vars)))
1584 ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
1585 (let ((newtag (byte-compile-make-tag)))
1586 (byte-compile-log-lap
1587 " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
1588 (nth 1 (cdr lap2)) (car tmp)
1589 lap1 lap2
1590 (nth 1 (cdr lap2)) (car tmp)
1591 (nth 1 newtag) 'byte-dup lap1
1592 (cons 'byte-goto newtag)
1593 )
1594 (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
1595 (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
1596 (setq add-depth 1)
1597 (setq keep-going t))
1598 ;;
1599 ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
1600 ;; (This can pull the loop test to the end of the loop)
1601 ;;
1602 ((and (eq (car lap0) 'byte-goto)
1603 (eq (car lap1) 'TAG)
1604 (eq lap1
1605 (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
1606 (memq (car (car tmp))
1607 '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
1608 byte-goto-if-nil-else-pop)))
1609;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
1610;; lap0 lap1 (cdr lap0) (car tmp))
1611 (let ((newtag (byte-compile-make-tag)))
1612 (byte-compile-log-lap
1613 "%s %s: ... %s: %s\t-->\t%s ... %s:"
1614 lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
1615 (cons (cdr (assq (car (car tmp))
1616 '((byte-goto-if-nil . byte-goto-if-not-nil)
1617 (byte-goto-if-not-nil . byte-goto-if-nil)
1618 (byte-goto-if-nil-else-pop .
1619 byte-goto-if-not-nil-else-pop)
1620 (byte-goto-if-not-nil-else-pop .
1621 byte-goto-if-nil-else-pop))))
1622 newtag)
1623
1624 (nth 1 newtag)
1625 )
1626 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
1627 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
1628 ;; We can handle this case but not the -if-not-nil case,
1629 ;; because we won't know which non-nil constant to push.
1630 (setcdr rest (cons (cons 'byte-constant
1631 (byte-compile-get-constant nil))
1632 (cdr rest))))
1633 (setcar lap0 (nth 1 (memq (car (car tmp))
1634 '(byte-goto-if-nil-else-pop
1635 byte-goto-if-not-nil
1636 byte-goto-if-nil
1637 byte-goto-if-not-nil
1638 byte-goto byte-goto))))
1639 )
1640 (setq keep-going t))
1641 )
1642 (setq rest (cdr rest)))
1643 )
1644 ;; Cleanup stage:
1645 ;; Rebuild byte-compile-constants / byte-compile-variables.
1646 ;; Simple optimizations that would inhibit other optimizations if they
1647 ;; were done in the optimizing loop, and optimizations which there is no
1648 ;; need to do more than once.
1649 (setq byte-compile-constants nil
1650 byte-compile-variables nil)
1651 (setq rest lap)
1652 (while rest
1653 (setq lap0 (car rest)
1654 lap1 (nth 1 rest))
1655 (if (memq (car lap0) byte-constref-ops)
1656 (if (eq (cdr lap0) 'byte-constant)
1657 (or (memq (cdr lap0) byte-compile-variables)
1658 (setq byte-compile-variables (cons (cdr lap0)
1659 byte-compile-variables)))
1660 (or (memq (cdr lap0) byte-compile-constants)
1661 (setq byte-compile-constants (cons (cdr lap0)
1662 byte-compile-constants)))))
1663 (cond (;;
1664 ;; const-C varset-X const-C --> const-C dup varset-X
1665 ;; const-C varbind-X const-C --> const-C dup varbind-X
1666 ;;
1667 (and (eq (car lap0) 'byte-constant)
1668 (eq (car (nth 2 rest)) 'byte-constant)
1669 (eq (cdr lap0) (car (nth 2 rest)))
1670 (memq (car lap1) '(byte-varbind byte-varset)))
1671 (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
1672 lap0 lap1 lap0 lap0 lap1)
1673 (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
1674 (setcar (cdr rest) (cons 'byte-dup 0))
1675 (setq add-depth 1))
1676 ;;
1677 ;; const-X [dup/const-X ...] --> const-X [dup ...] dup
1678 ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup
1679 ;;
1680 ((memq (car lap0) '(byte-constant byte-varref))
1681 (setq tmp rest
1682 tmp2 nil)
1683 (while (progn
1684 (while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
1685 (and (eq (cdr lap0) (cdr (car tmp)))
1686 (eq (car lap0) (car (car tmp)))))
1687 (setcar tmp (cons 'byte-dup 0))
1688 (setq tmp2 t))
1689 (if tmp2
1690 (byte-compile-log-lap
1691 " %s [dup/%s]... %s\t-->\t%s dup..." lap0 lap0 lap0)))
1692 ;;
1693 ;; unbind-N unbind-M --> unbind-(N+M)
1694 ;;
1695 ((and (eq 'byte-unbind (car lap0))
1696 (eq 'byte-unbind (car lap1)))
1697 (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
1698 (cons 'byte-unbind
1699 (+ (cdr lap0) (cdr lap1))))
1700 (setq keep-going t)
1701 (setq lap (delq lap0 lap))
1702 (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
1703 )
1704 (setq rest (cdr rest)))
1705 (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
1706 lap)
1707
1708(provide 'byte-optimize)
1709
1710
1711;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles
1712;; itself, compile some of its most used recursive functions (at load time).
1713;;
1714(eval-when-compile
1715 (or (compiled-function-p (symbol-function 'byte-optimize-form))
1716 (assq 'byte-code (symbol-function 'byte-optimize-form))
1717 (let ((byte-optimize nil)
1718 (byte-compile-warnings nil))
1719 (mapcar '(lambda (x)
1720 (or noninteractive (message "compiling %s..." x))
1721 (byte-compile x)
1722 (or noninteractive (message "compiling %s...done" x)))
1723 '(byte-optimize-form
1724 byte-optimize-body
1725 byte-optimize-predicate
1726 byte-optimize-binary-predicate
1727 ;; Inserted some more than necessary, to speed it up.
1728 byte-optimize-form-code-walker
1729 byte-optimize-lapcode))))
1730 nil)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
new file mode 100644
index 00000000000..1b30194690e
--- /dev/null
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -0,0 +1,3000 @@
1;;; -*- Mode: Emacs-Lisp -*-
2;;; Compilation of Lisp code into byte code.
3;;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
4
5;; By Jamie Zawinski <jwz@lucid.com> and Hallvard Furuseth <hbf@ulrik.uio.no>.
6
7(defconst byte-compile-version "2.04; 5-feb-92.")
8
9;; This file is part of GNU Emacs.
10
11;; GNU Emacs is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 1, or (at your option)
14;; any later version.
15
16;; GNU Emacs is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with GNU Emacs; see the file COPYING. If not, write to
23;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
24
25;;; ========================================================================
26;;; Entry points:
27;;; byte-recompile-directory, byte-compile-file,
28;;; byte-compile-and-load-file byte-compile-buffer, batch-byte-compile,
29;;; byte-compile, byte-compile-sexp, elisp-compile-defun,
30;;; byte-compile-report-call-tree
31
32;;; This version of the elisp byte compiler has the following improvements:
33;;; + optimization of compiled code:
34;;; - removal of unreachable code;
35;;; - removal of calls to side-effectless functions whose return-value
36;;; is unused;
37;;; - compile-time evaluation of safe constant forms, such as (consp nil)
38;;; and (ash 1 6);
39;;; - open-coding of literal lambdas;
40;;; - peephole optimization of emitted code;
41;;; - trivial functions are left uncompiled for speed.
42;;; + support for inline functions;
43;;; + compile-time evaluation of arbitrary expressions;
44;;; + compile-time warning messages for:
45;;; - functions being redefined with incompatible arglists;
46;;; - functions being redefined as macros, or vice-versa;
47;;; - functions or macros defined multiple times in the same file;
48;;; - functions being called with the incorrect number of arguments;
49;;; - functions being called which are not defined globally, in the
50;;; file, or as autoloads;
51;;; - assignment and reference of undeclared free variables;
52;;; - various syntax errors;
53;;; + correct compilation of nested defuns, defmacros, defvars and defsubsts;
54;;; + correct compilation of top-level uses of macros;
55;;; + the ability to generate a histogram of functions called.
56
57;;; User customization variables:
58;;;
59;;; byte-compile-verbose Whether to report the function currently being
60;;; compiled in the minibuffer;
61;;; byte-optimize Whether to do optimizations; this may be
62;;; t, nil, 'source, or 'byte;
63;;; byte-optimize-log Whether to report (in excruciating detail)
64;;; exactly which optimizations have been made.
65;;; This may be t, nil, 'source, or 'byte;
66;;; byte-compile-error-on-warn Whether to stop compilation when a warning is
67;;; produced;
68;;; byte-compile-delete-errors Whether the optimizer may delete calls or
69;;; variable references that are side-effect-free
70;;; except that they may return an error.
71;;; byte-compile-generate-call-tree Whether to generate a histogram of
72;;; function calls. This can be useful for
73;;; finding unused functions, as well as simple
74;;; performance metering.
75;;; byte-compile-warnings List of warnings to issue, or t. May contain
76;;; 'free-vars (references to variables not in the
77;;; current lexical scope)
78;;; 'unresolved (calls to unknown functions)
79;;; 'callargs (lambda calls with args that don't
80;;; match the lambda's definition)
81;;; 'redefine (function cell redefined from
82;;; a macro to a lambda or vice versa,
83;;; or redefined to take other args)
84;;; This defaults to nil in -batch mode, which is
85;;; slightly faster.
86;;; byte-compile-emacs18-compatibility Whether the compiler should
87;;; generate .elc files which can be loaded into
88;;; generic emacs 18's which don't have the file
89;;; bytecomp-runtime.el loaded as well;
90;;; byte-compile-generate-emacs19-bytecodes Whether to generate bytecodes
91;;; which exist only in emacs19. This is a more
92;;; extreme step than setting emacs18-compatibility
93;;; to nil, because there is no elisp you can load
94;;; into an emacs18 to make files compiled this
95;;; way work.
96;;; byte-compile-single-version Normally the byte-compiler will consult the
97;;; above two variables at runtime, but if this
98;;; variable is true when the compiler itself is
99;;; compiled, then the runtime checks will not be
100;;; made, and compilation will be slightly faster.
101;;; elisp-source-extention-re Regexp for the extention of elisp source-files;
102;;; see also the function byte-compile-dest-file.
103;;; byte-compile-overwrite-file If nil, delete old .elc files before saving.
104;;;
105;;; Most of the above parameters can also be set on a file-by-file basis; see
106;;; the documentation of the `byte-compiler-options' macro.
107
108;;; New Features:
109;;;
110;;; o The form `defsubst' is just like `defun', except that the function
111;;; generated will be open-coded in compiled code which uses it. This
112;;; means that no function call will be generated, it will simply be
113;;; spliced in. Elisp functions calls are very slow, so this can be a
114;;; big win.
115;;;
116;;; You can generally accomplish the same thing with `defmacro', but in
117;;; that case, the defined procedure can't be used as an argument to
118;;; mapcar, etc.
119;;;
120;;; o You can make a given function be inline even if it has already been
121;;; defined with `defun' by using the `proclaim-inline' form like so:
122;;; (proclaim-inline my-function)
123;;; This is, in fact, exactly what `defsubst' does. To make a function no
124;;; longer be inline, you must use `proclaim-notinline'. Beware that if
125;;; you define a function with `defsubst' and later redefine it with
126;;; `defun', it will still be open-coded until you use proclaim-notinline.
127;;;
128;;; o You can also open-code one particular call to a function without
129;;; open-coding all calls. Use the 'inline' form to do this, like so:
130;;;
131;;; (inline (foo 1 2 3)) ;; `foo' will be open-coded
132;;; or...
133;;; (inline ;; `foo' and `baz' will be
134;;; (foo 1 2 3 (bar 5)) ;; open-coded, but `bar' will not.
135;;; (baz 0))
136;;;
137;;; o It is possible to open-code a function in the same file it is defined
138;;; in without having to load that file before compiling it. the
139;;; byte-compiler has been modified to remember function definitions in
140;;; the compilation environment in the same way that it remembers macro
141;;; definitions.
142;;;
143;;; o Forms like ((lambda ...) ...) are open-coded.
144;;;
145;;; o The form `eval-when-compile' is like progn, except that the body
146;;; is evaluated at compile-time. When it appears at top-level, this
147;;; is analagous to the Common Lisp idiom (eval-when (compile) ...).
148;;; When it does not appear at top-level, it is similar to the
149;;; Common Lisp #. reader macro (but not in interpreted code.)
150;;;
151;;; o The form `eval-and-compile' is similar to eval-when-compile, but
152;;; the whole form is evalled both at compile-time and at run-time.
153;;;
154;;; o The command Meta-X byte-compile-and-load-file does what you'd think.
155;;;
156;;; o The command elisp-compile-defun is analogous to eval-defun.
157;;;
158;;; o If you run byte-compile-file on a filename which is visited in a
159;;; buffer, and that buffer is modified, you are asked whether you want
160;;; to save the buffer before compiling.
161
162(or (fboundp 'defsubst)
163 ;; This really ought to be loaded already!
164 (load-library "bytecomp-runtime"))
165
166(eval-when-compile
167 (defvar byte-compile-single-version nil
168 "If this is true, the choice of emacs version (v18 or v19) byte-codes will
169be hard-coded into bytecomp when it compiles itself. If the compiler itself
170is compiled with optimization, this causes a speedup.")
171
172 (cond (byte-compile-single-version
173 (defmacro byte-compile-single-version () t)
174 (defmacro byte-compile-version-cond (cond) (list 'quote (eval cond))))
175 (t
176 (defmacro byte-compile-single-version () nil)
177 (defmacro byte-compile-version-cond (cond) cond)))
178 )
179
180;;; The crud you see scattered through this file of the form
181;;; (or (and (boundp 'epoch::version) epoch::version)
182;;; (string-lessp emacs-version "19"))
183;;; is because the Epoch folks couldn't be bothered to follow the
184;;; normal emacs version numbering convention.
185
186(if (byte-compile-version-cond
187 (or (and (boundp 'epoch::version) epoch::version)
188 (string-lessp emacs-version "19")))
189 (progn
190 ;; emacs-18 compatibility.
191 (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined
192
193 (if (byte-compile-single-version)
194 (defmacro compiled-function-p (x) "Emacs 18 doesn't have these." nil)
195 (defun compiled-function-p (x) "Emacs 18 doesn't have these." nil))
196
197 (or (and (fboundp 'member)
198 ;; avoid using someone else's possibly bogus definition of this.
199 (subrp (symbol-function 'member)))
200 (defun member (elt list)
201 "like memq, but uses equal instead of eq. In v19, this is a subr."
202 (while (and list (not (equal elt (car list))))
203 (setq list (cdr list)))
204 list))
205 ))
206
207
208(defvar elisp-source-extention-re (if (eq system-type 'vax-vms)
209 "\\.EL\\(;[0-9]+\\)?$"
210 "\\.el$")
211 "*Regexp which matches the extention of elisp source-files.
212You may want to redefine defun byte-compile-dest-file to match this.")
213
214(or (fboundp 'byte-compile-dest-file)
215 ;; The user may want to redefine this along with elisp-source-extention-re,
216 ;; so only define it if it is undefined.
217 (defun byte-compile-dest-file (filename)
218 "Converts an emacs-lisp source-filename to a compiled-filename."
219 (setq filename (file-name-sans-versions filename))
220 (cond ((eq system-type 'vax-vms)
221 (concat (substring filename 0 (string-match ";" filename)) "c"))
222 ((string-match elisp-source-extention-re filename)
223 (concat (substring filename 0 (match-beginning 0)) ".elc"))
224 (t (concat filename "c")))))
225
226;; This can be the 'byte-compile property of any symbol.
227(autoload 'byte-compile-inline-expand "byte-optimize")
228
229;; This is the entrypoint to the lapcode optimizer pass1.
230(autoload 'byte-optimize-form "byte-optimize")
231;; This is the entrypoint to the lapcode optimizer pass2.
232(autoload 'byte-optimize-lapcode "byte-optimize")
233(autoload 'byte-compile-unfold-lambda "byte-optimize")
234
235(defvar byte-compile-verbose
236 (and (not noninteractive) (> baud-rate search-slow-speed))
237 "*Non-nil means print messages describing progress of byte-compiler.")
238
239(defvar byte-compile-emacs18-compatibility
240 (or (and (boundp 'epoch::version) epoch::version)
241 (string-lessp emacs-version "19"))
242 "*If this is true, then the byte compiler will generate .elc files which will
243work in generic version 18 emacses without having bytecomp-runtime.el loaded.
244If this is false, the generated code will be more efficient in emacs 19, and
245will be loadable in emacs 18 only if bytecomp-runtime.el is loaded.
246See also byte-compile-generate-emacs19-bytecodes.")
247
248(defvar byte-compile-generate-emacs19-bytecodes
249 (not (or (and (boundp 'epoch::version) epoch::version)
250 (string-lessp emacs-version "19")))
251 "*If this is true, then the byte-compiler will generate bytecode which
252makes use of byte-ops which are present only in emacs19. Code generated
253this way can never be run in emacs18, and may even cause it to crash.")
254
255(defvar byte-optimize t
256 "*If nil, no compile-optimizations will be done.
257Compilation will be faster, generated code will be slower and larger.
258This may be nil, t, 'byte, or 'source. If it is 'byte, then only byte-level
259optimizations will be done; if it is 'source, then only source-level
260optimizations will be done.")
261
262(defvar byte-compile-delete-errors t
263 "*If non-nil, the optimizer may delete forms that may signal an error
264(variable references and side-effect-free functions such as CAR).")
265
266(defvar byte-optimize-log nil
267 "*If true, the byte-compiler will log its optimizations into *Compile-Log*.
268If this is 'source, then only source-level optimizations will be logged.
269If it is 'byte, then only byte-level optimizations will be logged.")
270
271(defvar byte-compile-error-on-warn nil
272 "*If true, the byte-compiler will report warnings with `error' instead
273of `message.'")
274
275(defconst byte-compile-warning-types '(redefine callargs free-vars unresolved))
276(defvar byte-compile-warnings (not noninteractive)
277 "*List of warnings that the byte-compiler should issue (t for all).
278See doc of macro byte-compiler-options.")
279
280(defvar byte-compile-generate-call-tree nil
281 "*If this is true, then the compiler will collect statistics on what
282functions were called and from where. This will be displayed after the
283compilation completes. If it is non-nil, but not t, you will be asked
284for whether to display this.
285
286The call tree only lists functions called, not macros used. Those functions
287which the byte-code interpreter knows about directly (eq, cons, etc.) are
288not reported.
289
290The call tree also lists those functions which are not known to be called
291(that is, to which no calls have been compiled.) Functions which can be
292invoked interactively are excluded from this list.")
293
294(defconst byte-compile-call-tree nil "Alist of functions and their call tree.
295Each element looks like
296
297 \(FUNCTION CALLERS CALLS\)
298
299where CALLERS is a list of functions that call FUNCTION, and CALLS
300is a list of functions for which calls were generated while compiling
301FUNCTION.")
302
303(defvar byte-compile-call-tree-sort 'name
304 "*If non nil, the call tree is sorted.
305The values 'name, 'callers, 'calls, 'calls+callers means to sort on
306the those fields.")
307
308(defvar byte-compile-overwrite-file t
309 "If nil, old .elc files are deleted before the new is saved, and .elc
310files will have the same modes as the corresponding .el file. Otherwise,
311existing .elc files will simply be overwritten, and the existing modes
312will not be changed. If this variable is nil, then an .elc file which
313is a symbolic link will be turned into a normal file, instead of the file
314which the link points to being overwritten.")
315
316(defvar byte-compile-constants nil
317 "list of all constants encountered during compilation of this form")
318(defvar byte-compile-variables nil
319 "list of all variables encountered during compilation of this form")
320(defvar byte-compile-bound-variables nil
321 "list of variables bound in the context of the current form; this list
322lives partly on the stack.")
323(defvar byte-compile-free-references)
324(defvar byte-compile-free-assignments)
325
326(defconst byte-compile-initial-macro-environment
327 '((byte-compiler-options . (lambda (&rest forms)
328 (apply 'byte-compiler-options-handler forms)))
329 (eval-when-compile . (lambda (&rest body)
330 (list 'quote (eval (byte-compile-top-level
331 (cons 'progn body))))))
332 (eval-and-compile . (lambda (&rest body)
333 (eval (cons 'progn body))
334 (cons 'progn body))))
335 "The default macro-environment passed to macroexpand by the compiler.
336Placing a macro here will cause a macro to have different semantics when
337expanded by the compiler as when expanded by the interpreter.")
338
339(defvar byte-compile-macro-environment byte-compile-initial-macro-environment
340 "Alist of (MACRONAME . DEFINITION) macros defined in the file which is being
341compiled. It is (MACRONAME . nil) when a macro is redefined as a function.")
342
343(defvar byte-compile-function-environment nil
344 "Alist of (FUNCTIONNAME . DEFINITION) functions defined in the file which
345is being compiled (this is so we can inline them if necessary). It is
346(FUNCTIONNAME . nil) when a function is redefined as a macro.")
347
348(defvar byte-compile-unresolved-functions nil
349 "Alist of undefined functions to which calls have been compiled (used for
350warnings when the function is later defined with incorrect args).")
351
352(defvar byte-compile-tag-number 0)
353(defvar byte-compile-output nil
354 "Alist describing contents to put in byte code string.
355Each element is (INDEX . VALUE)")
356(defvar byte-compile-depth 0 "Current depth of execution stack.")
357(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
358
359
360;;; The byte codes; this information is duplicated in bytecomp.c
361
362(defconst byte-code-vector nil
363 "An array containing byte-code names indexed by byte-code values.")
364
365(defconst byte-stack+-info nil
366 "An array with the stack adjustment for each byte-code.")
367
368(defmacro byte-defop (opcode stack-adjust opname &optional docstring)
369 ;; This is a speed-hack for building the byte-code-vector at compile-time.
370 ;; We fill in the vector at macroexpand-time, and then after the last call
371 ;; to byte-defop, we write the vector out as a constant instead of writing
372 ;; out a bunch of calls to aset.
373 ;; Actually, we don't fill in the vector itself, because that could make
374 ;; it problematic to compile big changes to this compiler; we store the
375 ;; values on its plist, and remove them later in -extrude.
376 (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value)
377 (put 'byte-code-vector 'tmp-compile-time-value
378 (make-vector 256 nil))))
379 (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value)
380 (put 'byte-stack+-info 'tmp-compile-time-value
381 (make-vector 256 nil)))))
382 (aset v1 opcode opname)
383 (aset v2 opcode stack-adjust))
384 (if docstring
385 (list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
386 (list 'defconst opname opcode)))
387
388(defmacro byte-extrude-byte-code-vectors ()
389 (prog1 (list 'setq 'byte-code-vector
390 (get 'byte-code-vector 'tmp-compile-time-value)
391 'byte-stack+-info
392 (get 'byte-stack+-info 'tmp-compile-time-value))
393 ;; emacs-18 has no REMPROP.
394 (put 'byte-code-vector 'tmp-compile-time-value nil)
395 (put 'byte-stack+-info 'tmp-compile-time-value nil)))
396
397
398;; unused: 0-7
399
400;; These opcodes are special in that they pack their argument into the
401;; opcode word.
402;;
403(byte-defop 8 1 byte-varref "for variable reference")
404(byte-defop 16 -1 byte-varset "for setting a variable")
405(byte-defop 24 -1 byte-varbind "for binding a variable")
406(byte-defop 32 0 byte-call "for calling a function")
407(byte-defop 40 0 byte-unbind "for unbinding special bindings")
408;; codes 41-47 are consumed by the preceeding opcodes
409
410;; unused: 48-55
411
412(byte-defop 56 -1 byte-nth)
413(byte-defop 57 0 byte-symbolp)
414(byte-defop 58 0 byte-consp)
415(byte-defop 59 0 byte-stringp)
416(byte-defop 60 0 byte-listp)
417(byte-defop 61 -1 byte-eq)
418(byte-defop 62 -1 byte-memq)
419(byte-defop 63 0 byte-not)
420(byte-defop 64 0 byte-car)
421(byte-defop 65 0 byte-cdr)
422(byte-defop 66 -1 byte-cons)
423(byte-defop 67 0 byte-list1)
424(byte-defop 68 -1 byte-list2)
425(byte-defop 69 -2 byte-list3)
426(byte-defop 70 -3 byte-list4)
427(byte-defop 71 0 byte-length)
428(byte-defop 72 -1 byte-aref)
429(byte-defop 73 -2 byte-aset)
430(byte-defop 74 0 byte-symbol-value)
431(byte-defop 75 0 byte-symbol-function) ; this was commented out
432(byte-defop 76 -1 byte-set)
433(byte-defop 77 -1 byte-fset) ; this was commented out
434(byte-defop 78 -1 byte-get)
435(byte-defop 79 -2 byte-substring)
436(byte-defop 80 -1 byte-concat2)
437(byte-defop 81 -2 byte-concat3)
438(byte-defop 82 -3 byte-concat4)
439(byte-defop 83 0 byte-sub1)
440(byte-defop 84 0 byte-add1)
441(byte-defop 85 -1 byte-eqlsign)
442(byte-defop 86 -1 byte-gtr)
443(byte-defop 87 -1 byte-lss)
444(byte-defop 88 -1 byte-leq)
445(byte-defop 89 -1 byte-geq)
446(byte-defop 90 -1 byte-diff)
447(byte-defop 91 0 byte-negate)
448(byte-defop 92 -1 byte-plus)
449(byte-defop 93 -1 byte-max)
450(byte-defop 94 -1 byte-min)
451(byte-defop 95 -1 byte-mult) ; v19 only
452(byte-defop 96 1 byte-point)
453(byte-defop 97 1 byte-mark-OBSOLETE) ; no longer generated as of v18
454(byte-defop 98 0 byte-goto-char)
455(byte-defop 99 0 byte-insert)
456(byte-defop 100 1 byte-point-max)
457(byte-defop 101 1 byte-point-min)
458(byte-defop 102 0 byte-char-after)
459(byte-defop 103 1 byte-following-char)
460(byte-defop 104 1 byte-preceding-char)
461(byte-defop 105 1 byte-current-column)
462(byte-defop 106 0 byte-indent-to)
463(byte-defop 107 0 byte-scan-buffer-OBSOLETE) ; no longer generated as of v18
464(byte-defop 108 1 byte-eolp)
465(byte-defop 109 1 byte-eobp)
466(byte-defop 110 1 byte-bolp)
467(byte-defop 111 1 byte-bobp)
468(byte-defop 112 1 byte-current-buffer)
469(byte-defop 113 0 byte-set-buffer)
470(byte-defop 114 1 byte-read-char-OBSOLETE)
471(byte-defop 115 0 byte-set-mark-OBSOLETE)
472(byte-defop 116 1 byte-interactive-p)
473
474;; These ops are new to v19
475(byte-defop 117 0 byte-forward-char)
476(byte-defop 118 0 byte-forward-word)
477(byte-defop 119 -1 byte-skip-chars-forward)
478(byte-defop 120 -1 byte-skip-chars-backward)
479(byte-defop 121 0 byte-forward-line)
480(byte-defop 122 0 byte-char-syntax)
481(byte-defop 123 -1 byte-buffer-substring)
482(byte-defop 124 -1 byte-delete-region)
483(byte-defop 125 -1 byte-narrow-to-region)
484(byte-defop 126 1 byte-widen)
485(byte-defop 127 0 byte-end-of-line)
486
487;; unused: 128
488
489;; These store their argument in the next two bytes
490(byte-defop 129 1 byte-constant2
491 "for reference to a constant with vector index >= byte-constant-limit")
492(byte-defop 130 0 byte-goto "for unconditional jump")
493(byte-defop 131 -1 byte-goto-if-nil "to pop value and jump if it's nil")
494(byte-defop 132 -1 byte-goto-if-not-nil "to pop value and jump if it's not nil")
495(byte-defop 133 -1 byte-goto-if-nil-else-pop
496 "to examine top-of-stack, jump and don't pop it if it's nil,
497otherwise pop it")
498(byte-defop 134 -1 byte-goto-if-not-nil-else-pop
499 "to examine top-of-stack, jump and don't pop it if it's non nil,
500otherwise pop it")
501
502(byte-defop 135 -1 byte-return "to pop a value and return it from `byte-code'")
503(byte-defop 136 -1 byte-discard "to discard one value from stack")
504(byte-defop 137 1 byte-dup "to duplicate the top of the stack")
505
506(byte-defop 138 0 byte-save-excursion
507 "to make a binding to record the buffer, point and mark")
508(byte-defop 139 0 byte-save-window-excursion
509 "to make a binding to record entire window configuration")
510(byte-defop 140 0 byte-save-restriction
511 "to make a binding to record the current buffer clipping restrictions")
512(byte-defop 141 -1 byte-catch
513 "for catch. Takes, on stack, the tag and an expression for the body")
514(byte-defop 142 -1 byte-unwind-protect
515 "for unwind-protect. Takes, on stack, an expression for the unwind-action")
516
517(byte-defop 143 -2 byte-condition-case
518 "for condition-case. Takes, on stack, the variable to bind,
519an expression for the body, and a list of clauses")
520
521(byte-defop 144 0 byte-temp-output-buffer-setup
522 "for entry to with-output-to-temp-buffer.
523Takes, on stack, the buffer name.
524Binds standard-output and does some other things.
525Returns with temp buffer on the stack in place of buffer name")
526
527(byte-defop 145 -1 byte-temp-output-buffer-show
528 "for exit from with-output-to-temp-buffer.
529Expects the temp buffer on the stack underneath value to return.
530Pops them both, then pushes the value back on.
531Unbinds standard-output and makes the temp buffer visible")
532
533;; these ops are new to v19
534(byte-defop 146 0 byte-unbind-all "to unbind back to the beginning of
535this frame. Not used yet, but wil be needed for tail-recursion elimination.")
536
537;; these ops are new to v19
538(byte-defop 147 -2 byte-set-marker)
539(byte-defop 148 0 byte-match-beginning)
540(byte-defop 149 0 byte-match-end)
541(byte-defop 150 0 byte-upcase)
542(byte-defop 151 0 byte-downcase)
543(byte-defop 152 -1 byte-string=)
544(byte-defop 153 -1 byte-string<)
545(byte-defop 154 -1 byte-equal)
546(byte-defop 155 -1 byte-nthcdr)
547(byte-defop 156 -1 byte-elt)
548(byte-defop 157 -1 byte-member)
549(byte-defop 158 -1 byte-assq)
550(byte-defop 159 0 byte-nreverse)
551(byte-defop 160 -1 byte-setcar)
552(byte-defop 161 -1 byte-setcdr)
553(byte-defop 162 0 byte-car-safe)
554(byte-defop 163 0 byte-cdr-safe)
555(byte-defop 164 -1 byte-nconc)
556(byte-defop 165 -1 byte-quo)
557(byte-defop 166 -1 byte-rem)
558(byte-defop 167 0 byte-numberp)
559(byte-defop 168 0 byte-integerp)
560
561;; unused: 169
562
563;; New to v19. These store their arg in the next byte.
564(byte-defop 170 0 byte-rel-goto)
565(byte-defop 171 -1 byte-rel-goto-if-nil)
566(byte-defop 172 -1 byte-rel-goto-if-not-nil)
567(byte-defop 173 -1 byte-rel-goto-if-nil-else-pop)
568(byte-defop 174 -1 byte-rel-goto-if-not-nil-else-pop)
569
570(byte-defop 175 nil byte-listN)
571(byte-defop 176 nil byte-concatN)
572(byte-defop 177 nil byte-insertN)
573
574;; unused: 178-191
575
576(byte-defop 192 1 byte-constant "for reference to a constant")
577;; codes 193-255 are consumed by byte-constant.
578(defconst byte-constant-limit 64
579 "Exclusive maximum index usable in the `byte-constant' opcode.")
580
581(defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
582 byte-goto-if-nil-else-pop
583 byte-goto-if-not-nil-else-pop)
584 "those byte-codes whose offset is a pc.")
585
586(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
587
588(defconst byte-rel-goto-ops '(byte-rel-goto
589 byte-rel-goto-if-nil byte-rel-goto-if-not-nil
590 byte-rel-goto-if-nil-else-pop
591 byte-rel-goto-if-not-nil-else-pop)
592 "byte-codes for relative jumps.")
593
594(byte-extrude-byte-code-vectors)
595
596;;; lapcode generator
597;;;
598;;; the byte-compiler now does source -> lapcode -> bytecode instead of
599;;; source -> bytecode, because it's a lot easier to make optimizations
600;;; on lapcode than on bytecode.
601;;;
602;;; Elements of the lapcode list are of the form (<instruction> . <parameter>)
603;;; where instruction is a symbol naming a byte-code instruction,
604;;; and parameter is an argument to that instruction, if any.
605;;;
606;;; The instruction can be the pseudo-op TAG, which means that this position
607;;; in the instruction stream is a target of a goto. (car PARAMETER) will be
608;;; the PC for this location, and the whole instruction "(TAG pc)" will be the
609;;; parameter for some goto op.
610;;;
611;;; If the operation is varbind, varref, varset or push-constant, then the
612;;; parameter is (variable/constant . index_in_constant_vector).
613;;;
614;;; First, the source code is macroexpanded and optimized in various ways.
615;;; Then the resultant code is compiled into lapcode. Another set of
616;;; optimizations are then run over the lapcode. Then the variables and
617;;; constants referenced by the lapcode are collected and placed in the
618;;; constants-vector. (This happens now so that variables referenced by dead
619;;; code don't consume space.) And finally, the lapcode is transformed into
620;;; compacted byte-code.
621;;;
622;;; A distinction is made between variables and constants because the variable-
623;;; referencing instructions are more sensitive to the variables being near the
624;;; front of the constants-vector than the constant-referencing instructions.
625;;; Also, this lets us notice references to free variables.
626
627(defun byte-compile-lapcode (lap)
628 "Turns lapcode into bytecode. The lapcode is destroyed."
629 ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
630 (let ((pc 0) ; Program counter
631 op off ; Operation & offset
632 (bytes '()) ; Put the output bytes here
633 (patchlist nil) ; List of tags and goto's to patch
634 rest rel tmp)
635 (while lap
636 (setq op (car (car lap))
637 off (cdr (car lap)))
638 (cond ((not (symbolp op))
639 (error "non-symbolic opcode %s" op))
640 ((eq op 'TAG)
641 (setcar off pc)
642 (setq patchlist (cons off patchlist)))
643 ((memq op byte-goto-ops)
644 (setq pc (+ pc 3))
645 (setq bytes (cons (cons pc (cdr off))
646 (cons nil
647 (cons (symbol-value op) bytes))))
648 (setq patchlist (cons bytes patchlist)))
649 (t
650 (setq bytes
651 (cond ((cond ((consp off)
652 ;; Variable or constant reference
653 (setq off (cdr off))
654 (eq op 'byte-constant)))
655 (cond ((< off byte-constant-limit)
656 (setq pc (1+ pc))
657 (cons (+ byte-constant off) bytes))
658 (t
659 (setq pc (+ 3 pc))
660 (cons (lsh off -8)
661 (cons (logand off 255)
662 (cons byte-constant2 bytes))))))
663 ((<= byte-listN (symbol-value op))
664 (setq pc (+ 2 pc))
665 (cons off (cons (symbol-value op) bytes)))
666 ((< off 6)
667 (setq pc (1+ pc))
668 (cons (+ (symbol-value op) off) bytes))
669 ((< off 256)
670 (setq pc (+ 2 pc))
671 (cons off (cons (+ (symbol-value op) 6) bytes)))
672 (t
673 (setq pc (+ 3 pc))
674 (cons (lsh off -8)
675 (cons (logand off 255)
676 (cons (+ (symbol-value op) 7)
677 bytes))))))))
678 (setq lap (cdr lap)))
679 ;;(if (not (= pc (length bytes)))
680 ;; (error "compiler error: pc mismatch - %s %s" pc (length bytes)))
681 (cond ((byte-compile-version-cond byte-compile-generate-emacs19-bytecodes)
682 ;; Make relative jumps
683 (setq patchlist (nreverse patchlist))
684 (while (progn
685 (setq off 0) ; PC change because of deleted bytes
686 (setq rest patchlist)
687 (while rest
688 (setq tmp (car rest))
689 (and (consp (car tmp)) ; Jump
690 (prog1 (null (nth 1 tmp)) ; Absolute jump
691 (setq tmp (car tmp)))
692 (progn
693 (setq rel (- (car (cdr tmp)) (car tmp)))
694 (and (<= -129 rel) (< rel 128)))
695 (progn
696 ;; Convert to relative jump.
697 (setcdr (car rest) (cdr (cdr (car rest))))
698 (setcar (cdr (car rest))
699 (+ (car (cdr (car rest)))
700 (- byte-rel-goto byte-goto)))
701 (setq off (1- off))))
702 (setcar tmp (+ (car tmp) off)) ; Adjust PC
703 (setq rest (cdr rest)))
704 ;; If optimizing, repeat until no change.
705 (and byte-optimize
706 (not (zerop off)))))))
707 ;; Patch PC into jumps
708 (let (bytes)
709 (while patchlist
710 (setq bytes (car patchlist))
711 (cond ((atom (car bytes))) ; Tag
712 ((nth 1 bytes) ; Relative jump
713 (setcar bytes (+ (- (car (cdr (car bytes))) (car (car bytes)))
714 128)))
715 (t ; Absolute jump
716 (setq pc (car (cdr (car bytes)))) ; Pick PC from tag
717 (setcar (cdr bytes) (logand pc 255))
718 (setcar bytes (lsh pc -8))))
719 (setq patchlist (cdr patchlist))))
720 (concat (nreverse bytes))))
721
722
723;;; byte compiler messages
724
725(defconst byte-compile-current-form nil)
726(defconst byte-compile-current-file nil)
727
728(defmacro byte-compile-log (format-string &rest args)
729 (list 'and
730 'byte-optimize
731 '(memq byte-optimize-log '(t source))
732 (list 'let '((print-escape-newlines t)
733 (print-level 4)
734 (print-length 4))
735 (list 'byte-compile-log-1
736 (cons 'format
737 (cons format-string
738 (mapcar
739 '(lambda (x)
740 (if (symbolp x) (list 'prin1-to-string x) x))
741 args)))))))
742
743(defconst byte-compile-last-warned-form nil)
744
745(defun byte-compile-log-1 (string)
746 (cond (noninteractive
747 (if (or byte-compile-current-file
748 (and byte-compile-last-warned-form
749 (not (eq byte-compile-current-form
750 byte-compile-last-warned-form))))
751 (message (format "While compiling %s%s:"
752 (or byte-compile-current-form "toplevel forms")
753 (if byte-compile-current-file
754 (if (stringp byte-compile-current-file)
755 (concat " in file " byte-compile-current-file)
756 (concat " in buffer "
757 (buffer-name byte-compile-current-file)))
758 ""))))
759 (message " %s" string))
760 (t
761 (save-excursion
762 (set-buffer (get-buffer-create "*Compile-Log*"))
763 (goto-char (point-max))
764 (cond ((or byte-compile-current-file
765 (and byte-compile-last-warned-form
766 (not (eq byte-compile-current-form
767 byte-compile-last-warned-form))))
768 (if byte-compile-current-file
769 (insert "\n\^L\n" (current-time-string) "\n"))
770 (insert "While compiling "
771 (if byte-compile-current-form
772 (format "%s" byte-compile-current-form)
773 "toplevel forms"))
774 (if byte-compile-current-file
775 (if (stringp byte-compile-current-file)
776 (insert " in file " byte-compile-current-file)
777 (insert " in buffer "
778 (buffer-name byte-compile-current-file))))
779 (insert ":\n")))
780 (insert " " string "\n"))))
781 (setq byte-compile-current-file nil
782 byte-compile-last-warned-form byte-compile-current-form))
783
784(defun byte-compile-warn (format &rest args)
785 (setq format (apply 'format format args))
786 (if byte-compile-error-on-warn
787 (error "%s" format) ; byte-compile-file catches and logs it
788 (byte-compile-log-1 (concat "** " format))
789 (or noninteractive ; already written on stdout.
790 (message "Warning: %s" format))))
791
792;;; Used by make-obsolete.
793(defun byte-compile-obsolete (form)
794 (let ((new (get (car form) 'byte-obsolete-info)))
795 (byte-compile-warn "%s is an obsolete function; %s" (car form)
796 (if (stringp (car new))
797 (car new)
798 (format "use %s instead." (car new))))
799 (funcall (or (cdr new) 'byte-compile-normal-call) form)))
800
801;; Compiler options
802
803(defvar byte-compiler-legal-options
804 '((optimize byte-optimize (t nil source byte) val)
805 (file-format byte-compile-emacs18-compatibility (emacs18 emacs19)
806 (eq val 'emacs18))
807 (new-bytecodes byte-compile-generate-emacs19-bytecodes (t nil) val)
808 (delete-errors byte-compile-delete-errors (t nil) val)
809 (verbose byte-compile-verbose (t nil) val)
810 (warnings byte-compile-warnings ((callargs redefine free-vars unresolved))
811 val)))
812
813;; Inhibit v18/v19 selectors if the version is hardcoded.
814;; #### This should print a warning if the user tries to change something
815;; than can't be changed because the running compiler doesn't support it.
816(cond
817 ((byte-compile-single-version)
818 (setcar (cdr (cdr (assq 'new-bytecodes byte-compiler-legal-options)))
819 (list (byte-compile-version-cond
820 byte-compile-generate-emacs19-bytecodes)))
821 (setcar (cdr (cdr (assq 'file-format byte-compiler-legal-options)))
822 (if (byte-compile-version-cond byte-compile-emacs18-compatibility)
823 '(emacs18) '(emacs19)))))
824
825(defun byte-compiler-options-handler (&rest args)
826 (let (key val desc choices)
827 (while args
828 (if (or (atom (car args)) (nthcdr 2 (car args)) (null (cdr (car args))))
829 (error "malformed byte-compiler-option %s" (car args)))
830 (setq key (car (car args))
831 val (car (cdr (car args)))
832 desc (assq key byte-compiler-legal-options))
833 (or desc
834 (error "unknown byte-compiler option %s" key))
835 (setq choices (nth 2 desc))
836 (if (consp (car choices))
837 (let (this
838 (handler 'cons)
839 (ret (and (memq (car val) '(+ -))
840 (copy-sequence (if (eq t (symbol-value (nth 1 desc)))
841 choices
842 (symbol-value (nth 1 desc)))))))
843 (setq choices (car choices))
844 (while val
845 (setq this (car val))
846 (cond ((memq this choices)
847 (setq ret (funcall handler this ret)))
848 ((eq this '+) (setq handler 'cons))
849 ((eq this '-) (setq handler 'delq))
850 ((error "%s only accepts %s." key choices)))
851 (setq val (cdr val)))
852 (set (nth 1 desc) ret))
853 (or (memq val choices)
854 (error "%s must be one of %s." key choices))
855 (set (nth 1 desc) (eval (nth 3 desc))))
856 (setq args (cdr args)))
857 nil))
858
859;;; sanity-checking arglists
860
861(defun byte-compile-fdefinition (name macro-p)
862 (let* ((list (if macro-p
863 byte-compile-macro-environment
864 byte-compile-function-environment))
865 (env (cdr (assq name list))))
866 (or env
867 (let ((fn name))
868 (while (and (symbolp fn)
869 (fboundp fn)
870 (or (symbolp (symbol-function fn))
871 (consp (symbol-function fn))
872 (and (not macro-p)
873 (compiled-function-p (symbol-function fn)))))
874 (setq fn (symbol-function fn)))
875 (if (and (not macro-p) (compiled-function-p fn))
876 fn
877 (and (consp fn)
878 (if (eq 'macro (car fn))
879 (cdr fn)
880 (if macro-p
881 nil
882 (if (eq 'autoload (car fn))
883 nil
884 fn)))))))))
885
886(defun byte-compile-arglist-signature (arglist)
887 (let ((args 0)
888 opts
889 restp)
890 (while arglist
891 (cond ((eq (car arglist) '&optional)
892 (or opts (setq opts 0)))
893 ((eq (car arglist) '&rest)
894 (if (cdr arglist)
895 (setq restp t
896 arglist nil)))
897 (t
898 (if opts
899 (setq opts (1+ opts))
900 (setq args (1+ args)))))
901 (setq arglist (cdr arglist)))
902 (cons args (if restp nil (if opts (+ args opts) args)))))
903
904
905(defun byte-compile-arglist-signatures-congruent-p (old new)
906 (not (or
907 (> (car new) (car old)) ; requires more args now
908 (and (null (cdr old)) ; tooks rest-args, doesn't any more
909 (cdr new))
910 (and (cdr new) (cdr old) ; can't take as many args now
911 (< (cdr new) (cdr old)))
912 )))
913
914(defun byte-compile-arglist-signature-string (signature)
915 (cond ((null (cdr signature))
916 (format "%d+" (car signature)))
917 ((= (car signature) (cdr signature))
918 (format "%d" (car signature)))
919 (t (format "%d-%d" (car signature) (cdr signature)))))
920
921
922(defun byte-compile-callargs-warn (form)
923 "warn if the form is calling a function with the wrong number of arguments."
924 (let* ((def (or (byte-compile-fdefinition (car form) nil)
925 (byte-compile-fdefinition (car form) t)))
926 (sig (and def (byte-compile-arglist-signature
927 (if (eq 'lambda (car-safe def))
928 (nth 1 def)
929 (aref def 0)))))
930 (ncall (length (cdr form))))
931 (if sig
932 (if (or (< ncall (car sig))
933 (and (cdr sig) (> ncall (cdr sig))))
934 (byte-compile-warn
935 "%s called with %d argument%s, but %s %s"
936 (car form) ncall
937 (if (= 1 ncall) "" "s")
938 (if (< ncall (car sig))
939 "requires"
940 "accepts only")
941 (byte-compile-arglist-signature-string sig)))
942 (or (fboundp (car form)) ; might be a subr or autoload.
943 (eq (car form) byte-compile-current-form) ; ## this doesn't work with recursion.
944 ;; It's a currently-undefined function. Remember number of args in call.
945 (let ((cons (assq (car form) byte-compile-unresolved-functions))
946 (n (length (cdr form))))
947 (if cons
948 (or (memq n (cdr cons))
949 (setcdr cons (cons n (cdr cons))))
950 (setq byte-compile-unresolved-functions
951 (cons (list (car form) n)
952 byte-compile-unresolved-functions))))))))
953
954(defun byte-compile-arglist-warn (form macrop)
955 "warn if the function or macro is being redefined with a different
956number of arguments."
957 (let ((old (byte-compile-fdefinition (nth 1 form) macrop)))
958 (if old
959 (let ((sig1 (byte-compile-arglist-signature
960 (if (eq 'lambda (car-safe old))
961 (nth 1 old)
962 (aref old 0))))
963 (sig2 (byte-compile-arglist-signature (nth 2 form))))
964 (or (byte-compile-arglist-signatures-congruent-p sig1 sig2)
965 (byte-compile-warn "%s %s used to take %s %s, now takes %s"
966 (if (eq (car form) 'defun) "function" "macro")
967 (nth 1 form)
968 (byte-compile-arglist-signature-string sig1)
969 (if (equal sig1 '(1 . 1)) "argument" "arguments")
970 (byte-compile-arglist-signature-string sig2))))
971 ;; This is the first definition. See if previous calls are compatible.
972 (let ((calls (assq (nth 1 form) byte-compile-unresolved-functions))
973 nums sig min max)
974 (if calls
975 (progn
976 (setq sig (byte-compile-arglist-signature (nth 2 form))
977 nums (sort (copy-sequence (cdr calls)) (function <))
978 min (car nums)
979 max (car (nreverse nums)))
980 (if (or (< min (car sig))
981 (and (cdr sig) (> max (cdr sig))))
982 (byte-compile-warn
983 "%s being defined to take %s%s, but was previously called with %s"
984 (nth 1 form)
985 (byte-compile-arglist-signature-string sig)
986 (if (equal sig '(1 . 1)) " arg" " args")
987 (byte-compile-arglist-signature-string (cons min max))))
988
989 (setq byte-compile-unresolved-functions
990 (delq calls byte-compile-unresolved-functions)))))
991 )))
992
993(defun byte-compile-warn-about-unresolved-functions ()
994 "If we have compiled any calls to functions which are not known to be
995defined, issue a warning enumerating them. You can disable this by including
996'unresolved in variable byte-compile-warnings."
997 (if (memq 'unresolved byte-compile-warnings)
998 (let ((byte-compile-current-form "the end of the data"))
999 (if (cdr byte-compile-unresolved-functions)
1000 (let* ((str "The following functions are not known to be defined: ")
1001 (L (length str))
1002 (rest (reverse byte-compile-unresolved-functions))
1003 s)
1004 (while rest
1005 (setq s (symbol-name (car (car rest)))
1006 L (+ L (length s) 2)
1007 rest (cdr rest))
1008 (if (< L (1- fill-column))
1009 (setq str (concat str " " s (and rest ",")))
1010 (setq str (concat str "\n " s (and rest ","))
1011 L (+ (length s) 4))))
1012 (byte-compile-warn "%s" str))
1013 (if byte-compile-unresolved-functions
1014 (byte-compile-warn "the function %s is not known to be defined."
1015 (car (car byte-compile-unresolved-functions)))))))
1016 nil)
1017
1018
1019(defmacro byte-compile-constp (form)
1020 ;; Returns non-nil if FORM is a constant.
1021 (` (cond ((consp (, form)) (eq (car (, form)) 'quote))
1022 ((not (symbolp (, form))))
1023 ((memq (, form) '(nil t))))))
1024
1025(defmacro byte-compile-close-variables (&rest body)
1026 (cons 'let
1027 (cons '(;;
1028 ;; Close over these variables to encapsulate the
1029 ;; compilation state
1030 ;;
1031 (byte-compile-macro-environment
1032 ;; Copy it because the compiler may patch into the
1033 ;; macroenvironment.
1034 (copy-alist byte-compile-initial-macro-environment))
1035 (byte-compile-function-environment nil)
1036 (byte-compile-bound-variables nil)
1037 (byte-compile-free-references nil)
1038 (byte-compile-free-assignments nil)
1039 ;;
1040 ;; Close over these variables so that `byte-compiler-options'
1041 ;; can change them on a per-file basis.
1042 ;;
1043 (byte-compile-verbose byte-compile-verbose)
1044 (byte-optimize byte-optimize)
1045 (byte-compile-generate-emacs19-bytecodes
1046 byte-compile-generate-emacs19-bytecodes)
1047 (byte-compile-warnings (if (eq byte-compile-warnings t)
1048 byte-compile-warning-types
1049 byte-compile-warnings))
1050 )
1051 body)))
1052
1053(defvar byte-compile-warnings-point-max)
1054(defmacro displaying-byte-compile-warnings (&rest body)
1055 (list 'let
1056 '((byte-compile-warnings-point-max
1057 (if (boundp 'byte-compile-warnings-point-max)
1058 byte-compile-warnings-point-max
1059 (save-excursion
1060 (set-buffer (get-buffer-create "*Compile-Log*"))
1061 (point-max)))))
1062 (list 'unwind-protect (cons 'progn body)
1063 '(save-excursion
1064 ;; If there were compilation warnings, display them.
1065 (set-buffer "*Compile-Log*")
1066 (if (= byte-compile-warnings-point-max (point-max))
1067 nil
1068 (select-window
1069 (prog1 (selected-window)
1070 (select-window (display-buffer (current-buffer)))
1071 (goto-char byte-compile-warnings-point-max)
1072 (recenter 1))))))))
1073
1074
1075(defun byte-recompile-directory (directory &optional arg)
1076 "Recompile every `.el' file in DIRECTORY that needs recompilation.
1077This is if a `.elc' file exists but is older than the `.el' file.
1078
1079If the `.elc' file does not exist, normally the `.el' file is *not* compiled.
1080But a prefix argument (optional second arg) means ask user,
1081for each such `.el' file, whether to compile it."
1082 (interactive "DByte recompile directory: \nP")
1083 (save-some-buffers)
1084 (set-buffer-modified-p (buffer-modified-p)) ;Update the mode line.
1085 (setq directory (expand-file-name directory))
1086 (let ((files (directory-files directory nil elisp-source-extention-re))
1087 (count 0)
1088 source dest)
1089 (while files
1090 (if (and (not (auto-save-file-name-p (car files)))
1091 (setq source (expand-file-name (car files) directory))
1092 (setq dest (byte-compile-dest-file source))
1093 (if (file-exists-p dest)
1094 (file-newer-than-file-p source dest)
1095 (and arg (y-or-n-p (concat "Compile " source "? ")))))
1096 (progn (byte-compile-file source)
1097 (setq count (1+ count))))
1098 (setq files (cdr files)))
1099 (message "Done (Total of %d file%s compiled)"
1100 count (if (= count 1) "" "s"))))
1101
1102(defun byte-compile-file (filename &optional load)
1103 "Compile a file of Lisp code named FILENAME into a file of byte code.
1104The output file's name is made by appending `c' to the end of FILENAME.
1105With prefix arg (noninteractively: 2nd arg), load the file after compiling."
1106;; (interactive "fByte compile file: \nP")
1107 (interactive
1108 (let ((file buffer-file-name)
1109 (file-name nil)
1110 (file-dir nil))
1111 (and file
1112 (eq (cdr (assq 'major-mode (buffer-local-variables)))
1113 'emacs-lisp-mode)
1114 (setq file-name (file-name-nondirectory file)
1115 file-dir (file-name-directory file)))
1116 (list (if (byte-compile-version-cond
1117 (or (and (boundp 'epoch::version) epoch::version)
1118 (string-lessp emacs-version "19")))
1119 (read-file-name (if current-prefix-arg
1120 "Byte compile and load file: "
1121 "Byte compile file: ")
1122 file-dir file-name nil)
1123 (read-file-name (if current-prefix-arg
1124 "Byte compile and load file: "
1125 "Byte compile file: ")
1126 file-dir nil nil file-name))
1127 current-prefix-arg)))
1128 ;; Expand now so we get the current buffer's defaults
1129 (setq filename (expand-file-name filename))
1130
1131 ;; If we're compiling a file that's in a buffer and is modified, offer
1132 ;; to save it first.
1133 (or noninteractive
1134 (let ((b (get-file-buffer (expand-file-name filename))))
1135 (if (and b (buffer-modified-p b)
1136 (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
1137 (save-excursion (set-buffer b) (save-buffer)))))
1138
1139 (if byte-compile-verbose
1140 (message "Compiling %s..." filename))
1141 (let ((byte-compile-current-file (file-name-nondirectory filename))
1142 target-file)
1143 (save-excursion
1144 (set-buffer (get-buffer-create " *Compiler Input*"))
1145 (erase-buffer)
1146 (insert-file-contents filename)
1147 ;; Run hooks including the uncompression hook.
1148 ;; If they change the file name, then change it for the output also.
1149 (let ((buffer-file-name filename))
1150 (set-auto-mode)
1151 (setq filename buffer-file-name))
1152 (kill-buffer (prog1 (current-buffer)
1153 (set-buffer (byte-compile-from-buffer (current-buffer)))))
1154 (goto-char (point-max))
1155 (insert "\n") ; aaah, unix.
1156 (let ((vms-stmlf-recfm t))
1157 (setq target-file (byte-compile-dest-file filename))
1158 (or byte-compile-overwrite-file
1159 (condition-case ()
1160 (delete-file target-file)
1161 (error nil)))
1162 (if (file-writable-p target-file)
1163 (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki
1164 (write-region 1 (point-max) target-file))
1165 ;; This is just to give a better error message than write-region
1166 (signal 'file-error (list "Opening output file"
1167 (if (file-exists-p target-file)
1168 "cannot overwrite file"
1169 "directory not writable or nonexistent")
1170 target-file)))
1171 (or byte-compile-overwrite-file
1172 (condition-case ()
1173 (set-file-modes target-file (file-modes filename))
1174 (error nil))))
1175 (kill-buffer (current-buffer)))
1176 (if (and byte-compile-generate-call-tree
1177 (or (eq t byte-compile-generate-call-tree)
1178 (y-or-n-p (format "Report call tree for %s? " filename))))
1179 (save-excursion
1180 (byte-compile-report-call-tree filename)))
1181 (if load
1182 (load target-file)))
1183 t)
1184
1185(defun byte-compile-and-load-file (&optional filename)
1186 "Compile a file of Lisp code named FILENAME into a file of byte code,
1187and then load it. The output file's name is made by appending \"c\" to
1188the end of FILENAME."
1189 (interactive)
1190 (if filename ; I don't get it, (interactive-p) doesn't always work
1191 (byte-compile-file filename t)
1192 (let ((current-prefix-arg '(4)))
1193 (call-interactively 'byte-compile-file))))
1194
1195
1196(defun byte-compile-buffer (&optional buffer)
1197 "Byte-compile and evaluate contents of BUFFER (default: the current buffer)."
1198 (interactive "bByte compile buffer: ")
1199 (setq buffer (if buffer (get-buffer buffer) (current-buffer)))
1200 (message "Compiling %s..." (buffer-name buffer))
1201 (let* ((filename (or (buffer-file-name buffer)
1202 (concat "#<buffer " (buffer-name buffer) ">")))
1203 (byte-compile-current-file buffer))
1204 (byte-compile-from-buffer buffer t))
1205 (message "Compiling %s...done" (buffer-name buffer))
1206 t)
1207
1208;;; compiling a single function
1209(defun elisp-compile-defun (&optional arg)
1210 "Compile and evaluate the current top-level form.
1211Print the result in the minibuffer.
1212With argument, insert value in current buffer after the form."
1213 (interactive "P")
1214 (save-excursion
1215 (end-of-defun)
1216 (beginning-of-defun)
1217 (let* ((byte-compile-current-file nil)
1218 (byte-compile-last-warned-form 'nothing)
1219 (value (eval (byte-compile-sexp (read (current-buffer))))))
1220 (cond (arg
1221 (message "Compiling from buffer... done.")
1222 (prin1 value (current-buffer))
1223 (insert "\n"))
1224 ((message "%s" (prin1-to-string value)))))))
1225
1226
1227(defun byte-compile-from-buffer (inbuffer &optional eval)
1228 ;; buffer --> output-buffer, or buffer --> eval form, return nil
1229 (let (outbuffer)
1230 (let (;; Prevent truncation of flonums and lists as we read and print them
1231 (float-output-format "%20e")
1232 (case-fold-search nil)
1233 (print-length nil)
1234 ;; Simulate entry to byte-compile-top-level
1235 (byte-compile-constants nil)
1236 (byte-compile-variables nil)
1237 (byte-compile-tag-number 0)
1238 (byte-compile-depth 0)
1239 (byte-compile-maxdepth 0)
1240 (byte-compile-output nil)
1241 ;; #### This is bound in b-c-close-variables.
1242 ;;(byte-compile-warnings (if (eq byte-compile-warnings t)
1243 ;; byte-compile-warning-types
1244 ;; byte-compile-warnings))
1245 )
1246 (byte-compile-close-variables
1247 (save-excursion
1248 (setq outbuffer
1249 (set-buffer (get-buffer-create " *Compiler Output*")))
1250 (erase-buffer)
1251;; (emacs-lisp-mode)
1252 (setq case-fold-search nil))
1253 (displaying-byte-compile-warnings
1254 (save-excursion
1255 (set-buffer inbuffer)
1256 (goto-char 1)
1257 (while (progn
1258 (while (progn (skip-chars-forward " \t\n\^l")
1259 (looking-at ";"))
1260 (forward-line 1))
1261 (not (eobp)))
1262 (byte-compile-file-form (read inbuffer)))
1263 ;; Compile pending forms at end of file.
1264 (byte-compile-flush-pending)
1265 (and (not eval) (byte-compile-insert-header))
1266 (byte-compile-warn-about-unresolved-functions)
1267 ;; always do this? When calling multiple files, it would be useful
1268 ;; to delay this warning until all have been compiled.
1269 (setq byte-compile-unresolved-functions nil)))
1270 (save-excursion
1271 (set-buffer outbuffer)
1272 (goto-char (point-min)))))
1273 (if (not eval)
1274 outbuffer
1275 (while (condition-case nil
1276 (progn (setq form (read outbuffer))
1277 t)
1278 (end-of-file nil))
1279 (eval form))
1280 (kill-buffer outbuffer)
1281 nil)))
1282
1283(defun byte-compile-insert-header ()
1284 (save-excursion
1285 (set-buffer outbuffer)
1286 (goto-char 1)
1287 (insert ";;; compiled by " (user-login-name) "@" (system-name) " on "
1288 (current-time-string) "\n;;; from file " filename "\n")
1289 (insert ";;; emacs version " emacs-version ".\n")
1290 (insert ";;; bytecomp version " byte-compile-version "\n;;; "
1291 (cond
1292 ((eq byte-optimize 'source) "source-level optimization only")
1293 ((eq byte-optimize 'byte) "byte-level optimization only")
1294 (byte-optimize "optimization is on")
1295 (t "optimization is off"))
1296 (if (byte-compile-version-cond byte-compile-emacs18-compatibility)
1297 "; compiled with emacs18 compatibility.\n"
1298 ".\n"))
1299 (if (byte-compile-version-cond byte-compile-generate-emacs19-bytecodes)
1300 (insert ";;; this file uses opcodes which do not exist in Emacs18.\n"
1301 ;; Have to check if emacs-version is bound so that this works
1302 ;; in files loaded early in loadup.el.
1303 "\n(if (and (boundp 'emacs-version)\n"
1304 "\t (or (and (boundp 'epoch::version) epoch::version)\n"
1305 "\t (string-lessp emacs-version \"19\")))\n"
1306 " (error \"This file was compiled for Emacs19.\"))\n"
1307 ))
1308 ))
1309
1310
1311(defun byte-compile-output-file-form (form)
1312 ;; writes the given form to the output buffer, being careful of docstrings
1313 ;; in defun, defmacro, defvar, defconst and autoload because make-docfile is
1314 ;; so amazingly stupid.
1315 ;; fset's are output directly by byte-compile-file-form-defmumble; it does
1316 ;; not pay to first build the fset in defmumble and then parse it here.
1317 (if (and (memq (car-safe form) '(defun defmacro defvar defconst autoload))
1318 (stringp (nth 3 form)))
1319 (byte-compile-output-docform '("\n(" 3 ")") form)
1320 (let ((print-escape-newlines t)
1321 (print-readably t))
1322 (princ "\n" outbuffer)
1323 (prin1 form outbuffer)
1324 nil)))
1325
1326(defun byte-compile-output-docform (info form)
1327 ;; Print a form with a doc string. INFO is (prefix doc-index postfix).
1328 (set-buffer
1329 (prog1 (current-buffer)
1330 (set-buffer outbuffer)
1331 (insert (car info))
1332 (let ((docl (nthcdr (nth 1 info) form))
1333 (print-escape-newlines t)
1334 (print-readably t))
1335 (prin1 (car form) outbuffer)
1336 (while (setq form (cdr form))
1337 (insert " ")
1338 (if (eq form docl)
1339 (let ((print-escape-newlines nil))
1340 (goto-char (prog1 (1+ (point))
1341 (prin1 (car form) outbuffer)))
1342 (insert "\\\n")
1343 (goto-char (point-max)))
1344 (prin1 (car form) outbuffer))))
1345 (insert (nth 2 info))))
1346 nil)
1347
1348(defun byte-compile-keep-pending (form &optional handler)
1349 (if (memq byte-optimize '(t source))
1350 (setq form (byte-optimize-form form t)))
1351 (if handler
1352 (let ((for-effect t))
1353 ;; To avoid consing up monstrously large forms at load time, we split
1354 ;; the output regularly.
1355 (and (eq (car-safe form) 'fset) (nthcdr 300 byte-compile-output)
1356 (byte-compile-flush-pending))
1357 (funcall handler form)
1358 (if for-effect
1359 (byte-compile-discard)))
1360 (byte-compile-form form t))
1361 nil)
1362
1363(defun byte-compile-flush-pending ()
1364 (if byte-compile-output
1365 (let ((form (byte-compile-out-toplevel t 'file)))
1366 (cond ((eq (car-safe form) 'progn)
1367 (mapcar 'byte-compile-output-file-form (cdr form)))
1368 (form
1369 (byte-compile-output-file-form form)))
1370 (setq byte-compile-constants nil
1371 byte-compile-variables nil
1372 byte-compile-depth 0
1373 byte-compile-maxdepth 0
1374 byte-compile-output nil))))
1375
1376(defun byte-compile-file-form (form)
1377 (let ((byte-compile-current-form nil) ; close over this for warnings.
1378 handler)
1379 (cond
1380 ((not (consp form))
1381 (byte-compile-keep-pending form))
1382 ((and (symbolp (car form))
1383 (setq handler (get (car form) 'byte-hunk-handler)))
1384 (cond ((setq form (funcall handler form))
1385 (byte-compile-flush-pending)
1386 (byte-compile-output-file-form form))))
1387 ((eq form (setq form (macroexpand form byte-compile-macro-environment)))
1388 (byte-compile-keep-pending form))
1389 (t
1390 (byte-compile-file-form form)))))
1391
1392;; Functions and variables with doc strings must be output separately,
1393;; so make-docfile can recognise them. Most other things can be output
1394;; as byte-code.
1395
1396(put 'defsubst 'byte-hunk-handler 'byte-compile-file-form-defsubst)
1397(defun byte-compile-file-form-defsubst (form)
1398 (cond ((assq (nth 1 form) byte-compile-unresolved-functions)
1399 (setq byte-compile-current-form (nth 1 form))
1400 (byte-compile-warn "defsubst %s was used before it was defined"
1401 (nth 1 form))))
1402 (byte-compile-file-form
1403 (macroexpand form byte-compile-macro-environment))
1404 ;; Return nil so the form is not output twice.
1405 nil)
1406
1407(put 'autoload 'byte-hunk-handler 'byte-compile-file-form-autoload)
1408(defun byte-compile-file-form-autoload (form)
1409 (and (let ((form form))
1410 (while (if (setq form (cdr form)) (byte-compile-constp (car form))))
1411 (null form)) ;Constants only
1412 (eval (nth 5 form)) ;Macro
1413 (eval form)) ;Define the autoload.
1414 (if (stringp (nth 3 form))
1415 form
1416 ;; No doc string, so we can compile this as a normal form.
1417 (byte-compile-keep-pending form 'byte-compile-normal-call)))
1418
1419(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
1420(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
1421(defun byte-compile-file-form-defvar (form)
1422 (if (null (nth 3 form))
1423 ;; Since there is no doc string, we can compile this as a normal form,
1424 ;; and not do a file-boundary.
1425 (byte-compile-keep-pending form)
1426 (if (memq 'free-vars byte-compile-warnings)
1427 (setq byte-compile-bound-variables
1428 (cons (nth 1 form) byte-compile-bound-variables)))
1429 (cond ((consp (nth 2 form))
1430 (setq form (copy-sequence form))
1431 (setcar (cdr (cdr form))
1432 (byte-compile-top-level (nth 2 form) nil 'file))))
1433 form))
1434
1435(put 'require 'byte-hunk-handler 'byte-compile-file-form-eval-boundary)
1436(defun byte-compile-file-form-eval-boundary (form)
1437 (eval form)
1438 (byte-compile-keep-pending form 'byte-compile-normal-call))
1439
1440(put 'progn 'byte-hunk-handler 'byte-compile-file-form-progn)
1441(put 'prog1 'byte-hunk-handler 'byte-compile-file-form-progn)
1442(put 'prog2 'byte-hunk-handler 'byte-compile-file-form-progn)
1443(defun byte-compile-file-form-progn (form)
1444 (mapcar 'byte-compile-file-form (cdr form))
1445 ;; Return nil so the forms are not output twice.
1446 nil)
1447
1448;; This handler is not necessary, but it makes the output from dont-compile
1449;; and similar macros cleaner.
1450(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
1451(defun byte-compile-file-form-eval (form)
1452 (if (eq (car-safe (nth 1 form)) 'quote)
1453 (nth 1 (nth 1 form))
1454 (byte-compile-keep-pending form)))
1455
1456(put 'defun 'byte-hunk-handler 'byte-compile-file-form-defun)
1457(defun byte-compile-file-form-defun (form)
1458 (byte-compile-file-form-defmumble form nil))
1459
1460(put 'defmacro 'byte-hunk-handler 'byte-compile-file-form-defmacro)
1461(defun byte-compile-file-form-defmacro (form)
1462 (byte-compile-file-form-defmumble form t))
1463
1464(defun byte-compile-file-form-defmumble (form macrop)
1465 (let* ((name (car (cdr form)))
1466 (this-kind (if macrop 'byte-compile-macro-environment
1467 'byte-compile-function-environment))
1468 (that-kind (if macrop 'byte-compile-function-environment
1469 'byte-compile-macro-environment))
1470 (this-one (assq name (symbol-value this-kind)))
1471 (that-one (assq name (symbol-value that-kind)))
1472 (byte-compile-free-references nil)
1473 (byte-compile-free-assignments nil))
1474
1475 ;; When a function or macro is defined, add it to the call tree so that
1476 ;; we can tell when functions are not used.
1477 (if byte-compile-generate-call-tree
1478 (or (assq name byte-compile-call-tree)
1479 (setq byte-compile-call-tree
1480 (cons (list name nil nil) byte-compile-call-tree))))
1481
1482 (setq byte-compile-current-form name) ; for warnings
1483 (if (memq 'redefine byte-compile-warnings)
1484 (byte-compile-arglist-warn form macrop))
1485 (if byte-compile-verbose
1486 (message "Compiling %s (%s)..." (or filename "") (nth 1 form)))
1487 (cond (that-one
1488 (if (and (memq 'redefine byte-compile-warnings)
1489 ;; don't warn when compiling the stubs in bytecomp-runtime...
1490 (not (assq (nth 1 form)
1491 byte-compile-initial-macro-environment)))
1492 (byte-compile-warn
1493 "%s defined multiple times, as both function and macro"
1494 (nth 1 form)))
1495 (setcdr that-one nil))
1496 (this-one
1497 (if (and (memq 'redefine byte-compile-warnings)
1498 ;; hack: don't warn when compiling the magic internal
1499 ;; byte-compiler macros in bytecomp-runtime.el...
1500 (not (assq (nth 1 form)
1501 byte-compile-initial-macro-environment)))
1502 (byte-compile-warn "%s %s defined multiple times in this file"
1503 (if macrop "macro" "function")
1504 (nth 1 form))))
1505 ((and (fboundp name)
1506 (eq (car-safe (symbol-function name))
1507 (if macrop 'lambda 'macro)))
1508 (if (memq 'redefine byte-compile-warnings)
1509 (byte-compile-warn "%s %s being redefined as a %s"
1510 (if macrop "function" "macro")
1511 (nth 1 form)
1512 (if macrop "macro" "function")))
1513 ;; shadow existing definition
1514 (set this-kind
1515 (cons (cons name nil) (symbol-value this-kind))))
1516 )
1517 (let ((body (nthcdr 3 form)))
1518 (if (and (stringp (car body))
1519 (symbolp (car-safe (cdr-safe body)))
1520 (car-safe (cdr-safe body))
1521 (stringp (car-safe (cdr-safe (cdr-safe body)))))
1522 (byte-compile-warn "Probable `\"' without `\\' in doc string of %s"
1523 (nth 1 form))))
1524 (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form))))
1525 (code (byte-compile-byte-code-maker new-one)))
1526 (if this-one
1527 (setcdr this-one new-one)
1528 (set this-kind
1529 (cons (cons name new-one) (symbol-value this-kind))))
1530 (if (and (stringp (nth 3 form))
1531 (eq 'quote (car-safe code))
1532 (eq 'lambda (car-safe (nth 1 code))))
1533 (cons (car form)
1534 (cons name (cdr (nth 1 code))))
1535 (if (not (stringp (nth 3 form)))
1536 ;; No doc string to make-docfile; insert form in normal code.
1537 (byte-compile-keep-pending
1538 (list 'fset (list 'quote name)
1539 (cond ((not macrop)
1540 code)
1541 ((eq 'make-byte-code (car-safe code))
1542 (list 'cons ''macro code))
1543 ((list 'quote (if macrop
1544 (cons 'macro new-one)
1545 new-one)))))
1546 'byte-compile-two-args)
1547 ;; Output the form by hand, that's much simpler than having
1548 ;; b-c-output-file-form analyze the fset.
1549 (byte-compile-flush-pending)
1550 (princ "\n(fset '" outbuffer)
1551 (prin1 name outbuffer)
1552 (byte-compile-output-docform
1553 (cond ((atom code)
1554 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]")))
1555 ((eq (car code) 'quote)
1556 (setq code new-one)
1557 (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")")))
1558 ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")"))))
1559 (append code nil))
1560 (princ ")" outbuffer)
1561 nil)))))
1562
1563
1564(defun byte-compile (form)
1565 "If FORM is a symbol, byte-compile its function definition.
1566If FORM is a lambda or a macro, byte-compile it as a function."
1567 (displaying-byte-compile-warnings
1568 (byte-compile-close-variables
1569 (let* ((fun (if (symbolp form)
1570 (and (fboundp form) (symbol-function form))
1571 form))
1572 (macro (eq (car-safe fun) 'macro)))
1573 (if macro
1574 (setq fun (cdr fun)))
1575 (cond ((eq (car-safe fun) 'lambda)
1576 (setq fun (if macro
1577 (cons 'macro (byte-compile-lambda fun))
1578 (byte-compile-lambda fun)))
1579 (if (symbolp form)
1580 (fset form fun)
1581 fun)))))))
1582
1583(defun byte-compile-sexp (sexp)
1584 "Compile and return SEXP."
1585 (displaying-byte-compile-warnings
1586 (byte-compile-close-variables
1587 (byte-compile-top-level sexp))))
1588
1589;; Given a function made by byte-compile-lambda, make a form which produces it.
1590(defun byte-compile-byte-code-maker (fun)
1591 (cond
1592 ((byte-compile-version-cond byte-compile-emacs18-compatibility)
1593 ;; Return (quote (lambda ...)).
1594 (list 'quote (byte-compile-byte-code-unmake fun)))
1595 ;; ## atom is faster than compiled-func-p.
1596 ((atom fun) ; compiled function.
1597 ;; generate-emacs19-bytecodes must be on, otherwise byte-compile-lambda
1598 ;; would have produced a lambda.
1599 fun)
1600 ;; b-c-lambda didn't produce a compiled-function, so it's either a trivial
1601 ;; function, or this is emacs18, or generate-emacs19-bytecodes is off.
1602 ((let (tmp)
1603 (if (and (setq tmp (assq 'byte-code (cdr-safe (cdr fun))))
1604 (null (cdr (memq tmp fun))))
1605 ;; Generate a make-byte-code call.
1606 (let* ((interactive (assq 'interactive (cdr (cdr fun)))))
1607 (nconc (list 'make-byte-code
1608 (list 'quote (nth 1 fun)) ;arglist
1609 (nth 1 tmp) ;bytes
1610 (nth 2 tmp) ;consts
1611 (nth 3 tmp)) ;depth
1612 (cond ((stringp (nth 2 fun))
1613 (list (nth 2 fun))) ;doc
1614 (interactive
1615 (list nil)))
1616 (cond (interactive
1617 (list (if (or (null (nth 1 interactive))
1618 (stringp (nth 1 interactive)))
1619 (nth 1 interactive)
1620 ;; Interactive spec is a list or a variable
1621 ;; (if it is correct).
1622 (list 'quote (nth 1 interactive))))))))
1623 ;; a non-compiled function (probably trivial)
1624 (list 'quote fun))))))
1625
1626;; Turn a function into an ordinary lambda. Needed for v18 files.
1627(defun byte-compile-byte-code-unmake (function)
1628 (if (consp function)
1629 function;;It already is a lambda.
1630 (setq function (append function nil)) ; turn it into a list
1631 (nconc (list 'lambda (nth 0 function))
1632 (and (nth 4 function) (list (nth 4 function)))
1633 (if (nthcdr 5 function)
1634 (list (cons 'interactive (if (nth 5 function)
1635 (nthcdr 5 function)))))
1636 (list (list 'byte-code
1637 (nth 1 function) (nth 2 function)
1638 (nth 3 function))))))
1639
1640
1641;; Byte-compile a lambda-expression and return a valid function.
1642;; The value is usually a compiled function but may be the original
1643;; lambda-expression.
1644(defun byte-compile-lambda (fun)
1645 (let* ((arglist (nth 1 fun))
1646 (byte-compile-bound-variables
1647 (nconc (and (memq 'free-vars byte-compile-warnings)
1648 (delq '&rest (delq '&optional (copy-sequence arglist))))
1649 byte-compile-bound-variables))
1650 (body (cdr (cdr fun)))
1651 (doc (if (stringp (car body))
1652 (prog1 (car body)
1653 (setq body (cdr body)))))
1654 (int (assq 'interactive body)))
1655 (cond (int
1656 ;; Skip (interactive) if it is in front (the most usual location).
1657 (if (eq int (car body))
1658 (setq body (cdr body)))
1659 (cond ((cdr int)
1660 (if (cdr (cdr int))
1661 (byte-compile-warn "malformed interactive spec: %s"
1662 (prin1-to-string int)))
1663 (setq int (list 'interactive (byte-compile-top-level
1664 (nth 1 int))))))))
1665 (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda)))
1666 (if (and (eq 'byte-code (car-safe compiled))
1667 (byte-compile-version-cond
1668 byte-compile-generate-emacs19-bytecodes))
1669 (apply 'make-byte-code
1670 (append (list arglist)
1671 ;; byte-string, constants-vector, stack depth
1672 (cdr compiled)
1673 ;; optionally, the doc string.
1674 (if (or doc int)
1675 (list doc))
1676 ;; optionally, the interactive spec.
1677 (if int
1678 (list (nth 1 int)))))
1679 (setq compiled
1680 (nconc (if int (list int))
1681 (cond ((eq (car-safe compiled) 'progn) (cdr compiled))
1682 (compiled (list compiled)))))
1683 (nconc (list 'lambda arglist)
1684 (if (or doc (stringp (car compiled)))
1685 (cons doc (cond (compiled)
1686 (body (list nil))))
1687 compiled))))))
1688
1689(defun byte-compile-constants-vector ()
1690 ;; Builds the constants-vector from the current variables and constants.
1691 ;; This modifies the constants from (const . nil) to (const . offset).
1692 ;; To keep the byte-codes to look up the vector as short as possible:
1693 ;; First 6 elements are vars, as there are one-byte varref codes for those.
1694 ;; Next up to byte-constant-limit are constants, still with one-byte codes.
1695 ;; Next variables again, to get 2-byte codes for variable lookup.
1696 ;; The rest of the constants and variables need 3-byte byte-codes.
1697 (let* ((i -1)
1698 (rest (nreverse byte-compile-variables)) ; nreverse because the first
1699 (other (nreverse byte-compile-constants)) ; vars often are used most.
1700 ret tmp
1701 (limits '(5 ; Use the 1-byte varref codes,
1702 63 ; 1-constlim ; 1-byte byte-constant codes,
1703 255 ; 2-byte varref codes,
1704 65535)) ; 3-byte codes for the rest.
1705 limit)
1706 (while (or rest other)
1707 (setq limit (car limits))
1708 (while (and rest (not (eq i limit)))
1709 (if (setq tmp (assq (car (car rest)) ret))
1710 (setcdr (car rest) (cdr tmp))
1711 (setcdr (car rest) (setq i (1+ i)))
1712 (setq ret (cons (car rest) ret)))
1713 (setq rest (cdr rest)))
1714 (setq limits (cdr limits)
1715 rest (prog1 other
1716 (setq other rest))))
1717 (apply 'vector (nreverse (mapcar 'car ret)))))
1718
1719;; Given an expression FORM, compile it and return an equivalent byte-code
1720;; expression (a call to the function byte-code).
1721(defun byte-compile-top-level (form &optional for-effect output-type)
1722 ;; OUTPUT-TYPE advises about how form is expected to be used:
1723 ;; 'eval or nil -> a single form,
1724 ;; 'progn or t -> a list of forms,
1725 ;; 'lambda -> body of a lambda,
1726 ;; 'file -> used at file-level.
1727 (let ((byte-compile-constants nil)
1728 (byte-compile-variables nil)
1729 (byte-compile-tag-number 0)
1730 (byte-compile-depth 0)
1731 (byte-compile-maxdepth 0)
1732 (byte-compile-output nil))
1733 (if (memq byte-optimize '(t source))
1734 (setq form (byte-optimize-form form for-effect)))
1735 (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
1736 (setq form (nth 1 form)))
1737 (if (and (eq 'byte-code (car-safe form))
1738 (not (memq byte-optimize '(t byte)))
1739 (stringp (nth 1 form)) (vectorp (nth 2 form))
1740 (natnump (nth 3 form)))
1741 form
1742 (byte-compile-form form for-effect)
1743 (byte-compile-out-toplevel for-effect output-type))))
1744
1745(defun byte-compile-out-toplevel (&optional for-effect output-type)
1746 (if for-effect
1747 ;; The stack is empty. Push a value to be returned from (byte-code ..).
1748 (if (eq (car (car byte-compile-output)) 'byte-discard)
1749 (setq byte-compile-output (cdr byte-compile-output))
1750 (byte-compile-push-constant
1751 ;; Push any constant - preferably one which already is used, and
1752 ;; a number or symbol - ie not some big sequence. The return value
1753 ;; isn't returned, but it would be a shame if some textually large
1754 ;; constant was not optimized away because we chose to return it.
1755 (and (not (assq nil byte-compile-constants)) ; Nil is often there.
1756 (let ((tmp (reverse byte-compile-constants)))
1757 (while (and tmp (not (or (symbolp (car (car tmp)))
1758 (numberp (car (car tmp))))))
1759 (setq tmp (cdr tmp)))
1760 (car (car tmp)))))))
1761 (byte-compile-out 'byte-return 0)
1762 (setq byte-compile-output (nreverse byte-compile-output))
1763 (if (memq byte-optimize '(t byte))
1764 (setq byte-compile-output
1765 (byte-optimize-lapcode byte-compile-output for-effect)))
1766
1767 ;; Decompile trivial functions:
1768 ;; only constants and variables, or a single funcall except in lambdas.
1769 ;; Except for Lisp_Compiled objects, forms like (foo "hi")
1770 ;; are still quicker than (byte-code "..." [foo "hi"] 2).
1771 ;; Note that even (quote foo) must be parsed just as any subr by the
1772 ;; interpreter, so quote should be compiled into byte-code in some contexts.
1773 ;; What to leave uncompiled:
1774 ;; lambda -> a single atom.
1775 ;; eval -> atom, quote or (function atom atom atom)
1776 ;; progn -> as <<same-as-eval>> or (progn <<same-as-eval>> atom)
1777 ;; file -> as progn, but takes both quotes and atoms, and longer forms.
1778 (let (rest
1779 (maycall (not (eq output-type 'lambda))) ; t if we may make a funcall.
1780 tmp body)
1781 (cond
1782 ;; #### This should be split out into byte-compile-nontrivial-function-p.
1783 ((or (nthcdr (if (eq output-type 'file) 50 8) byte-compile-output)
1784 (assq 'TAG byte-compile-output) ; Not necessary, but speeds up a bit.
1785 (not (setq tmp (assq 'byte-return byte-compile-output)))
1786 (progn
1787 (setq rest (nreverse
1788 (cdr (memq tmp (reverse byte-compile-output)))))
1789 (while (cond
1790 ((memq (car (car rest)) '(byte-varref byte-constant))
1791 (setq tmp (car (cdr (car rest))))
1792 (if (if (eq (car (car rest)) 'byte-constant)
1793 (or (consp tmp)
1794 (and (symbolp tmp)
1795 (not (memq tmp '(nil t))))))
1796 (if maycall
1797 (setq body (cons (list 'quote tmp) body)))
1798 (setq body (cons tmp body))))
1799 ((and maycall
1800 ;; Allow a funcall if at most one atom follows it.
1801 (null (nthcdr 3 rest))
1802 (setq tmp (get (car (car rest)) 'byte-opcode-invert))
1803 (or (null (cdr rest))
1804 (and (memq output-type '(file progn t))
1805 (cdr (cdr rest))
1806 (eq (car (nth 1 rest)) 'byte-discard)
1807 (progn (setq rest (cdr rest)) t))))
1808 (setq maycall nil) ; Only allow one real function call.
1809 (setq body (nreverse body))
1810 (setq body (list
1811 (if (and (eq tmp 'funcall)
1812 (eq (car-safe (car body)) 'quote))
1813 (cons (nth 1 (car body)) (cdr body))
1814 (cons tmp body))))
1815 (or (eq output-type 'file)
1816 (not (delq nil (mapcar 'consp (cdr (car body))))))))
1817 (setq rest (cdr rest)))
1818 rest)
1819 (and (consp (car body)) (eq output-type 'lambda)))
1820 (let ((byte-compile-vector (byte-compile-constants-vector)))
1821 (list 'byte-code (byte-compile-lapcode byte-compile-output)
1822 byte-compile-vector byte-compile-maxdepth)))
1823 ;; it's a trivial function
1824 ((cdr body) (cons 'progn (nreverse body)))
1825 ((car body)))))
1826
1827;; Given BODY, compile it and return a new body.
1828(defun byte-compile-top-level-body (body &optional for-effect)
1829 (setq body (byte-compile-top-level (cons 'progn body) for-effect t))
1830 (cond ((eq (car-safe body) 'progn)
1831 (cdr body))
1832 (body
1833 (list body))))
1834
1835;; This is the recursive entry point for compiling each subform of an
1836;; expression.
1837;; If for-effect is non-nil, byte-compile-form will output a byte-discard
1838;; before terminating (ie no value will be left on the stack).
1839;; A byte-compile handler may, when for-effect is non-nil, choose output code
1840;; which does not leave a value on the stack, and then set for-effect to nil
1841;; (to prevent byte-compile-form from outputting the byte-discard).
1842;; If a handler wants to call another handler, it should do so via
1843;; byte-compile-form, or take extreme care to handle for-effect correctly.
1844;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
1845;;
1846(defun byte-compile-form (form &optional for-effect)
1847 (setq form (macroexpand form byte-compile-macro-environment))
1848 (cond ((not (consp form))
1849 (cond ((or (not (symbolp form)) (memq form '(nil t)))
1850 (byte-compile-constant form))
1851 ((and for-effect byte-compile-delete-errors)
1852 (setq for-effect nil))
1853 (t (byte-compile-variable-ref 'byte-varref form))))
1854 ((symbolp (car form))
1855 (let* ((fn (car form))
1856 (handler (get fn 'byte-compile)))
1857 (if (and handler
1858 (or (byte-compile-version-cond
1859 byte-compile-generate-emacs19-bytecodes)
1860 (not (get (get fn 'byte-opcode) 'emacs19-opcode))))
1861 (funcall handler form)
1862 (if (memq 'callargs byte-compile-warnings)
1863 (byte-compile-callargs-warn form))
1864 (byte-compile-normal-call form))))
1865 ((and (or (compiled-function-p (car form))
1866 (eq (car-safe (car form)) 'lambda))
1867 ;; if the form comes out the same way it went in, that's
1868 ;; because it was malformed, and we couldn't unfold it.
1869 (not (eq form (setq form (byte-compile-unfold-lambda form)))))
1870 (byte-compile-form form for-effect)
1871 (setq for-effect nil))
1872 ((byte-compile-normal-call form)))
1873 (if for-effect
1874 (byte-compile-discard)))
1875
1876(defun byte-compile-normal-call (form)
1877 (if byte-compile-generate-call-tree
1878 (byte-compile-annotate-call-tree form))
1879 (byte-compile-push-constant (car form))
1880 (mapcar 'byte-compile-form (cdr form)) ; wasteful, but faster.
1881 (byte-compile-out 'byte-call (length (cdr form))))
1882
1883(defun byte-compile-variable-ref (base-op var)
1884 (if (or (not (symbolp var)) (memq var '(nil t)))
1885 (byte-compile-warn (if (eq base-op 'byte-varbind)
1886 "Attempt to let-bind %s %s"
1887 "Variable reference to %s %s")
1888 (if (symbolp var) "constant" "nonvariable")
1889 (prin1-to-string var))
1890 (if (memq 'free-vars byte-compile-warnings)
1891 (if (eq base-op 'byte-varbind)
1892 (setq byte-compile-bound-variables
1893 (cons var byte-compile-bound-variables))
1894 (or (boundp var)
1895 (memq var byte-compile-bound-variables)
1896 (if (eq base-op 'byte-varset)
1897 (or (memq var byte-compile-free-assignments)
1898 (progn
1899 (byte-compile-warn "assignment to free variable %s" var)
1900 (setq byte-compile-free-assignments
1901 (cons var byte-compile-free-assignments))))
1902 (or (memq var byte-compile-free-references)
1903 (progn
1904 (byte-compile-warn "reference to free variable %s" var)
1905 (setq byte-compile-free-references
1906 (cons var byte-compile-free-references)))))))))
1907 (let ((tmp (assq var byte-compile-variables)))
1908 (or tmp
1909 (setq tmp (list var)
1910 byte-compile-variables (cons tmp byte-compile-variables)))
1911 (byte-compile-out base-op tmp)))
1912
1913(defmacro byte-compile-get-constant (const)
1914 (` (or (if (stringp (, const))
1915 (assoc (, const) byte-compile-constants)
1916 (assq (, const) byte-compile-constants))
1917 (car (setq byte-compile-constants
1918 (cons (list (, const)) byte-compile-constants))))))
1919
1920;; Use this when the value of a form is a constant. This obeys for-effect.
1921(defun byte-compile-constant (const)
1922 (if for-effect
1923 (setq for-effect nil)
1924 (byte-compile-out 'byte-constant (byte-compile-get-constant const))))
1925
1926;; Use this for a constant that is not the value of its containing form.
1927;; This ignores for-effect.
1928(defun byte-compile-push-constant (const)
1929 (let ((for-effect nil))
1930 (inline (byte-compile-constant const))))
1931
1932
1933;; Compile those primitive ordinary functions
1934;; which have special byte codes just for speed.
1935
1936(defmacro byte-defop-compiler (function &optional compile-handler)
1937 ;; add a compiler-form for FUNCTION.
1938 ;; If function is a symbol, then the variable "byte-SYMBOL" must name
1939 ;; the opcode to be used. If function is a list, the first element
1940 ;; is the function and the second element is the bytecode-symbol.
1941 ;; COMPILE-HANDLER is the function to use to compile this byte-op, or
1942 ;; may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2.
1943 ;; If it is nil, then the handler is "byte-compile-SYMBOL."
1944 (let (opcode)
1945 (if (symbolp function)
1946 (setq opcode (intern (concat "byte-" (symbol-name function))))
1947 (setq opcode (car (cdr function))
1948 function (car function)))
1949 (let ((fnform
1950 (list 'put (list 'quote function) ''byte-compile
1951 (list 'quote
1952 (or (cdr (assq compile-handler
1953 '((0 . byte-compile-no-args)
1954 (1 . byte-compile-one-arg)
1955 (2 . byte-compile-two-args)
1956 (3 . byte-compile-three-args)
1957 (0-1 . byte-compile-zero-or-one-arg)
1958 (1-2 . byte-compile-one-or-two-args)
1959 (2-3 . byte-compile-two-or-three-args)
1960 )))
1961 compile-handler
1962 (intern (concat "byte-compile-"
1963 (symbol-name function))))))))
1964 (if opcode
1965 (list 'progn fnform
1966 (list 'put (list 'quote function)
1967 ''byte-opcode (list 'quote opcode))
1968 (list 'put (list 'quote opcode)
1969 ''byte-opcode-invert (list 'quote function)))
1970 fnform))))
1971
1972(defmacro byte-defop-compiler19 (function &optional compile-handler)
1973 ;; Just like byte-defop-compiler, but defines an opcode that will only
1974 ;; be used when byte-compile-generate-emacs19-bytecodes is true.
1975 (if (and (byte-compile-single-version)
1976 (not byte-compile-generate-emacs19-bytecodes))
1977 nil
1978 (list 'progn
1979 (list 'put
1980 (list 'quote
1981 (or (car (cdr-safe function))
1982 (intern (concat "byte-"
1983 (symbol-name (or (car-safe function) function))))))
1984 ''emacs19-opcode t)
1985 (list 'byte-defop-compiler function compile-handler))))
1986
1987(defmacro byte-defop-compiler-1 (function &optional compile-handler)
1988 (list 'byte-defop-compiler (list function nil) compile-handler))
1989
1990
1991(put 'byte-call 'byte-opcode-invert 'funcall)
1992(put 'byte-list1 'byte-opcode-invert 'list)
1993(put 'byte-list2 'byte-opcode-invert 'list)
1994(put 'byte-list3 'byte-opcode-invert 'list)
1995(put 'byte-list4 'byte-opcode-invert 'list)
1996(put 'byte-listN 'byte-opcode-invert 'list)
1997(put 'byte-concat2 'byte-opcode-invert 'concat)
1998(put 'byte-concat3 'byte-opcode-invert 'concat)
1999(put 'byte-concat4 'byte-opcode-invert 'concat)
2000(put 'byte-concatN 'byte-opcode-invert 'concat)
2001(put 'byte-insertN 'byte-opcode-invert 'insert)
2002
2003(byte-defop-compiler (dot byte-point) 0)
2004(byte-defop-compiler (dot-max byte-point-max) 0)
2005(byte-defop-compiler (dot-min byte-point-min) 0)
2006(byte-defop-compiler point 0)
2007;;(byte-defop-compiler mark 0) ;; obsolete
2008(byte-defop-compiler point-max 0)
2009(byte-defop-compiler point-min 0)
2010(byte-defop-compiler following-char 0)
2011(byte-defop-compiler preceding-char 0)
2012(byte-defop-compiler current-column 0)
2013(byte-defop-compiler eolp 0)
2014(byte-defop-compiler eobp 0)
2015(byte-defop-compiler bolp 0)
2016(byte-defop-compiler bobp 0)
2017(byte-defop-compiler current-buffer 0)
2018;;(byte-defop-compiler read-char 0) ;; obsolete
2019(byte-defop-compiler interactive-p 0)
2020(byte-defop-compiler19 widen 0)
2021(byte-defop-compiler19 end-of-line 0-1)
2022(byte-defop-compiler19 forward-char 0-1)
2023(byte-defop-compiler19 forward-line 0-1)
2024(byte-defop-compiler symbolp 1)
2025(byte-defop-compiler consp 1)
2026(byte-defop-compiler stringp 1)
2027(byte-defop-compiler listp 1)
2028(byte-defop-compiler not 1)
2029(byte-defop-compiler (null byte-not) 1)
2030(byte-defop-compiler car 1)
2031(byte-defop-compiler cdr 1)
2032(byte-defop-compiler length 1)
2033(byte-defop-compiler symbol-value 1)
2034(byte-defop-compiler symbol-function 1)
2035(byte-defop-compiler (1+ byte-add1) 1)
2036(byte-defop-compiler (1- byte-sub1) 1)
2037(byte-defop-compiler goto-char 1)
2038(byte-defop-compiler char-after 1)
2039(byte-defop-compiler set-buffer 1)
2040;;(byte-defop-compiler set-mark 1) ;; obsolete
2041(byte-defop-compiler19 forward-word 1)
2042(byte-defop-compiler19 char-syntax 1)
2043(byte-defop-compiler19 nreverse 1)
2044(byte-defop-compiler19 car-safe 1)
2045(byte-defop-compiler19 cdr-safe 1)
2046(byte-defop-compiler19 numberp 1)
2047(byte-defop-compiler19 integerp 1)
2048(byte-defop-compiler19 skip-chars-forward 1-2)
2049(byte-defop-compiler19 skip-chars-backward 1-2)
2050(byte-defop-compiler (eql byte-eq) 2)
2051(byte-defop-compiler eq 2)
2052(byte-defop-compiler memq 2)
2053(byte-defop-compiler cons 2)
2054(byte-defop-compiler aref 2)
2055(byte-defop-compiler set 2)
2056(byte-defop-compiler (= byte-eqlsign) 2)
2057(byte-defop-compiler (< byte-lss) 2)
2058(byte-defop-compiler (> byte-gtr) 2)
2059(byte-defop-compiler (<= byte-leq) 2)
2060(byte-defop-compiler (>= byte-geq) 2)
2061(byte-defop-compiler get 2)
2062(byte-defop-compiler nth 2)
2063(byte-defop-compiler substring 2-3)
2064(byte-defop-compiler (move-marker byte-set-marker) 2-3)
2065(byte-defop-compiler19 set-marker 2-3)
2066(byte-defop-compiler19 match-beginning 1)
2067(byte-defop-compiler19 match-end 1)
2068(byte-defop-compiler19 upcase 1)
2069(byte-defop-compiler19 downcase 1)
2070(byte-defop-compiler19 string= 2)
2071(byte-defop-compiler19 string< 2)
2072(byte-defop-compiler (string-equal byte-string=) 2)
2073(byte-defop-compiler (string-lessp byte-string<) 2)
2074(byte-defop-compiler19 equal 2)
2075(byte-defop-compiler19 nthcdr 2)
2076(byte-defop-compiler19 elt 2)
2077(byte-defop-compiler19 member 2)
2078(byte-defop-compiler19 assq 2)
2079(byte-defop-compiler (rplaca byte-setcar) 2)
2080(byte-defop-compiler (rplacd byte-setcdr) 2)
2081(byte-defop-compiler19 setcar 2)
2082(byte-defop-compiler19 setcdr 2)
2083(byte-defop-compiler19 buffer-substring 2)
2084(byte-defop-compiler19 delete-region 2)
2085(byte-defop-compiler19 narrow-to-region 2)
2086(byte-defop-compiler (mod byte-rem) 2)
2087(byte-defop-compiler19 (% byte-rem) 2)
2088(byte-defop-compiler aset 3)
2089
2090(byte-defop-compiler max byte-compile-associative)
2091(byte-defop-compiler min byte-compile-associative)
2092(byte-defop-compiler (+ byte-plus) byte-compile-associative)
2093(byte-defop-compiler19 (* byte-mult) byte-compile-associative)
2094
2095;;####(byte-defop-compiler19 move-to-column 1)
2096(byte-defop-compiler-1 interactive byte-compile-noop)
2097
2098
2099(defun byte-compile-subr-wrong-args (form n)
2100 (byte-compile-warn "%s called with %d arg%s, but requires %s"
2101 (car form) (length (cdr form))
2102 (if (= 1 (length (cdr form))) "" "s") n)
2103 ;; get run-time wrong-number-of-args error.
2104 (byte-compile-normal-call form))
2105
2106(defun byte-compile-no-args (form)
2107 (if (not (= (length form) 1))
2108 (byte-compile-subr-wrong-args form "none")
2109 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2110
2111(defun byte-compile-one-arg (form)
2112 (if (not (= (length form) 2))
2113 (byte-compile-subr-wrong-args form 1)
2114 (byte-compile-form (car (cdr form))) ;; Push the argument
2115 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2116
2117(defun byte-compile-two-args (form)
2118 (if (not (= (length form) 3))
2119 (byte-compile-subr-wrong-args form 2)
2120 (byte-compile-form (car (cdr form))) ;; Push the arguments
2121 (byte-compile-form (nth 2 form))
2122 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2123
2124(defun byte-compile-three-args (form)
2125 (if (not (= (length form) 4))
2126 (byte-compile-subr-wrong-args form 3)
2127 (byte-compile-form (car (cdr form))) ;; Push the arguments
2128 (byte-compile-form (nth 2 form))
2129 (byte-compile-form (nth 3 form))
2130 (byte-compile-out (get (car form) 'byte-opcode) 0)))
2131
2132(defun byte-compile-zero-or-one-arg (form)
2133 (let ((len (length form)))
2134 (cond ((= len 1) (byte-compile-one-arg (append form '(nil))))
2135 ((= len 2) (byte-compile-one-arg form))
2136 (t (byte-compile-subr-wrong-args form "0-1")))))
2137
2138(defun byte-compile-one-or-two-args (form)
2139 (let ((len (length form)))
2140 (cond ((= len 2) (byte-compile-two-args (append form '(nil))))
2141 ((= len 3) (byte-compile-two-args form))
2142 (t (byte-compile-subr-wrong-args form "1-2")))))
2143
2144(defun byte-compile-two-or-three-args (form)
2145 (let ((len (length form)))
2146 (cond ((= len 3) (byte-compile-three-args (append form '(nil))))
2147 ((= len 4) (byte-compile-three-args form))
2148 (t (byte-compile-subr-wrong-args form "2-3")))))
2149
2150(defun byte-compile-noop (form)
2151 (byte-compile-constant nil))
2152
2153(defun byte-compile-discard ()
2154 (byte-compile-out 'byte-discard 0))
2155
2156
2157;; Compile a function that accepts one or more args and is right-associative.
2158(defun byte-compile-associative (form)
2159 (if (cdr form)
2160 (let ((opcode (get (car form) 'byte-opcode)))
2161 ;; To compile all the args first may enable some optimizaions.
2162 (mapcar 'byte-compile-form (setq form (cdr form)))
2163 (while (setq form (cdr form))
2164 (byte-compile-out opcode 0)))
2165 (byte-compile-constant (eval form))))
2166
2167
2168;; more complicated compiler macros
2169
2170(byte-defop-compiler list)
2171(byte-defop-compiler concat)
2172(byte-defop-compiler fset)
2173(byte-defop-compiler (indent-to-column byte-indent-to) byte-compile-indent-to)
2174(byte-defop-compiler indent-to)
2175(byte-defop-compiler insert)
2176(byte-defop-compiler-1 function byte-compile-function-form)
2177(byte-defop-compiler-1 - byte-compile-minus)
2178(byte-defop-compiler19 (/ byte-quo) byte-compile-quo)
2179(byte-defop-compiler19 nconc)
2180(byte-defop-compiler-1 beginning-of-line)
2181
2182(defun byte-compile-list (form)
2183 (let ((count (length (cdr form))))
2184 (cond ((= count 0)
2185 (byte-compile-constant nil))
2186 ((< count 5)
2187 (mapcar 'byte-compile-form (cdr form))
2188 (byte-compile-out
2189 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- count)) 0))
2190 ((and (< count 256) (byte-compile-version-cond
2191 byte-compile-generate-emacs19-bytecodes))
2192 (mapcar 'byte-compile-form (cdr form))
2193 (byte-compile-out 'byte-listN count))
2194 (t (byte-compile-normal-call form)))))
2195
2196(defun byte-compile-concat (form)
2197 (let ((count (length (cdr form))))
2198 (cond ((and (< 1 count) (< count 5))
2199 (mapcar 'byte-compile-form (cdr form))
2200 (byte-compile-out
2201 (aref [byte-concat2 byte-concat3 byte-concat4] (- count 2))
2202 0))
2203 ;; Concat of one arg is not a no-op if arg is not a string.
2204 ((= count 0)
2205 (byte-compile-form ""))
2206 ((and (< count 256) (byte-compile-version-cond
2207 byte-compile-generate-emacs19-bytecodes))
2208 (mapcar 'byte-compile-form (cdr form))
2209 (byte-compile-out 'byte-concatN count))
2210 ((byte-compile-normal-call form)))))
2211
2212(defun byte-compile-minus (form)
2213 (if (null (setq form (cdr form)))
2214 (byte-compile-constant 0)
2215 (byte-compile-form (car form))
2216 (if (cdr form)
2217 (while (setq form (cdr form))
2218 (byte-compile-form (car form))
2219 (byte-compile-out 'byte-diff 0))
2220 (byte-compile-out 'byte-negate 0))))
2221
2222(defun byte-compile-quo (form)
2223 (let ((len (length form)))
2224 (cond ((<= len 2)
2225 (byte-compile-subr-wrong-args form "2 or more"))
2226 (t
2227 (byte-compile-form (car (setq form (cdr form))))
2228 (while (setq form (cdr form))
2229 (byte-compile-form (car form))
2230 (byte-compile-out 'byte-quo 0))))))
2231
2232(defun byte-compile-nconc (form)
2233 (let ((len (length form)))
2234 (cond ((= len 1)
2235 (byte-compile-constant nil))
2236 ((= len 2)
2237 ;; nconc of one arg is a noop, even if that arg isn't a list.
2238 (byte-compile-form (nth 1 form)))
2239 (t
2240 (byte-compile-form (car (setq form (cdr form))))
2241 (while (setq form (cdr form))
2242 (byte-compile-form (car form))
2243 (byte-compile-out 'byte-nconc 0))))))
2244
2245(defun byte-compile-fset (form)
2246 ;; warn about forms like (fset 'foo '(lambda () ...))
2247 ;; (where the lambda expression is non-trivial...)
2248 (let ((fn (nth 2 form))
2249 body)
2250 (if (and (eq (car-safe fn) 'quote)
2251 (eq (car-safe (setq fn (nth 1 fn))) 'lambda))
2252 (progn
2253 (setq body (cdr (cdr fn)))
2254 (if (stringp (car body)) (setq body (cdr body)))
2255 (if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
2256 (if (and (consp (car body))
2257 (not (eq 'byte-code (car (car body)))))
2258 (byte-compile-warn
2259 "A quoted lambda form is the second argument of fset. This is probably
2260 not what you want, as that lambda cannot be compiled. Consider using
2261 the syntax (function (lambda (...) ...)) instead.")))))
2262 (byte-compile-two-args form))
2263
2264(defun byte-compile-funarg (form)
2265 ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..)
2266 ;; for cases where it's guarenteed that first arg will be used as a lambda.
2267 (byte-compile-normal-call
2268 (let ((fn (nth 1 form)))
2269 (if (and (eq (car-safe fn) 'quote)
2270 (eq (car-safe (nth 1 fn)) 'lambda))
2271 (cons (car form)
2272 (cons (cons 'function (cdr fn))
2273 (cdr (cdr form))))
2274 form))))
2275
2276;; (function foo) must compile like 'foo, not like (symbol-function 'foo).
2277;; Otherwise it will be incompatible with the interpreter,
2278;; and (funcall (function foo)) will lose with autoloads.
2279
2280(defun byte-compile-function-form (form)
2281 (byte-compile-constant
2282 (cond ((symbolp (nth 1 form))
2283 (nth 1 form))
2284 ;; If we're not allowed to use #[] syntax, then output a form like
2285 ;; '(lambda (..) (byte-code ..)) instead of a call to make-byte-code.
2286 ;; In this situation, calling make-byte-code at run-time will usually
2287 ;; be less efficient than processing a call to byte-code.
2288 ((byte-compile-version-cond byte-compile-emacs18-compatibility)
2289 (byte-compile-byte-code-unmake (byte-compile-lambda (nth 1 form))))
2290 ((byte-compile-lambda (nth 1 form))))))
2291
2292(defun byte-compile-indent-to (form)
2293 (let ((len (length form)))
2294 (cond ((= len 2)
2295 (byte-compile-form (car (cdr form)))
2296 (byte-compile-out 'byte-indent-to 0))
2297 ((= len 3)
2298 ;; no opcode for 2-arg case.
2299 (byte-compile-normal-call form))
2300 (t
2301 (byte-compile-subr-wrong-args form "1-2")))))
2302
2303(defun byte-compile-insert (form)
2304 (cond ((null (cdr form))
2305 (byte-compile-constant nil))
2306 ((and (byte-compile-version-cond
2307 byte-compile-generate-emacs19-bytecodes)
2308 (<= (length form) 256))
2309 (mapcar 'byte-compile-form (cdr form))
2310 (if (cdr (cdr form))
2311 (byte-compile-out 'byte-insertN (length (cdr form)))
2312 (byte-compile-out 'byte-insert 0)))
2313 ((memq t (mapcar 'consp (cdr (cdr form))))
2314 (byte-compile-normal-call form))
2315 ;; We can split it; there is no function call after inserting 1st arg.
2316 (t
2317 (while (setq form (cdr form))
2318 (byte-compile-form (car form))
2319 (byte-compile-out 'byte-insert 0)
2320 (if (cdr form)
2321 (byte-compile-discard))))))
2322
2323(defun byte-compile-beginning-of-line (form)
2324 (if (not (byte-compile-constp (nth 1 form)))
2325 (byte-compile-normal-call form)
2326 (byte-compile-form
2327 (list 'forward-line
2328 (if (integerp (setq form (or (eval (nth 1 form)) 1)))
2329 (1- form)
2330 (byte-compile-warn "Non-numeric arg to beginning-of-line: %s"
2331 form)
2332 (list '1- (list 'quote form))))
2333 t)
2334 (byte-compile-constant nil)))
2335
2336
2337(byte-defop-compiler-1 setq)
2338(byte-defop-compiler-1 setq-default)
2339(byte-defop-compiler-1 quote)
2340(byte-defop-compiler-1 quote-form)
2341
2342(defun byte-compile-setq (form)
2343 (let ((args (cdr form)))
2344 (if args
2345 (while args
2346 (byte-compile-form (car (cdr args)))
2347 (or for-effect (cdr (cdr args))
2348 (byte-compile-out 'byte-dup 0))
2349 (byte-compile-variable-ref 'byte-varset (car args))
2350 (setq args (cdr (cdr args))))
2351 ;; (setq), with no arguments.
2352 (byte-compile-form nil for-effect))
2353 (setq for-effect nil)))
2354
2355(defun byte-compile-setq-default (form)
2356 (byte-compile-form
2357 (cons 'set-default (cons (list 'quote (nth 1 form))
2358 (nthcdr 2 form)))))
2359
2360(defun byte-compile-quote (form)
2361 (byte-compile-constant (car (cdr form))))
2362
2363(defun byte-compile-quote-form (form)
2364 (byte-compile-constant (byte-compile-top-level (nth 1 form))))
2365
2366
2367;;; control structures
2368
2369(defun byte-compile-body (body &optional for-effect)
2370 (while (cdr body)
2371 (byte-compile-form (car body) t)
2372 (setq body (cdr body)))
2373 (byte-compile-form (car body) for-effect))
2374
2375(proclaim-inline byte-compile-body-do-effect)
2376(defun byte-compile-body-do-effect (body)
2377 (byte-compile-body body for-effect)
2378 (setq for-effect nil))
2379
2380(proclaim-inline byte-compile-form-do-effect)
2381(defun byte-compile-form-do-effect (form)
2382 (byte-compile-form form for-effect)
2383 (setq for-effect nil))
2384
2385(byte-defop-compiler-1 inline byte-compile-progn)
2386(byte-defop-compiler-1 progn)
2387(byte-defop-compiler-1 prog1)
2388(byte-defop-compiler-1 prog2)
2389(byte-defop-compiler-1 if)
2390(byte-defop-compiler-1 cond)
2391(byte-defop-compiler-1 and)
2392(byte-defop-compiler-1 or)
2393(byte-defop-compiler-1 while)
2394(byte-defop-compiler-1 funcall)
2395(byte-defop-compiler-1 apply byte-compile-funarg)
2396(byte-defop-compiler-1 mapcar byte-compile-funarg)
2397(byte-defop-compiler-1 mapatoms byte-compile-funarg)
2398(byte-defop-compiler-1 mapconcat byte-compile-funarg)
2399(byte-defop-compiler-1 let)
2400(byte-defop-compiler-1 let*)
2401
2402(defun byte-compile-progn (form)
2403 (byte-compile-body-do-effect (cdr form)))
2404
2405(defun byte-compile-prog1 (form)
2406 (byte-compile-form-do-effect (car (cdr form)))
2407 (byte-compile-body (cdr (cdr form)) t))
2408
2409(defun byte-compile-prog2 (form)
2410 (byte-compile-form (nth 1 form) t)
2411 (byte-compile-form-do-effect (nth 2 form))
2412 (byte-compile-body (cdr (cdr (cdr form))) t))
2413
2414(defmacro byte-compile-goto-if (cond discard tag)
2415 (` (byte-compile-goto
2416 (if (, cond)
2417 (if (, discard) 'byte-goto-if-not-nil 'byte-goto-if-not-nil-else-pop)
2418 (if (, discard) 'byte-goto-if-nil 'byte-goto-if-nil-else-pop))
2419 (, tag))))
2420
2421(defun byte-compile-if (form)
2422 (byte-compile-form (car (cdr form)))
2423 (if (null (nthcdr 3 form))
2424 ;; No else-forms
2425 (let ((donetag (byte-compile-make-tag)))
2426 (byte-compile-goto-if nil for-effect donetag)
2427 (byte-compile-form (nth 2 form) for-effect)
2428 (byte-compile-out-tag donetag))
2429 (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
2430 (byte-compile-goto 'byte-goto-if-nil elsetag)
2431 (byte-compile-form (nth 2 form) for-effect)
2432 (byte-compile-goto 'byte-goto donetag)
2433 (byte-compile-out-tag elsetag)
2434 (byte-compile-body (cdr (cdr (cdr form))) for-effect)
2435 (byte-compile-out-tag donetag)))
2436 (setq for-effect nil))
2437
2438(defun byte-compile-cond (clauses)
2439 (let ((donetag (byte-compile-make-tag))
2440 nexttag clause)
2441 (while (setq clauses (cdr clauses))
2442 (setq clause (car clauses))
2443 (cond ((or (eq (car clause) t)
2444 (and (eq (car-safe (car clause)) 'quote)
2445 (car-safe (cdr-safe (car clause)))))
2446 ;; Unconditional clause
2447 (setq clause (cons t clause)
2448 clauses nil))
2449 ((cdr clauses)
2450 (byte-compile-form (car clause))
2451 (if (null (cdr clause))
2452 ;; First clause is a singleton.
2453 (byte-compile-goto-if t for-effect donetag)
2454 (setq nexttag (byte-compile-make-tag))
2455 (byte-compile-goto 'byte-goto-if-nil nexttag)
2456 (byte-compile-body (cdr clause) for-effect)
2457 (byte-compile-goto 'byte-goto donetag)
2458 (byte-compile-out-tag nexttag)))))
2459 ;; Last clause
2460 (and (cdr clause) (not (eq (car clause) t))
2461 (progn (byte-compile-form (car clause))
2462 (byte-compile-goto-if nil for-effect donetag)
2463 (setq clause (cdr clause))))
2464 (byte-compile-body-do-effect clause)
2465 (byte-compile-out-tag donetag)))
2466
2467(defun byte-compile-and (form)
2468 (let ((failtag (byte-compile-make-tag))
2469 (args (cdr form)))
2470 (if (null args)
2471 (byte-compile-form-do-effect t)
2472 (while (cdr args)
2473 (byte-compile-form (car args))
2474 (byte-compile-goto-if nil for-effect failtag)
2475 (setq args (cdr args)))
2476 (byte-compile-form-do-effect (car args))
2477 (byte-compile-out-tag failtag))))
2478
2479(defun byte-compile-or (form)
2480 (let ((wintag (byte-compile-make-tag))
2481 (args (cdr form)))
2482 (if (null args)
2483 (byte-compile-form-do-effect nil)
2484 (while (cdr args)
2485 (byte-compile-form (car args))
2486 (byte-compile-goto-if t for-effect wintag)
2487 (setq args (cdr args)))
2488 (byte-compile-form-do-effect (car args))
2489 (byte-compile-out-tag wintag))))
2490
2491(defun byte-compile-while (form)
2492 (let ((endtag (byte-compile-make-tag))
2493 (looptag (byte-compile-make-tag)))
2494 (byte-compile-out-tag looptag)
2495 (byte-compile-form (car (cdr form)))
2496 (byte-compile-goto-if nil for-effect endtag)
2497 (byte-compile-body (cdr (cdr form)) t)
2498 (byte-compile-goto 'byte-goto looptag)
2499 (byte-compile-out-tag endtag)
2500 (setq for-effect nil)))
2501
2502(defun byte-compile-funcall (form)
2503 (mapcar 'byte-compile-form (cdr form))
2504 (byte-compile-out 'byte-call (length (cdr (cdr form)))))
2505
2506
2507(defun byte-compile-let (form)
2508 ;; First compute the binding values in the old scope.
2509 (let ((varlist (car (cdr form))))
2510 (while varlist
2511 (if (consp (car varlist))
2512 (byte-compile-form (car (cdr (car varlist))))
2513 (byte-compile-push-constant nil))
2514 (setq varlist (cdr varlist))))
2515 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
2516 (varlist (reverse (car (cdr form)))))
2517 (while varlist
2518 (byte-compile-variable-ref 'byte-varbind (if (consp (car varlist))
2519 (car (car varlist))
2520 (car varlist)))
2521 (setq varlist (cdr varlist)))
2522 (byte-compile-body-do-effect (cdr (cdr form)))
2523 (byte-compile-out 'byte-unbind (length (car (cdr form))))))
2524
2525(defun byte-compile-let* (form)
2526 (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope
2527 (varlist (copy-sequence (car (cdr form)))))
2528 (while varlist
2529 (if (atom (car varlist))
2530 (byte-compile-push-constant nil)
2531 (byte-compile-form (car (cdr (car varlist))))
2532 (setcar varlist (car (car varlist))))
2533 (byte-compile-variable-ref 'byte-varbind (car varlist))
2534 (setq varlist (cdr varlist)))
2535 (byte-compile-body-do-effect (cdr (cdr form)))
2536 (byte-compile-out 'byte-unbind (length (car (cdr form))))))
2537
2538
2539(byte-defop-compiler-1 /= byte-compile-negated)
2540(byte-defop-compiler-1 atom byte-compile-negated)
2541(byte-defop-compiler-1 nlistp byte-compile-negated)
2542
2543(put '/= 'byte-compile-negated-op '=)
2544(put 'atom 'byte-compile-negated-op 'consp)
2545(put 'nlistp 'byte-compile-negated-op 'listp)
2546
2547(defun byte-compile-negated (form)
2548 (byte-compile-form-do-effect (byte-compile-negation-optimizer form)))
2549
2550;; Even when optimization is off, /= is optimized to (not (= ...)).
2551(defun byte-compile-negation-optimizer (form)
2552 ;; an optimizer for forms where <form1> is less efficient than (not <form2>)
2553 (list 'not
2554 (cons (or (get (car form) 'byte-compile-negated-op)
2555 (error
2556 "compiler error: %s has no byte-compile-negated-op property"
2557 (car form)))
2558 (cdr form))))
2559
2560;;; other tricky macro-like special-forms
2561
2562(byte-defop-compiler-1 catch)
2563(byte-defop-compiler-1 unwind-protect)
2564(byte-defop-compiler-1 condition-case)
2565(byte-defop-compiler-1 save-excursion)
2566(byte-defop-compiler-1 save-restriction)
2567(byte-defop-compiler-1 save-window-excursion)
2568(byte-defop-compiler-1 with-output-to-temp-buffer)
2569
2570(defun byte-compile-catch (form)
2571 (byte-compile-form (car (cdr form)))
2572 (byte-compile-push-constant
2573 (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
2574 (byte-compile-out 'byte-catch 0))
2575
2576(defun byte-compile-unwind-protect (form)
2577 (byte-compile-push-constant
2578 (byte-compile-top-level-body (cdr (cdr form)) t))
2579 (byte-compile-out 'byte-unwind-protect 0)
2580 (byte-compile-form-do-effect (car (cdr form)))
2581 (byte-compile-out 'byte-unbind 1))
2582
2583(defun byte-compile-condition-case (form)
2584 (let* ((var (nth 1 form))
2585 (byte-compile-bound-variables
2586 (if var (cons var byte-compile-bound-variables)
2587 byte-compile-bound-variables)))
2588 (or (symbolp var)
2589 (byte-compile-warn
2590 "%s is not a variable-name or nil (in condition-case)" var))
2591 (byte-compile-push-constant var)
2592 (byte-compile-push-constant (byte-compile-top-level
2593 (nth 2 form) for-effect))
2594 (let ((clauses (cdr (cdr (cdr form))))
2595 compiled-clauses)
2596 (while clauses
2597 (let ((clause (car clauses)))
2598 (setq compiled-clauses
2599 (cons (cons (car clause)
2600 (byte-compile-top-level-body
2601 (cdr clause) for-effect))
2602 compiled-clauses)))
2603 (setq clauses (cdr clauses)))
2604 (byte-compile-push-constant (nreverse compiled-clauses)))
2605 (byte-compile-out 'byte-condition-case 0)))
2606
2607
2608(defun byte-compile-save-excursion (form)
2609 (byte-compile-out 'byte-save-excursion 0)
2610 (byte-compile-body-do-effect (cdr form))
2611 (byte-compile-out 'byte-unbind 1))
2612
2613(defun byte-compile-save-restriction (form)
2614 (byte-compile-out 'byte-save-restriction 0)
2615 (byte-compile-body-do-effect (cdr form))
2616 (byte-compile-out 'byte-unbind 1))
2617
2618(defun byte-compile-save-window-excursion (form)
2619 (byte-compile-push-constant
2620 (byte-compile-top-level-body (cdr form) for-effect))
2621 (byte-compile-out 'byte-save-window-excursion 0))
2622
2623(defun byte-compile-with-output-to-temp-buffer (form)
2624 (byte-compile-form (car (cdr form)))
2625 (byte-compile-out 'byte-temp-output-buffer-setup 0)
2626 (byte-compile-body (cdr (cdr form)))
2627 (byte-compile-out 'byte-temp-output-buffer-show 0))
2628
2629
2630;;; top-level forms elsewhere
2631
2632(byte-defop-compiler-1 defun)
2633(byte-defop-compiler-1 defmacro)
2634(byte-defop-compiler-1 defvar)
2635(byte-defop-compiler-1 defconst byte-compile-defvar)
2636(byte-defop-compiler-1 autoload)
2637(byte-defop-compiler-1 lambda byte-compile-lambda-form)
2638
2639(defun byte-compile-defun (form)
2640 ;; This is not used for file-level defuns with doc strings.
2641 (byte-compile-two-args ; Use this to avoid byte-compile-fset's warning.
2642 (list 'fset (list 'quote (nth 1 form))
2643 (byte-compile-byte-code-maker
2644 (byte-compile-lambda (cons 'lambda (cdr (cdr form)))))))
2645 (byte-compile-discard)
2646 (byte-compile-constant (nth 1 form)))
2647
2648(defun byte-compile-defmacro (form)
2649 ;; This is not used for file-level defmacros with doc strings.
2650 (byte-compile-body-do-effect
2651 (list (list 'fset (list 'quote (nth 1 form))
2652 (let ((code (byte-compile-byte-code-maker
2653 (byte-compile-lambda
2654 (cons 'lambda (cdr (cdr form)))))))
2655 (if (eq (car-safe code) 'make-byte-code)
2656 (list 'cons ''macro code)
2657 (list 'quote (cons 'macro (eval code))))))
2658 (list 'quote (nth 1 form)))))
2659
2660(defun byte-compile-defvar (form)
2661 ;; This is not used for file-level defvar/consts with doc strings.
2662 (let ((var (nth 1 form))
2663 (value (nth 2 form))
2664 (string (nth 3 form)))
2665 (if (memq 'free-vars byte-compile-warnings)
2666 (setq byte-compile-bound-variables
2667 (cons var byte-compile-bound-variables)))
2668 (byte-compile-body-do-effect
2669 (list (if (cdr (cdr form))
2670 (if (eq (car form) 'defconst)
2671 (list 'setq var value)
2672 (list 'or (list 'boundp (list 'quote var))
2673 (list 'setq var value))))
2674 (if string
2675 (list 'put (list 'quote var) ''variable-documentation string))
2676 (list 'quote var)))))
2677
2678(defun byte-compile-autoload (form)
2679 (and (byte-compile-constp (nth 1 form))
2680 (byte-compile-constp (nth 5 form))
2681 (eval (nth 5 form)) ; macro-p
2682 (not (fboundp (eval (nth 1 form))))
2683 (byte-compile-warn
2684 "The compiler ignores `autoload' except at top level. You should
2685 probably put the autoload of the macro `%s' at top-level."
2686 (eval (nth 1 form))))
2687 (byte-compile-normal-call form))
2688
2689;; Lambda's in valid places are handled as special cases by various code.
2690;; The ones that remain are errors.
2691(defun byte-compile-lambda-form (form)
2692 (error "`lambda' used as function name is invalid"))
2693
2694
2695;;; tags
2696
2697;; Note: Most operations will strip off the 'TAG, but it speeds up
2698;; optimization to have the 'TAG as a part of the tag.
2699;; Tags will be (TAG . (tag-number . stack-depth)).
2700(defun byte-compile-make-tag ()
2701 (list 'TAG (setq byte-compile-tag-number (1+ byte-compile-tag-number))))
2702
2703
2704(defun byte-compile-out-tag (tag)
2705 (setq byte-compile-output (cons tag byte-compile-output))
2706 (if (cdr (cdr tag))
2707 (progn
2708 ;; ## remove this someday
2709 (and byte-compile-depth
2710 (not (= (cdr (cdr tag)) byte-compile-depth))
2711 (error "bytecomp bug: depth conflict at tag %d" (car (cdr tag))))
2712 (setq byte-compile-depth (cdr (cdr tag))))
2713 (setcdr (cdr tag) byte-compile-depth)))
2714
2715(defun byte-compile-goto (opcode tag)
2716 (setq byte-compile-output (cons (cons opcode tag) byte-compile-output))
2717 (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
2718 (1- byte-compile-depth)
2719 byte-compile-depth))
2720 (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
2721 (1- byte-compile-depth))))
2722
2723(defun byte-compile-out (opcode offset)
2724 (setq byte-compile-output (cons (cons opcode offset) byte-compile-output))
2725 (cond ((eq opcode 'byte-call)
2726 (setq byte-compile-depth (- byte-compile-depth offset)))
2727 ((eq opcode 'byte-return)
2728 ;; This is actually an unnecessary case, because there should be
2729 ;; no more opcodes behind byte-return.
2730 (setq byte-compile-depth nil))
2731 (t
2732 (setq byte-compile-depth (+ byte-compile-depth
2733 (or (aref byte-stack+-info
2734 (symbol-value opcode))
2735 (- (1- offset))))
2736 byte-compile-maxdepth (max byte-compile-depth
2737 byte-compile-maxdepth))))
2738 ;;(if (< byte-compile-depth 0) (error "compiler error: stack underflow"))
2739 )
2740
2741
2742;;; call tree stuff
2743
2744(defun byte-compile-annotate-call-tree (form)
2745 (let (entry)
2746 ;; annotate the current call
2747 (if (setq entry (assq (car form) byte-compile-call-tree))
2748 (or (memq byte-compile-current-form (nth 1 entry)) ;callers
2749 (setcar (cdr entry)
2750 (cons byte-compile-current-form (nth 1 entry))))
2751 (setq byte-compile-call-tree
2752 (cons (list (car form) (list byte-compile-current-form) nil)
2753 byte-compile-call-tree)))
2754 ;; annotate the current function
2755 (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
2756 (or (memq (car form) (nth 2 entry)) ;called
2757 (setcar (cdr (cdr entry))
2758 (cons (car form) (nth 2 entry))))
2759 (setq byte-compile-call-tree
2760 (cons (list byte-compile-current-form nil (list (car form)))
2761 byte-compile-call-tree)))
2762 ))
2763
2764(defun byte-compile-report-call-tree (&optional filename)
2765 "Display a buffer describing which functions have been called, what functions
2766called them, and what functions they call. This buffer will list all functions
2767whose definitions have been compiled since this emacs session was started, as
2768well as all functions called by those functions.
2769
2770The call tree only lists functions called, not macros or inline functions
2771expanded. Those functions which the byte-code interpreter knows about directly
2772\(eq, cons, etc.\) are not reported.
2773
2774The call tree also lists those functions which are not known to be called
2775\(that is, to which no calls have been compiled.\) Functions which can be
2776invoked interactively are excluded from this list."
2777 (interactive)
2778 (message "Generating call tree...")
2779 (with-output-to-temp-buffer "*Call-Tree*"
2780 (set-buffer "*Call-Tree*")
2781 (erase-buffer)
2782 (message "Generating call tree (sorting on %s)..."
2783 byte-compile-call-tree-sort)
2784 (insert "Call tree for "
2785 (cond ((null byte-compile-current-file) (or filename "???"))
2786 ((stringp byte-compile-current-file)
2787 byte-compile-current-file)
2788 (t (buffer-name byte-compile-current-file)))
2789 " sorted on "
2790 (prin1-to-string byte-compile-call-tree-sort)
2791 ":\n\n")
2792 (if byte-compile-call-tree-sort
2793 (setq byte-compile-call-tree
2794 (sort byte-compile-call-tree
2795 (cond ((eq byte-compile-call-tree-sort 'callers)
2796 (function (lambda (x y) (< (length (nth 1 x))
2797 (length (nth 1 y))))))
2798 ((eq byte-compile-call-tree-sort 'calls)
2799 (function (lambda (x y) (< (length (nth 2 x))
2800 (length (nth 2 y))))))
2801 ((eq byte-compile-call-tree-sort 'calls+callers)
2802 (function (lambda (x y) (< (+ (length (nth 1 x))
2803 (length (nth 2 x)))
2804 (+ (length (nth 1 y))
2805 (length (nth 2 y)))))))
2806 ((eq byte-compile-call-tree-sort 'name)
2807 (function (lambda (x y) (string< (car x)
2808 (car y)))))
2809 (t (error "byte-compile-call-tree-sort: %s - unknown sort mode"
2810 byte-compile-call-tree-sort))))))
2811 (message "Generating call tree...")
2812 (let ((rest byte-compile-call-tree)
2813 (b (current-buffer))
2814 f p
2815 callers calls)
2816 (while rest
2817 (prin1 (car (car rest)) b)
2818 (setq callers (nth 1 (car rest))
2819 calls (nth 2 (car rest)))
2820 (insert "\t"
2821 (cond ((not (fboundp (setq f (car (car rest)))))
2822 (if (null f)
2823 " <top level>";; shouldn't insert nil then, actually -sk
2824 " <not defined>"))
2825 ((subrp (setq f (symbol-function f)))
2826 " <subr>")
2827 ((symbolp f)
2828 (format " ==> %s" f))
2829 ((compiled-function-p f)
2830 "<compiled function>")
2831 ((not (consp f))
2832 "<malformed function>")
2833 ((eq 'macro (car f))
2834 (if (or (compiled-function-p (cdr f))
2835 (assq 'byte-code (cdr (cdr (cdr f)))))
2836 " <compiled macro>"
2837 " <macro>"))
2838 ((assq 'byte-code (cdr (cdr f)))
2839 "<compiled lambda>")
2840 ((eq 'lambda (car f))
2841 "<function>")
2842 (t "???"))
2843 (format " (%d callers + %d calls = %d)"
2844 ;; Does the optimizer eliminate common subexpressions?-sk
2845 (length callers)
2846 (length calls)
2847 (+ (length callers) (length calls)))
2848 "\n")
2849 (if callers
2850 (progn
2851 (insert " called by:\n")
2852 (setq p (point))
2853 (insert " " (if (car callers)
2854 (mapconcat 'symbol-name callers ", ")
2855 "<top level>"))
2856 (let ((fill-prefix " "))
2857 (fill-region-as-paragraph p (point)))))
2858 (if calls
2859 (progn
2860 (insert " calls:\n")
2861 (setq p (point))
2862 (insert " " (mapconcat 'symbol-name calls ", "))
2863 (let ((fill-prefix " "))
2864 (fill-region-as-paragraph p (point)))))
2865 (insert "\n")
2866 (setq rest (cdr rest)))
2867
2868 (message "Generating call tree...(finding uncalled functions...)")
2869 (setq rest byte-compile-call-tree)
2870 (let ((uncalled nil))
2871 (while rest
2872 (or (nth 1 (car rest))
2873 (null (setq f (car (car rest))))
2874 (byte-compile-fdefinition f t)
2875 (commandp (byte-compile-fdefinition f nil))
2876 (setq uncalled (cons f uncalled)))
2877 (setq rest (cdr rest)))
2878 (if uncalled
2879 (let ((fill-prefix " "))
2880 (insert "Noninteractive functions not known to be called:\n ")
2881 (setq p (point))
2882 (insert (mapconcat 'symbol-name (nreverse uncalled) ", "))
2883 (fill-region-as-paragraph p (point)))))
2884 )
2885 (message "Generating call tree...done.")
2886 ))
2887
2888
2889;;; by crl@newton.purdue.edu
2890;;; Only works noninteractively.
2891(defun batch-byte-compile ()
2892 "Runs `byte-compile-file' on the files remaining on the command line.
2893Must be used only with -batch, and kills emacs on completion.
2894Each file will be processed even if an error occurred previously.
2895For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
2896 ;; command-line-args-left is what is left of the command line (from startup.el)
2897 (defvar command-line-args-left) ;Avoid 'free variable' warning
2898 (if (not noninteractive)
2899 (error "batch-byte-compile is to be used only with -batch"))
2900 (let ((error nil))
2901 (while command-line-args-left
2902 (if (file-directory-p (expand-file-name (car command-line-args-left)))
2903 (let ((files (directory-files (car command-line-args-left)))
2904 source dest)
2905 (while files
2906 (if (and (string-match elisp-source-extention-re (car files))
2907 (not (auto-save-file-name-p (car files)))
2908 (setq source (expand-file-name (car files)
2909 (car command-line-args-left)))
2910 (setq dest (byte-compile-dest-file source))
2911 (file-exists-p dest)
2912 (file-newer-than-file-p source dest))
2913 (if (null (batch-byte-compile-file source))
2914 (setq error t)))
2915 (setq files (cdr files))))
2916 (if (null (batch-byte-compile-file (car command-line-args-left)))
2917 (setq error t)))
2918 (setq command-line-args-left (cdr command-line-args-left)))
2919 (message "Done")
2920 (kill-emacs (if error 1 0))))
2921
2922(defun batch-byte-compile-file (file)
2923 (condition-case err
2924 (progn (byte-compile-file file) t)
2925 (error
2926 (message (if (cdr err)
2927 ">>Error occurred processing %s: %s (%s)"
2928 ">>Error occurred processing %s: %s")
2929 file
2930 (get (car err) 'error-message)
2931 (prin1-to-string (cdr err)))
2932 nil)))
2933
2934
2935(make-obsolete 'mod '%)
2936(make-obsolete 'dot 'point)
2937(make-obsolete 'dot-max 'point-max)
2938(make-obsolete 'dot-min 'point-min)
2939(make-obsolete 'dot-marker 'point-marker)
2940
2941(cond ((not (or (and (boundp 'epoch::version) epoch::version)
2942 (string-lessp emacs-version "19")))
2943 (make-obsolete 'buffer-flush-undo 'buffer-disable-undo)
2944 (make-obsolete 'baud-rate "use the baud-rate variable instead")
2945 ))
2946
2947(provide 'byte-compile)
2948
2949
2950;;; report metering (see the hacks in bytecode.c)
2951
2952(if (boundp 'byte-code-meter)
2953 (defun byte-compile-report-ops ()
2954 (defvar byte-code-meter)
2955 (with-output-to-temp-buffer "*Meter*"
2956 (set-buffer "*Meter*")
2957 (let ((i 0) n op off)
2958 (while (< i 256)
2959 (setq n (aref (aref byte-code-meter 0) i)
2960 off nil)
2961 (if t ;(not (zerop n))
2962 (progn
2963 (setq op i)
2964 (setq off nil)
2965 (cond ((< op byte-nth)
2966 (setq off (logand op 7))
2967 (setq op (logand op 248)))
2968 ((>= op byte-constant)
2969 (setq off (- op byte-constant)
2970 op byte-constant)))
2971 (setq op (aref byte-code-vector op))
2972 (insert (format "%-4d" i))
2973 (insert (symbol-name op))
2974 (if off (insert " [" (int-to-string off) "]"))
2975 (indent-to 40)
2976 (insert (int-to-string n) "\n")))
2977 (setq i (1+ i)))))))
2978
2979
2980;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when bytecomp compiles
2981;; itself, compile some of its most used recursive functions (at load time).
2982;;
2983(eval-when-compile
2984 (or (compiled-function-p (symbol-function 'byte-compile-form))
2985 (assq 'byte-code (symbol-function 'byte-compile-form))
2986 (let ((byte-optimize nil) ; do it fast
2987 (byte-compile-warnings nil))
2988 (mapcar '(lambda (x)
2989 (or noninteractive (message "compiling %s..." x))
2990 (byte-compile x)
2991 (or noninteractive (message "compiling %s...done" x)))
2992 '(byte-compile-normal-call
2993 byte-compile-form
2994 byte-compile-body
2995 ;; Inserted some more than necessary, to speed it up.
2996 byte-compile-top-level
2997 byte-compile-out-toplevel
2998 byte-compile-constant
2999 byte-compile-variable-ref))))
3000 nil)
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
new file mode 100644
index 00000000000..52ee8d61c3f
--- /dev/null
+++ b/lisp/emacs-lisp/disass.el
@@ -0,0 +1,224 @@
1;;; Disassembler for compiled Emacs Lisp code
2;;; Copyright (C) 1986 Free Software Foundation, Inc.
3;;; Original version by Doug Cutting (doug@csli.stanford.edu)
4;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
5;;; the new lapcode-based byte compiler.
6;;; Last modified 22-oct-91.
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 1, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING. If not, write to
22;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
24
25;;; The variable byte-code-vector is defined by the new bytecomp.el.
26;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
27(require 'byte-optimize)
28
29(defvar disassemble-column-1-indent 5 "*")
30(defvar disassemble-column-2-indent 10 "*")
31
32(defvar disassemble-recursive-indent 3 "*")
33
34(defun disassemble (object &optional buffer indent interactive-p)
35 "Print disassembled code for OBJECT in (optional) BUFFER.
36OBJECT can be a symbol defined as a function, or a function itself
37\(a lambda expression or a compiled-function object).
38If OBJECT is not already compiled, we compile it, but do not
39redefine OBJECT if it is a symbol."
40 (interactive (list (intern (completing-read "Disassemble function: "
41 obarray 'fboundp t))
42 nil 0 t))
43 (if (eq (car-safe object) 'byte-code)
44 (setq object (list 'lambda () object)))
45 (or indent (setq indent 0)) ;Default indent to zero
46 (save-excursion
47 (if (or interactive-p (null buffer))
48 (with-output-to-temp-buffer "*Disassemble*"
49 (set-buffer "*Disassemble*")
50 (disassemble-internal object indent (not interactive-p)))
51 (set-buffer buffer)
52 (disassemble-internal object indent nil)))
53 nil)
54
55
56(defun disassemble-internal (obj indent interactive-p)
57 (let ((macro 'nil)
58 (name 'nil)
59 (doc 'nil)
60 args)
61 (while (symbolp obj)
62 (setq name obj
63 obj (symbol-function obj)))
64 (if (subrp obj)
65 (error "Can't disassemble #<subr %s>" name))
66 (if (eq (car-safe obj) 'macro) ;handle macros
67 (setq macro t
68 obj (cdr obj)))
69 (if (and (listp obj) (not (eq (car obj) 'lambda)))
70 (error "not a function"))
71 (if (consp obj)
72 (if (assq 'byte-code obj)
73 nil
74 (if interactive-p (message (if name
75 "Compiling %s's definition..."
76 "Compiling definition...")
77 name))
78 (setq obj (byte-compile obj))
79 (if interactive-p (message "Done compiling. Disassembling..."))))
80 (cond ((consp obj)
81 (setq obj (cdr obj)) ;throw lambda away
82 (setq args (car obj)) ;save arg list
83 (setq obj (cdr obj)))
84 (t
85 (setq args (aref obj 0))))
86 (if (zerop indent) ; not a nested function
87 (progn
88 (indent-to indent)
89 (insert (format "byte code%s%s%s:\n"
90 (if (or macro name) " for" "")
91 (if macro " macro" "")
92 (if name (format " %s" name) "")))))
93 (let ((doc (if (consp obj)
94 (and (stringp (car obj)) (car obj))
95 (and (> (length obj) 4) (aref obj 4)))))
96 (if (and doc (stringp doc))
97 (progn (and (consp obj) (setq obj (cdr obj)))
98 (indent-to indent)
99 (princ " doc: " (current-buffer))
100 (if (string-match "\n" doc)
101 (setq doc (concat (substring doc 0 (match-beginning 0))
102 " ...")))
103 (insert doc "\n"))))
104 (indent-to indent)
105 (insert " args: ")
106 (prin1 args (current-buffer))
107 (insert "\n")
108 (let ((interactive (cond ((consp obj)
109 (assq 'interactive obj))
110 ((> (length obj) 5)
111 (list 'interactive (aref obj 5))))))
112 (if interactive
113 (progn
114 (setq interactive (nth 1 interactive))
115 (if (eq (car-safe (car-safe obj)) 'interactive)
116 (setq obj (cdr obj)))
117 (indent-to indent)
118 (insert " interactive: ")
119 (if (eq (car-safe interactive) 'byte-code)
120 (progn
121 (insert "\n")
122 (disassemble-1 interactive
123 (+ indent disassemble-recursive-indent)))
124 (let ((print-escape-newlines t))
125 (prin1 interactive (current-buffer))))
126 (insert "\n"))))
127 (cond ((and (consp obj) (assq 'byte-code obj))
128 (disassemble-1 (assq 'byte-code obj) indent))
129 ((compiled-function-p obj)
130 (disassemble-1 obj indent))
131 (t
132 (insert "Uncompiled body: ")
133 (let ((print-escape-newlines t))
134 (prin1 (if (cdr obj) (cons 'progn obj) (car obj))
135 (current-buffer))))))
136 (if interactive-p
137 (message "")))
138
139
140(defun disassemble-1 (obj indent)
141 "Prints the byte-code call OBJ in the current buffer.
142OBJ should be a call to BYTE-CODE generated by the byte compiler."
143 (let (bytes constvec)
144 (if (consp obj)
145 (setq bytes (car (cdr obj)) ;the byte code
146 constvec (car (cdr (cdr obj)))) ;constant vector
147 (setq bytes (aref obj 1)
148 constvec (aref obj 2)))
149 (let ((lap (byte-decompile-bytecode bytes constvec))
150 op arg opname)
151 (let ((tagno 0)
152 tmp
153 (lap lap))
154 (while (setq tmp (assq 'TAG lap))
155 (setcar (cdr tmp) (setq tagno (1+ tagno)))
156 (setq lap (cdr (memq tmp lap)))))
157 (while lap
158 (setq op (car (car lap))
159 arg (cdr (car lap)))
160 (indent-to indent)
161 (if (eq 'TAG op)
162 (insert (int-to-string (car arg)) ":")
163
164 (indent-to (+ indent disassemble-column-1-indent))
165 (if (and op
166 (string-match "^byte-" (setq opname (symbol-name op))))
167 (setq opname (substring opname 5))
168 (setq opname "<not-an-opcode>"))
169 (if (eq op 'byte-constant2)
170 (insert " #### shouldn't have seen constant2 here!\n "))
171 (insert opname)
172 (indent-to (+ indent disassemble-column-1-indent
173 disassemble-column-2-indent
174 -1))
175 (insert " ")
176 (cond ((memq op byte-goto-ops)
177 (insert (int-to-string (nth 1 arg))))
178 ((memq op '(byte-call byte-unbind
179 byte-listN byte-concatN byte-insertN))
180 (insert (int-to-string arg)))
181 ((memq op '(byte-varref byte-varset byte-varbind))
182 (prin1 (car arg) (current-buffer)))
183 ((memq op '(byte-constant byte-constant2))
184 ;; it's a constant
185 (setq arg (car arg))
186 ;; but if the value of the constant is compiled code, then
187 ;; recursively disassemble it.
188 (cond ((or (compiled-function-p arg)
189 (and (eq (car-safe arg) 'lambda)
190 (assq 'byte-code arg))
191 (and (eq (car-safe arg) 'macro)
192 (or (compiled-function-p (cdr arg))
193 (and (eq (car-safe (cdr arg)) 'lambda)
194 (assq 'byte-code (cdr arg))))))
195 (cond ((compiled-function-p arg)
196 (insert "<compiled-function>\n"))
197 ((eq (car-safe arg) 'lambda)
198 (insert "<compiled lambda>"))
199 (t (insert "<compiled macro>\n")))
200 (disassemble-internal
201 arg
202 (+ indent disassemble-recursive-indent 1)
203 nil))
204 ((eq (car-safe arg) 'byte-code)
205 (insert "<byte code>\n")
206 (disassemble-1 ;recurse on byte-code object
207 arg
208 (+ indent disassemble-recursive-indent)))
209 ((eq (car-safe (car-safe arg)) 'byte-code)
210 (insert "(<byte code>...)\n")
211 (mapcar ;recurse on list of byte-code objects
212 '(lambda (obj)
213 (disassemble-1
214 obj
215 (+ indent disassemble-recursive-indent)))
216 arg))
217 (t
218 ;; really just a constant
219 (let ((print-escape-newlines t))
220 (prin1 arg (current-buffer))))))
221 )
222 (insert "\n"))
223 (setq lap (cdr lap)))))
224 nil)
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-09 11:47:58 +0000