Line data Source code
1 : ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 1991, 1994, 2000-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Jamie Zawinski <jwz@lucid.com>
6 : ;; Hallvard Furuseth <hbf@ulrik.uio.no>
7 : ;; Maintainer: emacs-devel@gnu.org
8 : ;; Keywords: internal
9 : ;; Package: emacs
10 :
11 : ;; This file is part of GNU Emacs.
12 :
13 : ;; GNU Emacs is free software: you can redistribute it and/or modify
14 : ;; it under the terms of the GNU General Public License as published by
15 : ;; the Free Software Foundation, either version 3 of the License, or
16 : ;; (at your option) any later version.
17 :
18 : ;; GNU Emacs is distributed in the hope that it will be useful,
19 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 : ;; GNU General Public License for more details.
22 :
23 : ;; You should have received a copy of the GNU General Public License
24 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 :
26 : ;;; Commentary:
27 :
28 : ;; ========================================================================
29 : ;; "No matter how hard you try, you can't make a racehorse out of a pig.
30 : ;; You can, however, make a faster pig."
31 : ;;
32 : ;; Or, to put it another way, the Emacs byte compiler is a VW Bug. This code
33 : ;; makes it be a VW Bug with fuel injection and a turbocharger... You're
34 : ;; still not going to make it go faster than 70 mph, but it might be easier
35 : ;; to get it there.
36 : ;;
37 :
38 : ;; TO DO:
39 : ;;
40 : ;; (apply (lambda (x &rest y) ...) 1 (foo))
41 : ;;
42 : ;; maintain a list of functions known not to access any global variables
43 : ;; (actually, give them a 'dynamically-safe property) and then
44 : ;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==>
45 : ;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> )
46 : ;; by recursing on this, we might be able to eliminate the entire let.
47 : ;; However certain variables should never have their bindings optimized
48 : ;; away, because they affect everything.
49 : ;; (put 'debug-on-error 'binding-is-magic t)
50 : ;; (put 'debug-on-abort 'binding-is-magic t)
51 : ;; (put 'debug-on-next-call 'binding-is-magic t)
52 : ;; (put 'inhibit-quit 'binding-is-magic t)
53 : ;; (put 'quit-flag 'binding-is-magic t)
54 : ;; (put 't 'binding-is-magic t)
55 : ;; (put 'nil 'binding-is-magic t)
56 : ;; possibly also
57 : ;; (put 'gc-cons-threshold 'binding-is-magic t)
58 : ;; (put 'track-mouse 'binding-is-magic t)
59 : ;; others?
60 : ;;
61 : ;; Simple defsubsts often produce forms like
62 : ;; (let ((v1 (f1)) (v2 (f2)) ...)
63 : ;; (FN v1 v2 ...))
64 : ;; It would be nice if we could optimize this to
65 : ;; (FN (f1) (f2) ...)
66 : ;; but we can't unless FN is dynamically-safe (it might be dynamically
67 : ;; referring to the bindings that the lambda arglist established.)
68 : ;; One of the uncountable lossages introduced by dynamic scope...
69 : ;;
70 : ;; Maybe there should be a control-structure that says "turn on
71 : ;; fast-and-loose type-assumptive optimizations here." Then when
72 : ;; we see a form like (car foo) we can from then on assume that
73 : ;; the variable foo is of type cons, and optimize based on that.
74 : ;; But, this won't win much because of (you guessed it) dynamic
75 : ;; scope. Anything down the stack could change the value.
76 : ;; (Another reason it doesn't work is that it is perfectly valid
77 : ;; to call car with a null argument.) A better approach might
78 : ;; be to allow type-specification of the form
79 : ;; (put 'foo 'arg-types '(float (list integer) dynamic))
80 : ;; (put 'foo 'result-type 'bool)
81 : ;; It should be possible to have these types checked to a certain
82 : ;; degree.
83 : ;;
84 : ;; collapse common subexpressions
85 : ;;
86 : ;; It would be nice if redundant sequences could be factored out as well,
87 : ;; when they are known to have no side-effects:
88 : ;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2
89 : ;; but beware of traps like
90 : ;; (cons (list x y) (list x y))
91 : ;;
92 : ;; Tail-recursion elimination is not really possible in Emacs Lisp.
93 : ;; Tail-recursion elimination is almost always impossible when all variables
94 : ;; have dynamic scope, but given that the "return" byteop requires the
95 : ;; binding stack to be empty (rather than emptying it itself), there can be
96 : ;; no truly tail-recursive Emacs Lisp functions that take any arguments or
97 : ;; make any bindings.
98 : ;;
99 : ;; Here is an example of an Emacs Lisp function which could safely be
100 : ;; byte-compiled tail-recursively:
101 : ;;
102 : ;; (defun tail-map (fn list)
103 : ;; (cond (list
104 : ;; (funcall fn (car list))
105 : ;; (tail-map fn (cdr list)))))
106 : ;;
107 : ;; However, if there was even a single let-binding around the COND,
108 : ;; it could not be byte-compiled, because there would be an "unbind"
109 : ;; byte-op between the final "call" and "return." Adding a
110 : ;; Bunbind_all byteop would fix this.
111 : ;;
112 : ;; (defun foo (x y z) ... (foo a b c))
113 : ;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return)
114 : ;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return)
115 : ;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return)
116 : ;;
117 : ;; this also can be considered tail recursion:
118 : ;;
119 : ;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return)
120 : ;; could generalize this by doing the optimization
121 : ;; (goto X) ... X: (return) --> (return)
122 : ;;
123 : ;; But this doesn't solve all of the problems: although by doing tail-
124 : ;; recursion elimination in this way, the call-stack does not grow, the
125 : ;; binding-stack would grow with each recursive step, and would eventually
126 : ;; overflow. I don't believe there is any way around this without lexical
127 : ;; scope.
128 : ;;
129 : ;; Wouldn't it be nice if Emacs Lisp had lexical scope.
130 : ;;
131 : ;; Idea: the form (lexical-scope) in a file means that the file may be
132 : ;; compiled lexically. This proclamation is file-local. Then, within
133 : ;; that file, "let" would establish lexical bindings, and "let-dynamic"
134 : ;; would do things the old way. (Or we could use CL "declare" forms.)
135 : ;; We'd have to notice defvars and defconsts, since those variables should
136 : ;; always be dynamic, and attempting to do a lexical binding of them
137 : ;; should simply do a dynamic binding instead.
138 : ;; But! We need to know about variables that were not necessarily defvared
139 : ;; in the file being compiled (doing a boundp check isn't good enough.)
140 : ;; Fdefvar() would have to be modified to add something to the plist.
141 : ;;
142 : ;; A major disadvantage of this scheme is that the interpreter and compiler
143 : ;; would have different semantics for files compiled with (dynamic-scope).
144 : ;; Since this would be a file-local optimization, there would be no way to
145 : ;; modify the interpreter to obey this (unless the loader was hacked
146 : ;; in some grody way, but that's a really bad idea.)
147 :
148 : ;; Other things to consider:
149 :
150 : ;; ;; Associative math should recognize subcalls to identical function:
151 : ;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2))))
152 : ;; ;; This should generate the same as (1+ x) and (1- x)
153 :
154 : ;; (disassemble (lambda (x) (cons (+ x 1) (- x 1))))
155 : ;; ;; An awful lot of functions always return a non-nil value. If they're
156 : ;; ;; error free also they may act as true-constants.
157 :
158 : ;; (disassemble (lambda (x) (and (point) (foo))))
159 : ;; ;; When
160 : ;; ;; - all but one arguments to a function are constant
161 : ;; ;; - the non-constant argument is an if-expression (cond-expression?)
162 : ;; ;; then the outer function can be distributed. If the guarding
163 : ;; ;; condition is side-effect-free [assignment-free] then the other
164 : ;; ;; arguments may be any expressions. Since, however, the code size
165 : ;; ;; can increase this way they should be "simple". Compare:
166 :
167 : ;; (disassemble (lambda (x) (eq (if (point) 'a 'b) 'c)))
168 : ;; (disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
169 :
170 : ;; ;; (car (cons A B)) -> (prog1 A B)
171 : ;; (disassemble (lambda (x) (car (cons (foo) 42))))
172 :
173 : ;; ;; (cdr (cons A B)) -> (progn A B)
174 : ;; (disassemble (lambda (x) (cdr (cons 42 (foo)))))
175 :
176 : ;; ;; (car (list A B ...)) -> (prog1 A B ...)
177 : ;; (disassemble (lambda (x) (car (list (foo) 42 (bar)))))
178 :
179 : ;; ;; (cdr (list A B ...)) -> (progn A (list B ...))
180 : ;; (disassemble (lambda (x) (cdr (list 42 (foo) (bar)))))
181 :
182 :
183 : ;;; Code:
184 :
185 : (require 'bytecomp)
186 : (eval-when-compile (require 'cl-lib))
187 : (require 'macroexp)
188 : (eval-when-compile (require 'subr-x))
189 :
190 : (defun byte-compile-log-lap-1 (format &rest args)
191 : ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
192 : ;; But the "old disassembler" is *really* ancient by now.
193 : ;; (if (aref byte-code-vector 0)
194 : ;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well"))
195 0 : (byte-compile-log-1
196 0 : (apply #'format-message format
197 0 : (let (c a)
198 0 : (mapcar (lambda (arg)
199 0 : (if (not (consp arg))
200 0 : (if (and (symbolp arg)
201 0 : (string-match "^byte-" (symbol-name arg)))
202 0 : (intern (substring (symbol-name arg) 5))
203 0 : arg)
204 0 : (if (integerp (setq c (car arg)))
205 0 : (error "non-symbolic byte-op %s" c))
206 0 : (if (eq c 'TAG)
207 0 : (setq c arg)
208 0 : (setq a (cond ((memq c byte-goto-ops)
209 0 : (car (cdr (cdr arg))))
210 0 : ((memq c byte-constref-ops)
211 0 : (car (cdr arg)))
212 0 : (t (cdr arg))))
213 0 : (setq c (symbol-name c))
214 0 : (if (string-match "^byte-." c)
215 0 : (setq c (intern (substring c 5)))))
216 0 : (if (eq c 'constant) (setq c 'const))
217 0 : (if (and (eq (cdr arg) 0)
218 0 : (not (memq c '(unbind call const))))
219 0 : c
220 0 : (format "(%s %s)" c a))))
221 0 : args)))))
222 :
223 : (defmacro byte-compile-log-lap (format-string &rest args)
224 30 : `(and (memq byte-optimize-log '(t byte))
225 30 : (byte-compile-log-lap-1 ,format-string ,@args)))
226 :
227 :
228 : ;;; byte-compile optimizers to support inlining
229 :
230 : (put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
231 :
232 : (defun byte-optimize-inline-handler (form)
233 : "byte-optimize-handler for the `inline' special-form."
234 0 : (cons 'progn
235 0 : (mapcar
236 : (lambda (sexp)
237 0 : (let ((f (car-safe sexp)))
238 0 : (if (and (symbolp f)
239 0 : (or (cdr (assq f byte-compile-function-environment))
240 0 : (not (or (not (fboundp f))
241 0 : (cdr (assq f byte-compile-macro-environment))
242 0 : (and (consp (setq f (symbol-function f)))
243 0 : (eq (car f) 'macro))
244 0 : (subrp f)))))
245 0 : (byte-compile-inline-expand sexp)
246 0 : sexp)))
247 0 : (cdr form))))
248 :
249 : (defun byte-compile-inline-expand (form)
250 14 : (let* ((name (car form))
251 14 : (localfn (cdr (assq name byte-compile-function-environment)))
252 14 : (fn (or localfn (symbol-function name))))
253 14 : (when (autoloadp fn)
254 0 : (autoload-do-load fn)
255 0 : (setq fn (or (symbol-function name)
256 14 : (cdr (assq name byte-compile-function-environment)))))
257 14 : (pcase fn
258 : (`nil
259 0 : (byte-compile-warn "attempt to inline `%s' before it was defined"
260 0 : name)
261 0 : form)
262 : (`(autoload . ,_)
263 0 : (error "File `%s' didn't define `%s'" (nth 1 fn) name))
264 0 : ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
265 0 : (byte-compile-inline-expand (cons fn (cdr form))))
266 : ((pred byte-code-function-p)
267 : ;; (message "Inlining byte-code for %S!" name)
268 : ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
269 0 : `(,fn ,@(cdr form)))
270 : ((or `(lambda . ,_) `(closure . ,_))
271 0 : (if (not (or (eq fn localfn) ;From the same file => same mode.
272 0 : (eq (car fn) ;Same mode.
273 0 : (if lexical-binding 'closure 'lambda))))
274 : ;; While byte-compile-unfold-bcf can inline dynbind byte-code into
275 : ;; letbind byte-code (or any other combination for that matter), we
276 : ;; can only inline dynbind source into dynbind source or letbind
277 : ;; source into letbind source.
278 0 : (progn
279 : ;; We can of course byte-compile the inlined function
280 : ;; first, and then inline its byte-code.
281 0 : (byte-compile name)
282 0 : `(,(symbol-function name) ,@(cdr form)))
283 0 : (let ((newfn (if (eq fn localfn)
284 : ;; If `fn' is from the same file, it has already
285 : ;; been preprocessed!
286 0 : `(function ,fn)
287 0 : (byte-compile-preprocess
288 0 : (byte-compile--reify-function fn)))))
289 0 : (if (eq (car-safe newfn) 'function)
290 0 : (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
291 : ;; This can happen because of macroexp-warn-and-return &co.
292 0 : (byte-compile-warn
293 0 : "Inlining closure %S failed" name)
294 0 : form))))
295 :
296 : (_ ;; Give up on inlining.
297 14 : form))))
298 :
299 : ;; ((lambda ...) ...)
300 : (defun byte-compile-unfold-lambda (form &optional name)
301 : ;; In lexical-binding mode, let and functions don't bind vars in the same way
302 : ;; (let obey special-variable-p, but functions don't). But luckily, this
303 : ;; doesn't matter here, because function's behavior is underspecified so it
304 : ;; can safely be turned into a `let', even though the reverse is not true.
305 0 : (or name (setq name "anonymous lambda"))
306 0 : (let* ((lambda (car form))
307 0 : (values (cdr form))
308 0 : (arglist (nth 1 lambda))
309 0 : (body (cdr (cdr lambda)))
310 : optionalp restp
311 : bindings)
312 0 : (if (and (stringp (car body)) (cdr body))
313 0 : (setq body (cdr body)))
314 0 : (if (and (consp (car body)) (eq 'interactive (car (car body))))
315 0 : (setq body (cdr body)))
316 : ;; FIXME: The checks below do not belong in an optimization phase.
317 0 : (while arglist
318 0 : (cond ((eq (car arglist) '&optional)
319 : ;; ok, I'll let this slide because funcall_lambda() does...
320 : ;; (if optionalp (error "multiple &optional keywords in %s" name))
321 0 : (if restp (error "&optional found after &rest in %s" name))
322 0 : (if (null (cdr arglist))
323 0 : (error "nothing after &optional in %s" name))
324 0 : (setq optionalp t))
325 0 : ((eq (car arglist) '&rest)
326 : ;; ...but it is by no stretch of the imagination a reasonable
327 : ;; thing that funcall_lambda() allows (&rest x y) and
328 : ;; (&rest x &optional y) in arglists.
329 0 : (if (null (cdr arglist))
330 0 : (error "nothing after &rest in %s" name))
331 0 : (if (cdr (cdr arglist))
332 0 : (error "multiple vars after &rest in %s" name))
333 0 : (setq restp t))
334 0 : (restp
335 0 : (setq bindings (cons (list (car arglist)
336 0 : (and values (cons 'list values)))
337 0 : bindings)
338 0 : values nil))
339 0 : ((and (not optionalp) (null values))
340 0 : (byte-compile-warn "attempt to open-code `%s' with too few arguments" name)
341 0 : (setq arglist nil values 'too-few))
342 : (t
343 0 : (setq bindings (cons (list (car arglist) (car values))
344 0 : bindings)
345 0 : values (cdr values))))
346 0 : (setq arglist (cdr arglist)))
347 0 : (if values
348 0 : (progn
349 0 : (or (eq values 'too-few)
350 0 : (byte-compile-warn
351 0 : "attempt to open-code `%s' with too many arguments" name))
352 0 : form)
353 :
354 : ;; The following leads to infinite recursion when loading a
355 : ;; file containing `(defsubst f () (f))', and then trying to
356 : ;; byte-compile that file.
357 : ;(setq body (mapcar 'byte-optimize-form body)))
358 :
359 0 : (let ((newform
360 0 : (if bindings
361 0 : (cons 'let (cons (nreverse bindings) body))
362 0 : (cons 'progn body))))
363 0 : (byte-compile-log " %s\t==>\t%s" form newform)
364 0 : newform))))
365 :
366 :
367 : ;;; implementing source-level optimizers
368 :
369 : (defun byte-optimize-form-code-walker (form for-effect)
370 : ;;
371 : ;; For normal function calls, We can just mapcar the optimizer the cdr. But
372 : ;; we need to have special knowledge of the syntax of the special forms
373 : ;; like let and defun (that's why they're special forms :-). (Actually,
374 : ;; the important aspect is that they are subrs that don't evaluate all of
375 : ;; their args.)
376 : ;;
377 603 : (let ((fn (car-safe form))
378 : tmp)
379 603 : (cond ((not (consp form))
380 249 : (if (not (and for-effect
381 0 : (or byte-compile-delete-errors
382 0 : (not (symbolp form))
383 249 : (eq form t))))
384 249 : form))
385 354 : ((eq fn 'quote)
386 55 : (if (cdr (cdr form))
387 0 : (byte-compile-warn "malformed quote form: `%s'"
388 55 : (prin1-to-string form)))
389 : ;; map (quote nil) to nil to simplify optimizer logic.
390 : ;; map quoted constants to nil if for-effect (just because).
391 55 : (and (nth 1 form)
392 55 : (not for-effect)
393 55 : form))
394 299 : ((eq (car-safe fn) 'lambda)
395 0 : (let ((newform (byte-compile-unfold-lambda form)))
396 0 : (if (eq newform form)
397 : ;; Some error occurred, avoid infinite recursion
398 0 : form
399 0 : (byte-optimize-form-code-walker newform for-effect))))
400 299 : ((eq (car-safe fn) 'closure) form)
401 299 : ((memq fn '(let let*))
402 : ;; recursively enter the optimizer for the bindings and body
403 : ;; of a let or let*. This for depth-firstness: forms that
404 : ;; are more deeply nested are optimized first.
405 30 : (cons fn
406 30 : (cons
407 30 : (mapcar (lambda (binding)
408 35 : (if (symbolp binding)
409 0 : binding
410 35 : (if (cdr (cdr binding))
411 0 : (byte-compile-warn "malformed let binding: `%s'"
412 35 : (prin1-to-string binding)))
413 35 : (list (car binding)
414 35 : (byte-optimize-form (nth 1 binding) nil))))
415 30 : (nth 1 form))
416 30 : (byte-optimize-body (cdr (cdr form)) for-effect))))
417 269 : ((eq fn 'cond)
418 0 : (cons fn
419 0 : (mapcar (lambda (clause)
420 0 : (if (consp clause)
421 0 : (cons
422 0 : (byte-optimize-form (car clause) nil)
423 0 : (byte-optimize-body (cdr clause) for-effect))
424 0 : (byte-compile-warn "malformed cond form: `%s'"
425 0 : (prin1-to-string clause))
426 0 : clause))
427 0 : (cdr form))))
428 269 : ((eq fn 'progn)
429 : ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
430 25 : (if (cdr (cdr form))
431 10 : (macroexp-progn (byte-optimize-body (cdr form) for-effect))
432 25 : (byte-optimize-form (nth 1 form) for-effect)))
433 244 : ((eq fn 'prog1)
434 0 : (if (cdr (cdr form))
435 0 : (cons 'prog1
436 0 : (cons (byte-optimize-form (nth 1 form) for-effect)
437 0 : (byte-optimize-body (cdr (cdr form)) t)))
438 0 : (byte-optimize-form (nth 1 form) for-effect)))
439 244 : ((eq fn 'prog2)
440 0 : (cons 'prog2
441 0 : (cons (byte-optimize-form (nth 1 form) t)
442 0 : (cons (byte-optimize-form (nth 2 form) for-effect)
443 0 : (byte-optimize-body (cdr (cdr (cdr form))) t)))))
444 :
445 244 : ((memq fn '(save-excursion save-restriction save-current-buffer))
446 : ;; those subrs which have an implicit progn; it's not quite good
447 : ;; enough to treat these like normal function calls.
448 : ;; This can turn (save-excursion ...) into (save-excursion) which
449 : ;; will be optimized away in the lap-optimize pass.
450 0 : (cons fn (byte-optimize-body (cdr form) for-effect)))
451 :
452 244 : ((eq fn 'with-output-to-temp-buffer)
453 : ;; this is just like the above, except for the first argument.
454 0 : (cons fn
455 0 : (cons
456 0 : (byte-optimize-form (nth 1 form) nil)
457 0 : (byte-optimize-body (cdr (cdr form)) for-effect))))
458 :
459 244 : ((eq fn 'if)
460 30 : (when (< (length form) 3)
461 30 : (byte-compile-warn "too few arguments for `if'"))
462 30 : (cons fn
463 30 : (cons (byte-optimize-form (nth 1 form) nil)
464 30 : (cons
465 30 : (byte-optimize-form (nth 2 form) for-effect)
466 30 : (byte-optimize-body (nthcdr 3 form) for-effect)))))
467 :
468 214 : ((memq fn '(and or)) ; Remember, and/or are control structures.
469 : ;; Take forms off the back until we can't any more.
470 : ;; In the future it could conceivably be a problem that the
471 : ;; subexpressions of these forms are optimized in the reverse
472 : ;; order, but it's ok for now.
473 24 : (if for-effect
474 0 : (let ((backwards (reverse (cdr form))))
475 0 : (while (and backwards
476 0 : (null (setcar backwards
477 0 : (byte-optimize-form (car backwards)
478 0 : for-effect))))
479 0 : (setq backwards (cdr backwards)))
480 0 : (if (and (cdr form) (null backwards))
481 0 : (byte-compile-log
482 0 : " all subforms of %s called for effect; deleted" form))
483 0 : (and backwards
484 0 : (cons fn (nreverse (mapcar 'byte-optimize-form
485 0 : backwards)))))
486 24 : (cons fn (mapcar 'byte-optimize-form (cdr form)))))
487 :
488 190 : ((eq fn 'interactive)
489 0 : (byte-compile-warn "misplaced interactive spec: `%s'"
490 0 : (prin1-to-string form))
491 : nil)
492 :
493 190 : ((eq fn 'function)
494 : ;; This forms is compiled as constant or by breaking out
495 : ;; all the subexpressions and compiling them separately.
496 10 : form)
497 :
498 180 : ((eq fn 'condition-case)
499 0 : (if byte-compile--use-old-handlers
500 : ;; Will be optimized later.
501 0 : form
502 0 : `(condition-case ,(nth 1 form) ;Not evaluated.
503 0 : ,(byte-optimize-form (nth 2 form) for-effect)
504 0 : ,@(mapcar (lambda (clause)
505 0 : `(,(car clause)
506 0 : ,@(byte-optimize-body (cdr clause) for-effect)))
507 0 : (nthcdr 3 form)))))
508 :
509 180 : ((eq fn 'unwind-protect)
510 : ;; the "protected" part of an unwind-protect is compiled (and thus
511 : ;; optimized) as a top-level form, so don't do it here. But the
512 : ;; non-protected part has the same for-effect status as the
513 : ;; unwind-protect itself. (The protected part is always for effect,
514 : ;; but that isn't handled properly yet.)
515 0 : (cons fn
516 0 : (cons (byte-optimize-form (nth 1 form) for-effect)
517 0 : (cdr (cdr form)))))
518 :
519 180 : ((eq fn 'catch)
520 0 : (cons fn
521 0 : (cons (byte-optimize-form (nth 1 form) nil)
522 0 : (if byte-compile--use-old-handlers
523 : ;; The body of a catch is compiled (and thus
524 : ;; optimized) as a top-level form, so don't do it
525 : ;; here.
526 0 : (cdr (cdr form))
527 0 : (byte-optimize-body (cdr form) for-effect)))))
528 :
529 180 : ((eq fn 'ignore)
530 : ;; Don't treat the args to `ignore' as being
531 : ;; computed for effect. We want to avoid the warnings
532 : ;; that might occur if they were treated that way.
533 : ;; However, don't actually bother calling `ignore'.
534 0 : `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
535 :
536 : ;; Needed as long as we run byte-optimize-form after cconv.
537 180 : ((eq fn 'internal-make-closure) form)
538 :
539 175 : ((byte-code-function-p fn)
540 0 : (cons fn (mapcar #'byte-optimize-form (cdr form))))
541 :
542 175 : ((not (symbolp fn))
543 0 : (byte-compile-warn "`%s' is a malformed function"
544 0 : (prin1-to-string fn))
545 0 : form)
546 :
547 175 : ((and for-effect (setq tmp (get fn 'side-effect-free))
548 0 : (or byte-compile-delete-errors
549 0 : (eq tmp 'error-free)
550 0 : (progn
551 0 : (byte-compile-warn "value returned from %s is unused"
552 0 : (prin1-to-string form))
553 175 : nil)))
554 0 : (byte-compile-log " %s called for effect; deleted" fn)
555 : ;; appending a nil here might not be necessary, but it can't hurt.
556 0 : (byte-optimize-form
557 0 : (cons 'progn (append (cdr form) '(nil))) t))
558 :
559 : (t
560 : ;; Otherwise, no args can be considered to be for-effect,
561 : ;; even if the called function is for-effect, because we
562 : ;; don't know anything about that function.
563 175 : (let ((args (mapcar #'byte-optimize-form (cdr form))))
564 175 : (if (and (get fn 'pure)
565 175 : (byte-optimize-all-constp args))
566 0 : (list 'quote (apply fn (mapcar #'eval args)))
567 603 : (cons fn args)))))))
568 :
569 : (defun byte-optimize-all-constp (list)
570 : "Non-nil if all elements of LIST satisfy `macroexp-const-p'."
571 0 : (let ((constant t))
572 0 : (while (and list constant)
573 0 : (unless (macroexp-const-p (car list))
574 0 : (setq constant nil))
575 0 : (setq list (cdr list)))
576 0 : constant))
577 :
578 : (defun byte-optimize-form (form &optional for-effect)
579 : "The source-level pass of the optimizer."
580 : ;;
581 : ;; First, optimize all sub-forms of this one.
582 603 : (setq form (byte-optimize-form-code-walker form for-effect))
583 : ;;
584 : ;; after optimizing all subforms, optimize this form until it doesn't
585 : ;; optimize any further. This means that some forms will be passed through
586 : ;; the optimizer many times, but that's necessary to make the for-effect
587 : ;; processing do as much as possible.
588 : ;;
589 603 : (let (opt new)
590 603 : (if (and (consp form)
591 354 : (symbolp (car form))
592 354 : (or ;; (and for-effect
593 : ;; ;; We don't have any of these yet, but we might.
594 : ;; (setq opt (get (car form)
595 : ;; 'byte-for-effect-optimizer)))
596 354 : (setq opt (function-get (car form) 'byte-optimizer)))
597 603 : (not (eq form (setq new (funcall opt form)))))
598 26 : (progn
599 : ;; (if (equal form new) (error "bogus optimizer -- %s" opt))
600 26 : (byte-compile-log " %s\t==>\t%s" form new)
601 26 : (setq new (byte-optimize-form new for-effect))
602 26 : new)
603 603 : form)))
604 :
605 :
606 : (defun byte-optimize-body (forms all-for-effect)
607 : ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
608 : ;; forms, all but the last of which are optimized with the assumption that
609 : ;; they are being called for effect. the last is for-effect as well if
610 : ;; all-for-effect is true. returns a new list of forms.
611 70 : (let ((rest forms)
612 : (result nil)
613 : fe new)
614 150 : (while rest
615 80 : (setq fe (or all-for-effect (cdr rest)))
616 80 : (setq new (and (car rest) (byte-optimize-form (car rest) fe)))
617 80 : (if (or new (not fe))
618 80 : (setq result (cons new result)))
619 80 : (setq rest (cdr rest)))
620 70 : (nreverse result)))
621 :
622 :
623 : ;; some source-level optimizers
624 : ;;
625 : ;; when writing optimizers, be VERY careful that the optimizer returns
626 : ;; something not EQ to its argument if and ONLY if it has made a change.
627 : ;; This implies that you cannot simply destructively modify the list;
628 : ;; you must return something not EQ to it if you make an optimization.
629 : ;;
630 : ;; It is now safe to optimize code such that it introduces new bindings.
631 :
632 : (defsubst byte-compile-trueconstp (form)
633 : "Return non-nil if FORM always evaluates to a non-nil value."
634 48 : (while (eq (car-safe form) 'progn)
635 48 : (setq form (car (last (cdr form)))))
636 48 : (cond ((consp form)
637 18 : (pcase (car form)
638 0 : (`quote (cadr form))
639 : ;; Can't use recursion in a defsubst.
640 : ;; (`progn (byte-compile-trueconstp (car (last (cdr form)))))
641 18 : ))
642 30 : ((not (symbolp form)))
643 30 : ((eq form t))
644 48 : ((keywordp form))))
645 :
646 : (defsubst byte-compile-nilconstp (form)
647 : "Return non-nil if FORM always evaluates to a nil value."
648 30 : (while (eq (car-safe form) 'progn)
649 30 : (setq form (car (last (cdr form)))))
650 30 : (cond ((consp form)
651 0 : (pcase (car form)
652 0 : (`quote (null (cadr form)))
653 : ;; Can't use recursion in a defsubst.
654 : ;; (`progn (byte-compile-nilconstp (car (last (cdr form)))))
655 0 : ))
656 30 : ((not (symbolp form)) nil)
657 30 : ((null form))))
658 :
659 : ;; If the function is being called with constant numeric args,
660 : ;; evaluate as much as possible at compile-time. This optimizer
661 : ;; assumes that the function is associative, like + or *.
662 : (defun byte-optimize-associative-math (form)
663 0 : (let ((args nil)
664 : (constants nil)
665 0 : (rest (cdr form)))
666 0 : (while rest
667 0 : (if (numberp (car rest))
668 0 : (setq constants (cons (car rest) constants))
669 0 : (setq args (cons (car rest) args)))
670 0 : (setq rest (cdr rest)))
671 0 : (if (cdr constants)
672 0 : (if args
673 0 : (list (car form)
674 0 : (apply (car form) constants)
675 0 : (if (cdr args)
676 0 : (cons (car form) (nreverse args))
677 0 : (car args)))
678 0 : (apply (car form) constants))
679 0 : form)))
680 :
681 : ;; If the function is being called with constant numeric args,
682 : ;; evaluate as much as possible at compile-time. This optimizer
683 : ;; assumes that the function satisfies
684 : ;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn)
685 : ;; like - and /.
686 : (defun byte-optimize-nonassociative-math (form)
687 0 : (if (or (not (numberp (car (cdr form))))
688 0 : (not (numberp (car (cdr (cdr form))))))
689 0 : form
690 0 : (let ((constant (car (cdr form)))
691 0 : (rest (cdr (cdr form))))
692 0 : (while (numberp (car rest))
693 0 : (setq constant (funcall (car form) constant (car rest))
694 0 : rest (cdr rest)))
695 0 : (if rest
696 0 : (cons (car form) (cons constant rest))
697 0 : constant))))
698 :
699 : ;;(defun byte-optimize-associative-two-args-math (form)
700 : ;; (setq form (byte-optimize-associative-math form))
701 : ;; (if (consp form)
702 : ;; (byte-optimize-two-args-left form)
703 : ;; form))
704 :
705 : ;;(defun byte-optimize-nonassociative-two-args-math (form)
706 : ;; (setq form (byte-optimize-nonassociative-math form))
707 : ;; (if (consp form)
708 : ;; (byte-optimize-two-args-right form)
709 : ;; form))
710 :
711 : (defun byte-optimize-approx-equal (x y)
712 0 : (<= (* (abs (- x y)) 100) (abs (+ x y))))
713 :
714 : ;; Collect all the constants from FORM, after the STARTth arg,
715 : ;; and apply FUN to them to make one argument at the end.
716 : ;; For functions that can handle floats, that optimization
717 : ;; can be incorrect because reordering can cause an overflow
718 : ;; that would otherwise be avoided by encountering an arg that is a float.
719 : ;; We avoid this problem by (1) not moving float constants and
720 : ;; (2) not moving anything if it would cause an overflow.
721 : (defun byte-optimize-delay-constants-math (form start fun)
722 : ;; Merge all FORM's constants from number START, call FUN on them
723 : ;; and put the result at the end.
724 0 : (let ((rest (nthcdr (1- start) form))
725 0 : (orig form)
726 : ;; t means we must check for overflow.
727 0 : (overflow (memq fun '(+ *))))
728 0 : (while (cdr (setq rest (cdr rest)))
729 0 : (if (integerp (car rest))
730 0 : (let (constants)
731 0 : (setq form (copy-sequence form)
732 0 : rest (nthcdr (1- start) form))
733 0 : (while (setq rest (cdr rest))
734 0 : (cond ((integerp (car rest))
735 0 : (setq constants (cons (car rest) constants))
736 0 : (setcar rest nil))))
737 : ;; If necessary, check now for overflow
738 : ;; that might be caused by reordering.
739 0 : (if (and overflow
740 : ;; We have overflow if the result of doing the arithmetic
741 : ;; on floats is not even close to the result
742 : ;; of doing it on integers.
743 0 : (not (byte-optimize-approx-equal
744 0 : (apply fun (mapcar 'float constants))
745 0 : (float (apply fun constants)))))
746 0 : (setq form orig)
747 0 : (setq form (nconc (delq nil form)
748 0 : (list (apply fun (nreverse constants)))))))))
749 0 : form))
750 :
751 : (defsubst byte-compile-butlast (form)
752 0 : (nreverse (cdr (reverse form))))
753 :
754 : (defun byte-optimize-plus (form)
755 : ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
756 : ;;(setq form (byte-optimize-delay-constants-math form 1 '+))
757 0 : (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
758 : ;; For (+ constants...), byte-optimize-predicate does the work.
759 0 : (when (memq nil (mapcar 'numberp (cdr form)))
760 0 : (cond
761 : ;; (+ x 1) --> (1+ x) and (+ x -1) --> (1- x).
762 0 : ((and (= (length form) 3)
763 0 : (or (memq (nth 1 form) '(1 -1))
764 0 : (memq (nth 2 form) '(1 -1))))
765 0 : (let (integer other)
766 0 : (if (memq (nth 1 form) '(1 -1))
767 0 : (setq integer (nth 1 form) other (nth 2 form))
768 0 : (setq integer (nth 2 form) other (nth 1 form)))
769 0 : (setq form
770 0 : (list (if (eq integer 1) '1+ '1-) other))))
771 : ;; Here, we could also do
772 : ;; (+ x y ... 1) --> (1+ (+ x y ...))
773 : ;; (+ x y ... -1) --> (1- (+ x y ...))
774 : ;; The resulting bytecode is smaller, but is it faster? -- cyd
775 0 : ))
776 0 : (byte-optimize-predicate form))
777 :
778 : (defun byte-optimize-minus (form)
779 : ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
780 : ;;(setq form (byte-optimize-delay-constants-math form 2 '+))
781 : ;; Remove zeros.
782 0 : (when (and (nthcdr 3 form)
783 0 : (memq 0 (cddr form)))
784 0 : (setq form (nconc (list (car form) (cadr form))
785 0 : (delq 0 (copy-sequence (cddr form)))))
786 : ;; After the above, we must turn (- x) back into (- x 0)
787 0 : (or (cddr form)
788 0 : (setq form (nconc form (list 0)))))
789 : ;; For (- constants..), byte-optimize-predicate does the work.
790 0 : (when (memq nil (mapcar 'numberp (cdr form)))
791 0 : (cond
792 : ;; (- x 1) --> (1- x)
793 0 : ((equal (nthcdr 2 form) '(1))
794 0 : (setq form (list '1- (nth 1 form))))
795 : ;; (- x -1) --> (1+ x)
796 0 : ((equal (nthcdr 2 form) '(-1))
797 0 : (setq form (list '1+ (nth 1 form))))
798 : ;; (- 0 x) --> (- x)
799 0 : ((and (eq (nth 1 form) 0)
800 0 : (= (length form) 3))
801 0 : (setq form (list '- (nth 2 form))))
802 : ;; Here, we could also do
803 : ;; (- x y ... 1) --> (1- (- x y ...))
804 : ;; (- x y ... -1) --> (1+ (- x y ...))
805 : ;; The resulting bytecode is smaller, but is it faster? -- cyd
806 0 : ))
807 0 : (byte-optimize-predicate form))
808 :
809 : (defun byte-optimize-multiply (form)
810 0 : (setq form (byte-optimize-delay-constants-math form 1 '*))
811 : ;; For (* constants..), byte-optimize-predicate does the work.
812 0 : (when (memq nil (mapcar 'numberp (cdr form)))
813 : ;; After `byte-optimize-predicate', if there is a INTEGER constant
814 : ;; in FORM, it is in the last element.
815 0 : (let ((last (car (reverse (cdr form)))))
816 0 : (cond
817 : ;; Would handling (* ... 0) here cause floating point errors?
818 : ;; See bug#1334.
819 0 : ((eq 1 last) (setq form (byte-compile-butlast form)))
820 0 : ((eq -1 last)
821 0 : (setq form (list '- (if (nthcdr 3 form)
822 0 : (byte-compile-butlast form)
823 0 : (nth 1 form))))))))
824 0 : (byte-optimize-predicate form))
825 :
826 : (defun byte-optimize-divide (form)
827 0 : (setq form (byte-optimize-delay-constants-math form 2 '*))
828 : ;; After `byte-optimize-predicate', if there is a INTEGER constant
829 : ;; in FORM, it is in the last element.
830 0 : (let ((last (car (reverse (cdr (cdr form))))))
831 0 : (cond
832 : ;; Runtime error (leave it intact).
833 0 : ((or (null last)
834 0 : (eq last 0)
835 0 : (memql 0.0 (cddr form))))
836 : ;; No constants in expression
837 0 : ((not (numberp last)))
838 : ;; For (* constants..), byte-optimize-predicate does the work.
839 0 : ((null (memq nil (mapcar 'numberp (cdr form)))))
840 : ;; (/ x y.. 1) --> (/ x y..)
841 0 : ((and (eq last 1) (nthcdr 3 form))
842 0 : (setq form (byte-compile-butlast form)))
843 : ;; (/ x -1), (/ x .. -1) --> (- x), (- (/ x ..))
844 0 : ((eq last -1)
845 0 : (setq form (list '- (if (nthcdr 3 form)
846 0 : (byte-compile-butlast form)
847 0 : (nth 1 form)))))))
848 0 : (byte-optimize-predicate form))
849 :
850 : (defun byte-optimize-logmumble (form)
851 0 : (setq form (byte-optimize-delay-constants-math form 1 (car form)))
852 0 : (byte-optimize-predicate
853 0 : (cond ((memq 0 form)
854 0 : (setq form (if (eq (car form) 'logand)
855 0 : (cons 'progn (cdr form))
856 0 : (delq 0 (copy-sequence form)))))
857 0 : ((and (eq (car-safe form) 'logior)
858 0 : (memq -1 form))
859 0 : (cons 'progn (cdr form)))
860 0 : (form))))
861 :
862 :
863 : (defun byte-optimize-binary-predicate (form)
864 0 : (cond
865 0 : ((or (not (macroexp-const-p (nth 1 form)))
866 0 : (nthcdr 3 form)) ;; In case there are more than 2 args.
867 0 : form)
868 0 : ((macroexp-const-p (nth 2 form))
869 0 : (condition-case ()
870 0 : (list 'quote (eval form))
871 0 : (error form)))
872 : (t ;; This can enable some lapcode optimizations.
873 0 : (list (car form) (nth 2 form) (nth 1 form)))))
874 :
875 : (defun byte-optimize-predicate (form)
876 32 : (let ((ok t)
877 32 : (rest (cdr form)))
878 64 : (while (and rest ok)
879 32 : (setq ok (macroexp-const-p (car rest))
880 32 : rest (cdr rest)))
881 32 : (if ok
882 0 : (condition-case ()
883 0 : (list 'quote (eval form))
884 0 : (error form))
885 32 : form)))
886 :
887 : (defun byte-optimize-identity (form)
888 0 : (if (and (cdr form) (null (cdr (cdr form))))
889 0 : (nth 1 form)
890 0 : (byte-compile-warn "identity called with %d arg%s, but requires 1"
891 0 : (length (cdr form))
892 0 : (if (= 1 (length (cdr form))) "" "s"))
893 0 : form))
894 :
895 : (put 'identity 'byte-optimizer 'byte-optimize-identity)
896 :
897 : (put '+ 'byte-optimizer 'byte-optimize-plus)
898 : (put '* 'byte-optimizer 'byte-optimize-multiply)
899 : (put '- 'byte-optimizer 'byte-optimize-minus)
900 : (put '/ 'byte-optimizer 'byte-optimize-divide)
901 : (put 'max 'byte-optimizer 'byte-optimize-associative-math)
902 : (put 'min 'byte-optimizer 'byte-optimize-associative-math)
903 :
904 : (put '= 'byte-optimizer 'byte-optimize-binary-predicate)
905 : (put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
906 : (put 'equal 'byte-optimizer 'byte-optimize-binary-predicate)
907 : (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
908 : (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
909 :
910 : (put '< 'byte-optimizer 'byte-optimize-predicate)
911 : (put '> 'byte-optimizer 'byte-optimize-predicate)
912 : (put '<= 'byte-optimizer 'byte-optimize-predicate)
913 : (put '>= 'byte-optimizer 'byte-optimize-predicate)
914 : (put '1+ 'byte-optimizer 'byte-optimize-predicate)
915 : (put '1- 'byte-optimizer 'byte-optimize-predicate)
916 : (put 'not 'byte-optimizer 'byte-optimize-predicate)
917 : (put 'null 'byte-optimizer 'byte-optimize-predicate)
918 : (put 'memq 'byte-optimizer 'byte-optimize-predicate)
919 : (put 'consp 'byte-optimizer 'byte-optimize-predicate)
920 : (put 'listp 'byte-optimizer 'byte-optimize-predicate)
921 : (put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
922 : (put 'stringp 'byte-optimizer 'byte-optimize-predicate)
923 : (put 'string< 'byte-optimizer 'byte-optimize-predicate)
924 : (put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
925 :
926 : (put 'logand 'byte-optimizer 'byte-optimize-logmumble)
927 : (put 'logior 'byte-optimizer 'byte-optimize-logmumble)
928 : (put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
929 : (put 'lognot 'byte-optimizer 'byte-optimize-predicate)
930 :
931 : (put 'car 'byte-optimizer 'byte-optimize-predicate)
932 : (put 'cdr 'byte-optimizer 'byte-optimize-predicate)
933 : (put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
934 : (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
935 :
936 :
937 : ;; I'm not convinced that this is necessary. Doesn't the optimizer loop
938 : ;; take care of this? - Jamie
939 : ;; I think this may some times be necessary to reduce ie (quote 5) to 5,
940 : ;; so arithmetic optimizers recognize the numeric constant. - Hallvard
941 : (put 'quote 'byte-optimizer 'byte-optimize-quote)
942 : (defun byte-optimize-quote (form)
943 55 : (if (or (consp (nth 1 form))
944 55 : (and (symbolp (nth 1 form))
945 55 : (not (macroexp--const-symbol-p form))))
946 38 : form
947 55 : (nth 1 form)))
948 :
949 : (defun byte-optimize-and (form)
950 : ;; Simplify if less than 2 args.
951 : ;; if there is a literal nil in the args to `and', throw it and following
952 : ;; forms away, and surround the `and' with (progn ... nil).
953 6 : (cond ((null (cdr form)))
954 6 : ((memq nil form)
955 0 : (list 'progn
956 0 : (byte-optimize-and
957 0 : (prog1 (setq form (copy-sequence form))
958 0 : (while (nth 1 form)
959 0 : (setq form (cdr form)))
960 0 : (setcdr form nil)))
961 0 : nil))
962 6 : ((null (cdr (cdr form)))
963 0 : (nth 1 form))
964 6 : ((byte-optimize-predicate form))))
965 :
966 : (defun byte-optimize-or (form)
967 : ;; Throw away nil's, and simplify if less than 2 args.
968 : ;; If there is a literal non-nil constant in the args to `or', throw away all
969 : ;; following forms.
970 18 : (if (memq nil form)
971 18 : (setq form (delq nil (copy-sequence form))))
972 18 : (let ((rest form))
973 36 : (while (cdr (setq rest (cdr rest)))
974 18 : (if (byte-compile-trueconstp (car rest))
975 0 : (setq form (copy-sequence form)
976 18 : rest (setcdr (memq (car rest) form) nil))))
977 18 : (if (cdr (cdr form))
978 16 : (byte-optimize-predicate form)
979 18 : (nth 1 form))))
980 :
981 : (defun byte-optimize-cond (form)
982 : ;; if any clauses have a literal nil as their test, throw them away.
983 : ;; if any clause has a literal non-nil constant as its test, throw
984 : ;; away all following clauses.
985 0 : (let (rest)
986 : ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
987 0 : (while (setq rest (assq nil (cdr form)))
988 0 : (setq form (delq rest (copy-sequence form))))
989 0 : (if (memq nil (cdr form))
990 0 : (setq form (delq nil (copy-sequence form))))
991 0 : (setq rest form)
992 0 : (while (setq rest (cdr rest))
993 0 : (cond ((byte-compile-trueconstp (car-safe (car rest)))
994 : ;; This branch will always be taken: kill the subsequent ones.
995 0 : (cond ((eq rest (cdr form)) ;First branch of `cond'.
996 0 : (setq form `(progn ,@(car rest))))
997 0 : ((cdr rest)
998 0 : (setq form (copy-sequence form))
999 0 : (setcdr (memq (car rest) form) nil)))
1000 0 : (setq rest nil))
1001 0 : ((and (consp (car rest))
1002 0 : (byte-compile-nilconstp (caar rest)))
1003 : ;; This branch will never be taken: kill its body.
1004 0 : (setcdr (car rest) nil)))))
1005 : ;;
1006 : ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
1007 0 : (if (eq 'cond (car-safe form))
1008 0 : (let ((clauses (cdr form)))
1009 0 : (if (and (consp (car clauses))
1010 0 : (null (cdr (car clauses))))
1011 0 : (list 'or (car (car clauses))
1012 0 : (byte-optimize-cond
1013 0 : (cons (car form) (cdr (cdr form)))))
1014 0 : form))
1015 0 : form))
1016 :
1017 : (defun byte-optimize-if (form)
1018 : ;; (if (progn <insts> <test>) <rest>) ==> (progn <insts> (if <test> <rest>))
1019 : ;; (if <true-constant> <then> <else...>) ==> <then>
1020 : ;; (if <false-constant> <then> <else...>) ==> (progn <else...>)
1021 : ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>))
1022 : ;; (if <test> <then> nil) ==> (if <test> <then>)
1023 30 : (let ((clause (nth 1 form)))
1024 30 : (cond ((and (eq (car-safe clause) 'progn)
1025 : ;; `clause' is a proper list.
1026 30 : (null (cdr (last clause))))
1027 0 : (if (null (cddr clause))
1028 : ;; A trivial `progn'.
1029 0 : (byte-optimize-if `(if ,(cadr clause) ,@(nthcdr 2 form)))
1030 0 : (nconc (butlast clause)
1031 0 : (list
1032 0 : (byte-optimize-if
1033 0 : `(if ,(car (last clause)) ,@(nthcdr 2 form)))))))
1034 30 : ((byte-compile-trueconstp clause)
1035 0 : `(progn ,clause ,(nth 2 form)))
1036 30 : ((byte-compile-nilconstp clause)
1037 0 : `(progn ,clause ,@(nthcdr 3 form)))
1038 30 : ((nth 2 form)
1039 30 : (if (equal '(nil) (nthcdr 3 form))
1040 0 : (list 'if clause (nth 2 form))
1041 30 : form))
1042 0 : ((or (nth 3 form) (nthcdr 4 form))
1043 0 : (list 'if
1044 : ;; Don't make a double negative;
1045 : ;; instead, take away the one that is there.
1046 0 : (if (and (consp clause) (memq (car clause) '(not null))
1047 0 : (= (length clause) 2)) ; (not xxxx) or (not (xxxx))
1048 0 : (nth 1 clause)
1049 0 : (list 'not clause))
1050 0 : (if (nthcdr 4 form)
1051 0 : (cons 'progn (nthcdr 3 form))
1052 0 : (nth 3 form))))
1053 : (t
1054 30 : (list 'progn clause nil)))))
1055 :
1056 : (defun byte-optimize-while (form)
1057 0 : (when (< (length form) 2)
1058 0 : (byte-compile-warn "too few arguments for `while'"))
1059 0 : (if (nth 1 form)
1060 0 : form))
1061 :
1062 : (put 'and 'byte-optimizer 'byte-optimize-and)
1063 : (put 'or 'byte-optimizer 'byte-optimize-or)
1064 : (put 'cond 'byte-optimizer 'byte-optimize-cond)
1065 : (put 'if 'byte-optimizer 'byte-optimize-if)
1066 : (put 'while 'byte-optimizer 'byte-optimize-while)
1067 :
1068 : ;; byte-compile-negation-optimizer lives in bytecomp.el
1069 : (put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
1070 : (put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
1071 : (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
1072 :
1073 :
1074 : (defun byte-optimize-funcall (form)
1075 : ;; (funcall (lambda ...) ...) ==> ((lambda ...) ...)
1076 : ;; (funcall foo ...) ==> (foo ...)
1077 26 : (let ((fn (nth 1 form)))
1078 26 : (if (memq (car-safe fn) '(quote function))
1079 2 : (cons (nth 1 fn) (cdr (cdr form)))
1080 26 : form)))
1081 :
1082 : (defun byte-optimize-apply (form)
1083 : ;; If the last arg is a literal constant, turn this into a funcall.
1084 : ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...).
1085 20 : (let ((fn (nth 1 form))
1086 20 : (last (nth (1- (length form)) form))) ; I think this really is fastest
1087 20 : (or (if (or (null last)
1088 20 : (eq (car-safe last) 'quote))
1089 0 : (if (listp (nth 1 last))
1090 0 : (let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
1091 0 : (nconc (list 'funcall fn) butlast
1092 0 : (mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
1093 0 : (byte-compile-warn
1094 : "last arg to apply can't be a literal atom: `%s'"
1095 0 : (prin1-to-string last))
1096 20 : nil))
1097 20 : form)))
1098 :
1099 : (put 'funcall 'byte-optimizer 'byte-optimize-funcall)
1100 : (put 'apply 'byte-optimizer 'byte-optimize-apply)
1101 :
1102 :
1103 : (put 'let 'byte-optimizer 'byte-optimize-letX)
1104 : (put 'let* 'byte-optimizer 'byte-optimize-letX)
1105 : (defun byte-optimize-letX (form)
1106 35 : (cond ((null (nth 1 form))
1107 : ;; No bindings
1108 5 : (cons 'progn (cdr (cdr form))))
1109 30 : ((or (nth 2 form) (nthcdr 3 form))
1110 30 : form)
1111 : ;; The body is nil
1112 0 : ((eq (car form) 'let)
1113 0 : (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form)))
1114 0 : '(nil)))
1115 : (t
1116 0 : (let ((binds (reverse (nth 1 form))))
1117 35 : (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil)))))
1118 :
1119 :
1120 : (put 'nth 'byte-optimizer 'byte-optimize-nth)
1121 : (defun byte-optimize-nth (form)
1122 0 : (if (= (safe-length form) 3)
1123 0 : (if (memq (nth 1 form) '(0 1))
1124 0 : (list 'car (if (zerop (nth 1 form))
1125 0 : (nth 2 form)
1126 0 : (list 'cdr (nth 2 form))))
1127 0 : (byte-optimize-predicate form))
1128 0 : form))
1129 :
1130 : (put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr)
1131 : (defun byte-optimize-nthcdr (form)
1132 0 : (if (= (safe-length form) 3)
1133 0 : (if (memq (nth 1 form) '(0 1 2))
1134 0 : (let ((count (nth 1 form)))
1135 0 : (setq form (nth 2 form))
1136 0 : (while (>= (setq count (1- count)) 0)
1137 0 : (setq form (list 'cdr form)))
1138 0 : form)
1139 0 : (byte-optimize-predicate form))
1140 0 : form))
1141 :
1142 : ;; Fixme: delete-char -> delete-region (byte-coded)
1143 : ;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte,
1144 : ;; string-make-multibyte for constant args.
1145 :
1146 : (put 'set 'byte-optimizer 'byte-optimize-set)
1147 : (defun byte-optimize-set (form)
1148 0 : (let ((var (car-safe (cdr-safe form))))
1149 0 : (cond
1150 0 : ((and (eq (car-safe var) 'quote) (consp (cdr var)))
1151 0 : `(setq ,(cadr var) ,@(cddr form)))
1152 0 : ((and (eq (car-safe var) 'make-local-variable)
1153 0 : (eq (car-safe (setq var (car-safe (cdr var)))) 'quote)
1154 0 : (consp (cdr var)))
1155 0 : `(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form))))
1156 0 : (t form))))
1157 :
1158 : ;; enumerating those functions which need not be called if the returned
1159 : ;; value is not used. That is, something like
1160 : ;; (progn (list (something-with-side-effects) (yow))
1161 : ;; (foo))
1162 : ;; may safely be turned into
1163 : ;; (progn (progn (something-with-side-effects) (yow))
1164 : ;; (foo))
1165 : ;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo.
1166 :
1167 : ;; Some of these functions have the side effect of allocating memory
1168 : ;; and it would be incorrect to replace two calls with one.
1169 : ;; But we don't try to do those kinds of optimizations,
1170 : ;; so it is safe to list such functions here.
1171 : ;; Some of these functions return values that depend on environment
1172 : ;; state, so that constant folding them would be wrong,
1173 : ;; but we don't do constant folding based on this list.
1174 :
1175 : ;; However, at present the only optimization we normally do
1176 : ;; is delete calls that need not occur, and we only do that
1177 : ;; with the error-free functions.
1178 :
1179 : ;; I wonder if I missed any :-\)
1180 : (let ((side-effect-free-fns
1181 : '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
1182 : assoc assq
1183 : boundp buffer-file-name buffer-local-variables buffer-modified-p
1184 : buffer-substring byte-code-function-p
1185 : capitalize car-less-than-car car cdr ceiling char-after char-before
1186 : char-equal char-to-string char-width compare-strings
1187 : compare-window-configurations concat coordinates-in-window-p
1188 : copy-alist copy-sequence copy-marker cos count-lines
1189 : decode-char
1190 : decode-time default-boundp default-value documentation downcase
1191 : elt encode-char exp expt encode-time error-message-string
1192 : fboundp fceiling featurep ffloor
1193 : file-directory-p file-exists-p file-locked-p file-name-absolute-p
1194 : file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
1195 : float float-time floor format format-time-string frame-first-window
1196 : frame-root-window frame-selected-window
1197 : frame-visible-p fround ftruncate
1198 : get gethash get-buffer get-buffer-window getenv get-file-buffer
1199 : hash-table-count
1200 : int-to-string intern-soft
1201 : keymap-parent
1202 : length local-variable-if-set-p local-variable-p log log10 logand
1203 : logb logior lognot logxor lsh langinfo
1204 : make-list make-string make-symbol marker-buffer max member memq min
1205 : minibuffer-selected-window minibuffer-window
1206 : mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
1207 : parse-colon-path plist-get plist-member
1208 : prefix-numeric-value previous-window prin1-to-string propertize
1209 : degrees-to-radians
1210 : radians-to-degrees rassq rassoc read-from-string regexp-quote
1211 : region-beginning region-end reverse round
1212 : sin sqrt string string< string= string-equal string-lessp string-to-char
1213 : string-to-int string-to-number substring
1214 : sxhash sxhash-equal sxhash-eq sxhash-eql
1215 : symbol-function symbol-name symbol-plist symbol-value string-make-unibyte
1216 : string-make-multibyte string-as-multibyte string-as-unibyte
1217 : string-to-multibyte
1218 : tan truncate
1219 : unibyte-char-to-multibyte upcase user-full-name
1220 : user-login-name user-original-login-name custom-variable-p
1221 : vconcat
1222 : window-absolute-pixel-edges window-at window-body-height
1223 : window-body-width window-buffer window-dedicated-p window-display-table
1224 : window-combination-limit window-edges window-frame window-fringes
1225 : window-height window-hscroll window-inside-edges
1226 : window-inside-absolute-pixel-edges window-inside-pixel-edges
1227 : window-left-child window-left-column window-margins window-minibuffer-p
1228 : window-next-buffers window-next-sibling window-new-normal
1229 : window-new-total window-normal-size window-parameter window-parameters
1230 : window-parent window-pixel-edges window-point window-prev-buffers
1231 : window-prev-sibling window-redisplay-end-trigger window-scroll-bars
1232 : window-start window-text-height window-top-child window-top-line
1233 : window-total-height window-total-width window-use-time window-vscroll
1234 : window-width zerop))
1235 : (side-effect-and-error-free-fns
1236 : '(arrayp atom
1237 : bobp bolp bool-vector-p
1238 : buffer-end buffer-list buffer-size buffer-string bufferp
1239 : car-safe case-table-p cdr-safe char-or-string-p characterp
1240 : charsetp commandp cons consp
1241 : current-buffer current-global-map current-indentation
1242 : current-local-map current-minor-mode-maps current-time
1243 : current-time-string current-time-zone
1244 : eobp eolp eq equal eventp
1245 : floatp following-char framep
1246 : get-largest-window get-lru-window
1247 : hash-table-p
1248 : identity ignore integerp integer-or-marker-p interactive-p
1249 : invocation-directory invocation-name
1250 : keymapp keywordp
1251 : line-beginning-position line-end-position list listp
1252 : make-marker mark mark-marker markerp max-char
1253 : memory-limit minibuffer-window
1254 : mouse-movement-p
1255 : natnump nlistp not null number-or-marker-p numberp
1256 : one-window-p overlayp
1257 : point point-marker point-min point-max preceding-char primary-charset
1258 : processp
1259 : recent-keys recursion-depth
1260 : safe-length selected-frame selected-window sequencep
1261 : standard-case-table standard-syntax-table stringp subrp symbolp
1262 : syntax-table syntax-table-p
1263 : this-command-keys this-command-keys-vector this-single-command-keys
1264 : this-single-command-raw-keys
1265 : user-real-login-name user-real-uid user-uid
1266 : vector vectorp visible-frame-list
1267 : wholenump window-configuration-p window-live-p
1268 : window-valid-p windowp)))
1269 : (while side-effect-free-fns
1270 : (put (car side-effect-free-fns) 'side-effect-free t)
1271 : (setq side-effect-free-fns (cdr side-effect-free-fns)))
1272 : (while side-effect-and-error-free-fns
1273 : (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
1274 : (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
1275 : nil)
1276 :
1277 :
1278 : ;; pure functions are side-effect free functions whose values depend
1279 : ;; only on their arguments. For these functions, calls with constant
1280 : ;; arguments can be evaluated at compile time. This may shift run time
1281 : ;; errors to compile time.
1282 :
1283 : (let ((pure-fns
1284 : '(concat symbol-name regexp-opt regexp-quote string-to-syntax)))
1285 : (while pure-fns
1286 : (put (car pure-fns) 'pure t)
1287 : (setq pure-fns (cdr pure-fns)))
1288 : nil)
1289 :
1290 : (defconst byte-constref-ops
1291 : '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
1292 :
1293 : ;; Used and set dynamically in byte-decompile-bytecode-1.
1294 : (defvar bytedecomp-op)
1295 : (defvar bytedecomp-ptr)
1296 :
1297 : ;; This function extracts the bitfields from variable-length opcodes.
1298 : ;; Originally defined in disass.el (which no longer uses it.)
1299 : (defun disassemble-offset (bytes)
1300 : "Don't call this!"
1301 : ;; Fetch and return the offset for the current opcode.
1302 : ;; Return nil if this opcode has no offset.
1303 0 : (cond ((< bytedecomp-op byte-pophandler)
1304 0 : (let ((tem (logand bytedecomp-op 7)))
1305 0 : (setq bytedecomp-op (logand bytedecomp-op 248))
1306 0 : (cond ((eq tem 6)
1307 : ;; Offset in next byte.
1308 0 : (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1309 0 : (aref bytes bytedecomp-ptr))
1310 0 : ((eq tem 7)
1311 : ;; Offset in next 2 bytes.
1312 0 : (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1313 0 : (+ (aref bytes bytedecomp-ptr)
1314 0 : (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1315 0 : (lsh (aref bytes bytedecomp-ptr) 8))))
1316 0 : (t tem)))) ;Offset was in opcode.
1317 0 : ((>= bytedecomp-op byte-constant)
1318 0 : (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
1319 0 : (setq bytedecomp-op byte-constant)))
1320 0 : ((or (and (>= bytedecomp-op byte-constant2)
1321 0 : (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
1322 0 : (memq bytedecomp-op (eval-when-compile
1323 1 : (list byte-stack-set2 byte-pushcatch
1324 1 : byte-pushconditioncase))))
1325 : ;; Offset in next 2 bytes.
1326 0 : (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1327 0 : (+ (aref bytes bytedecomp-ptr)
1328 0 : (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
1329 0 : (lsh (aref bytes bytedecomp-ptr) 8))))
1330 0 : ((and (>= bytedecomp-op byte-listN)
1331 0 : (<= bytedecomp-op byte-discardN))
1332 0 : (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
1333 0 : (aref bytes bytedecomp-ptr))))
1334 :
1335 : (defvar byte-compile-tag-number)
1336 :
1337 : ;; This de-compiler is used for inline expansion of compiled functions,
1338 : ;; and by the disassembler.
1339 : ;;
1340 : ;; This list contains numbers, which are pc values,
1341 : ;; before each instruction.
1342 : (defun byte-decompile-bytecode (bytes constvec)
1343 : "Turn BYTECODE into lapcode, referring to CONSTVEC."
1344 0 : (let ((byte-compile-constants nil)
1345 : (byte-compile-variables nil)
1346 : (byte-compile-tag-number 0))
1347 0 : (byte-decompile-bytecode-1 bytes constvec)))
1348 :
1349 : ;; As byte-decompile-bytecode, but updates
1350 : ;; byte-compile-{constants, variables, tag-number}.
1351 : ;; If MAKE-SPLICEABLE is true, then `return' opcodes are replaced
1352 : ;; with `goto's destined for the end of the code.
1353 : ;; That is for use by the compiler.
1354 : ;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
1355 : ;; In that case, we put a pc value into the list
1356 : ;; before each insn (or its label).
1357 : (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
1358 0 : (let ((length (length bytes))
1359 : (bytedecomp-ptr 0) optr tags bytedecomp-op offset
1360 : lap tmp last-constant)
1361 0 : (while (not (= bytedecomp-ptr length))
1362 0 : (or make-spliceable
1363 0 : (push bytedecomp-ptr lap))
1364 0 : (setq bytedecomp-op (aref bytes bytedecomp-ptr)
1365 0 : optr bytedecomp-ptr
1366 : ;; This uses dynamic-scope magic.
1367 0 : offset (disassemble-offset bytes))
1368 0 : (let ((opcode (aref byte-code-vector bytedecomp-op)))
1369 0 : (cl-assert opcode)
1370 0 : (setq bytedecomp-op opcode))
1371 0 : (cond ((memq bytedecomp-op byte-goto-ops)
1372 : ;; It's a pc.
1373 0 : (setq offset
1374 0 : (cdr (or (assq offset tags)
1375 0 : (let ((new (cons offset (byte-compile-make-tag))))
1376 0 : (push new tags)
1377 0 : new)))))
1378 0 : ((cond ((eq bytedecomp-op 'byte-constant2)
1379 0 : (setq bytedecomp-op 'byte-constant) t)
1380 0 : ((memq bytedecomp-op byte-constref-ops)))
1381 0 : (setq tmp (if (>= offset (length constvec))
1382 0 : (list 'out-of-range offset)
1383 0 : (aref constvec offset))
1384 0 : offset (if (eq bytedecomp-op 'byte-constant)
1385 0 : (byte-compile-get-constant tmp)
1386 0 : (or (assq tmp byte-compile-variables)
1387 0 : (let ((new (list tmp)))
1388 0 : (push new byte-compile-variables)
1389 0 : new)))
1390 0 : last-constant tmp))
1391 0 : ((eq bytedecomp-op 'byte-stack-set2)
1392 0 : (setq bytedecomp-op 'byte-stack-set))
1393 0 : ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
1394 : ;; The top bit of the operand for byte-discardN is a flag,
1395 : ;; saying whether the top-of-stack is preserved. In
1396 : ;; lapcode, we represent this by using a different opcode
1397 : ;; (with the flag removed from the operand).
1398 0 : (setq bytedecomp-op 'byte-discardN-preserve-tos)
1399 0 : (setq offset (- offset #x80)))
1400 0 : ((eq bytedecomp-op 'byte-switch)
1401 0 : (cl-assert (hash-table-p last-constant) nil
1402 0 : "byte-switch used without preceeding hash table")
1403 : ;; We cannot use the original hash table referenced in the op,
1404 : ;; so we create a copy of it, and replace the addresses with
1405 : ;; TAGs.
1406 0 : (let ((orig-table last-constant))
1407 0 : (cl-loop for e across constvec
1408 0 : when (eq e last-constant)
1409 0 : do (setq last-constant (copy-hash-table e))
1410 0 : and return nil)
1411 : ;; Replace all addresses with TAGs.
1412 0 : (maphash #'(lambda (value tag)
1413 0 : (let (newtag)
1414 0 : (setq newtag (byte-compile-make-tag))
1415 0 : (push (cons tag newtag) tags)
1416 0 : (puthash value newtag last-constant)))
1417 0 : last-constant)
1418 : ;; Replace the hash table referenced in the lapcode with our
1419 : ;; modified one.
1420 0 : (cl-loop for el in-ref lap
1421 0 : when (and (listp el) ;; make sure we're at the correct op
1422 0 : (eq (nth 1 el) 'byte-constant)
1423 0 : (eq (nth 2 el) orig-table))
1424 : ;; Jump tables are never reused, so do this exactly
1425 : ;; once.
1426 0 : do (setf (nth 2 el) last-constant) and return nil))))
1427 : ;; lap = ( [ (pc . (op . arg)) ]* )
1428 0 : (push (cons optr (cons bytedecomp-op (or offset 0)))
1429 0 : lap)
1430 0 : (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
1431 0 : (let ((rest lap))
1432 0 : (while rest
1433 0 : (cond ((numberp (car rest)))
1434 0 : ((setq tmp (assq (car (car rest)) tags))
1435 : ;; This addr is jumped to.
1436 0 : (setcdr rest (cons (cons nil (cdr tmp))
1437 0 : (cdr rest)))
1438 0 : (setq tags (delq tmp tags))
1439 0 : (setq rest (cdr rest))))
1440 0 : (setq rest (cdr rest))))
1441 0 : (if tags (error "optimizer error: missed tags %s" tags))
1442 : ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
1443 0 : (mapcar (function (lambda (elt)
1444 0 : (if (numberp elt)
1445 0 : elt
1446 0 : (cdr elt))))
1447 0 : (nreverse lap))))
1448 :
1449 :
1450 : ;;; peephole optimizer
1451 :
1452 : (defconst byte-tagref-ops (cons 'TAG byte-goto-ops))
1453 :
1454 : (defconst byte-conditional-ops
1455 : '(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
1456 : byte-goto-if-not-nil-else-pop))
1457 :
1458 : (defconst byte-after-unbind-ops
1459 : '(byte-constant byte-dup
1460 : byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
1461 : byte-eq byte-not
1462 : byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4
1463 : byte-interactive-p)
1464 : ;; How about other side-effect-free-ops? Is it safe to move an
1465 : ;; error invocation (such as from nth) out of an unwind-protect?
1466 : ;; No, it is not, because the unwind-protect forms can alter
1467 : ;; the inside of the object to which nth would apply.
1468 : ;; For the same reason, byte-equal was deleted from this list.
1469 : "Byte-codes that can be moved past an unbind.")
1470 :
1471 : (defconst byte-compile-side-effect-and-error-free-ops
1472 : '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
1473 : byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
1474 : byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
1475 : byte-point-min byte-following-char byte-preceding-char
1476 : byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
1477 : byte-current-buffer byte-stack-ref))
1478 :
1479 : (defconst byte-compile-side-effect-free-ops
1480 : (nconc
1481 : '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
1482 : byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
1483 : byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
1484 : byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
1485 : byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
1486 : byte-member byte-assq byte-quo byte-rem)
1487 : byte-compile-side-effect-and-error-free-ops))
1488 :
1489 : ;; This crock is because of the way DEFVAR_BOOL variables work.
1490 : ;; Consider the code
1491 : ;;
1492 : ;; (defun foo (flag)
1493 : ;; (let ((old-pop-ups pop-up-windows)
1494 : ;; (pop-up-windows flag))
1495 : ;; (cond ((not (eq pop-up-windows old-pop-ups))
1496 : ;; (setq old-pop-ups pop-up-windows)
1497 : ;; ...))))
1498 : ;;
1499 : ;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is
1500 : ;; something else. But if we optimize
1501 : ;;
1502 : ;; varref flag
1503 : ;; varbind pop-up-windows
1504 : ;; varref pop-up-windows
1505 : ;; not
1506 : ;; to
1507 : ;; varref flag
1508 : ;; dup
1509 : ;; varbind pop-up-windows
1510 : ;; not
1511 : ;;
1512 : ;; we break the program, because it will appear that pop-up-windows and
1513 : ;; old-pop-ups are not EQ when really they are. So we have to know what
1514 : ;; the BOOL variables are, and not perform this optimization on them.
1515 :
1516 : ;; The variable `byte-boolean-vars' is now primitive and updated
1517 : ;; automatically by DEFVAR_BOOL.
1518 :
1519 : (defun byte-optimize-lapcode (lap &optional _for-effect)
1520 : "Simple peephole optimizer. LAP is both modified and returned.
1521 : If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
1522 15 : (let (lap0
1523 : lap1
1524 : lap2
1525 : (keep-going 'first-time)
1526 : (add-depth 0)
1527 : rest tmp tmp2 tmp3
1528 15 : (side-effect-free (if byte-compile-delete-errors
1529 0 : byte-compile-side-effect-free-ops
1530 15 : byte-compile-side-effect-and-error-free-ops)))
1531 40 : (while keep-going
1532 25 : (or (eq keep-going 'first-time)
1533 25 : (byte-compile-log-lap " ---- next pass"))
1534 25 : (setq rest lap
1535 25 : keep-going nil)
1536 932 : (while rest
1537 907 : (setq lap0 (car rest)
1538 907 : lap1 (nth 1 rest)
1539 907 : lap2 (nth 2 rest))
1540 :
1541 : ;; You may notice that sequences like "dup varset discard" are
1542 : ;; optimized but sequences like "dup varset TAG1: discard" are not.
1543 : ;; You may be tempted to change this; resist that temptation.
1544 907 : (cond ;;
1545 : ;; <side-effect-free> pop --> <deleted>
1546 : ;; ...including:
1547 : ;; const-X pop --> <deleted>
1548 : ;; varref-X pop --> <deleted>
1549 : ;; dup pop --> <deleted>
1550 : ;;
1551 907 : ((and (eq 'byte-discard (car lap1))
1552 907 : (memq (car lap0) side-effect-free))
1553 0 : (setq keep-going t)
1554 0 : (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
1555 0 : (setq rest (cdr rest))
1556 0 : (cond ((= tmp 1)
1557 0 : (byte-compile-log-lap
1558 0 : " %s discard\t-->\t<deleted>" lap0)
1559 0 : (setq lap (delq lap0 (delq lap1 lap))))
1560 0 : ((= tmp 0)
1561 0 : (byte-compile-log-lap
1562 0 : " %s discard\t-->\t<deleted> discard" lap0)
1563 0 : (setq lap (delq lap0 lap)))
1564 0 : ((= tmp -1)
1565 0 : (byte-compile-log-lap
1566 0 : " %s discard\t-->\tdiscard discard" lap0)
1567 0 : (setcar lap0 'byte-discard)
1568 0 : (setcdr lap0 0))
1569 0 : ((error "Optimizer error: too much on the stack"))))
1570 : ;;
1571 : ;; goto*-X X: --> X:
1572 : ;;
1573 907 : ((and (memq (car lap0) byte-goto-ops)
1574 907 : (eq (cdr lap0) lap1))
1575 0 : (cond ((eq (car lap0) 'byte-goto)
1576 0 : (setq lap (delq lap0 lap))
1577 0 : (setq tmp "<deleted>"))
1578 0 : ((memq (car lap0) byte-goto-always-pop-ops)
1579 0 : (setcar lap0 (setq tmp 'byte-discard))
1580 0 : (setcdr lap0 0))
1581 0 : ((error "Depth conflict at tag %d" (nth 2 lap0))))
1582 0 : (and (memq byte-optimize-log '(t byte))
1583 0 : (byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
1584 : (nth 1 lap1) (nth 1 lap1)
1585 0 : tmp (nth 1 lap1)))
1586 0 : (setq keep-going t))
1587 : ;;
1588 : ;; varset-X varref-X --> dup varset-X
1589 : ;; varbind-X varref-X --> dup varbind-X
1590 : ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
1591 : ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
1592 : ;; The latter two can enable other optimizations.
1593 : ;;
1594 : ;; For lexical variables, we could do the same
1595 : ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
1596 : ;; but this is a very minor gain, since dup is stack-ref-0,
1597 : ;; i.e. it's only better if X>5, and even then it comes
1598 : ;; at the cost of an extra stack slot. Let's not bother.
1599 907 : ((and (eq 'byte-varref (car lap2))
1600 4 : (eq (cdr lap1) (cdr lap2))
1601 907 : (memq (car lap1) '(byte-varset byte-varbind)))
1602 0 : (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
1603 0 : (not (eq (car lap0) 'byte-constant)))
1604 : nil
1605 0 : (setq keep-going t)
1606 0 : (if (memq (car lap0) '(byte-constant byte-dup))
1607 0 : (progn
1608 0 : (setq tmp (if (or (not tmp)
1609 0 : (macroexp--const-symbol-p
1610 0 : (car (cdr lap0))))
1611 0 : (cdr lap0)
1612 0 : (byte-compile-get-constant t)))
1613 0 : (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
1614 : lap0 lap1 lap2 lap0 lap1
1615 0 : (cons (car lap0) tmp))
1616 0 : (setcar lap2 (car lap0))
1617 0 : (setcdr lap2 tmp))
1618 0 : (byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
1619 0 : (setcar lap2 (car lap1))
1620 0 : (setcar lap1 'byte-dup)
1621 0 : (setcdr lap1 0)
1622 : ;; The stack depth gets locally increased, so we will
1623 : ;; increase maxdepth in case depth = maxdepth here.
1624 : ;; This can cause the third argument to byte-code to
1625 : ;; be larger than necessary.
1626 0 : (setq add-depth 1))))
1627 : ;;
1628 : ;; dup varset-X discard --> varset-X
1629 : ;; dup varbind-X discard --> varbind-X
1630 : ;; dup stack-set-X discard --> stack-set-X-1
1631 : ;; (the varbind variant can emerge from other optimizations)
1632 : ;;
1633 907 : ((and (eq 'byte-dup (car lap0))
1634 10 : (eq 'byte-discard (car lap2))
1635 0 : (memq (car lap1) '(byte-varset byte-varbind
1636 907 : byte-stack-set)))
1637 0 : (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
1638 0 : (setq keep-going t
1639 0 : rest (cdr rest))
1640 0 : (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
1641 0 : (setq lap (delq lap0 (delq lap2 lap))))
1642 : ;;
1643 : ;; not goto-X-if-nil --> goto-X-if-non-nil
1644 : ;; not goto-X-if-non-nil --> goto-X-if-nil
1645 : ;;
1646 : ;; it is wrong to do the same thing for the -else-pop variants.
1647 : ;;
1648 907 : ((and (eq 'byte-not (car lap0))
1649 907 : (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
1650 0 : (byte-compile-log-lap " not %s\t-->\t%s"
1651 : lap1
1652 : (cons
1653 : (if (eq (car lap1) 'byte-goto-if-nil)
1654 : 'byte-goto-if-not-nil
1655 : 'byte-goto-if-nil)
1656 0 : (cdr lap1)))
1657 0 : (setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
1658 : 'byte-goto-if-not-nil
1659 0 : 'byte-goto-if-nil))
1660 0 : (setq lap (delq lap0 lap))
1661 0 : (setq keep-going t))
1662 : ;;
1663 : ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1664 : ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1665 : ;;
1666 : ;; it is wrong to do the same thing for the -else-pop variants.
1667 : ;;
1668 907 : ((and (memq (car lap0)
1669 907 : '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
1670 28 : (eq 'byte-goto (car lap1)) ; gotoY
1671 907 : (eq (cdr lap0) lap2)) ; TAG X
1672 0 : (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1673 0 : 'byte-goto-if-not-nil 'byte-goto-if-nil)))
1674 0 : (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
1675 : lap0 lap1 lap2
1676 0 : (cons inverse (cdr lap1)) lap2)
1677 0 : (setq lap (delq lap0 lap))
1678 0 : (setcar lap1 inverse)
1679 0 : (setq keep-going t)))
1680 : ;;
1681 : ;; const goto-if-* --> whatever
1682 : ;;
1683 907 : ((and (eq 'byte-constant (car lap0))
1684 317 : (memq (car lap1) byte-conditional-ops)
1685 : ;; If the `byte-constant's cdr is not a cons cell, it has
1686 : ;; to be an index into the constant pool); even though
1687 : ;; it'll be a constant, that constant is not known yet
1688 : ;; (it's typically a free variable of a closure, so will
1689 : ;; only be known when the closure will be built at
1690 : ;; run-time).
1691 907 : (consp (cdr lap0)))
1692 0 : (cond ((if (memq (car lap1) '(byte-goto-if-nil
1693 0 : byte-goto-if-nil-else-pop))
1694 0 : (car (cdr lap0))
1695 0 : (not (car (cdr lap0))))
1696 0 : (byte-compile-log-lap " %s %s\t-->\t<deleted>"
1697 0 : lap0 lap1)
1698 0 : (setq rest (cdr rest)
1699 0 : lap (delq lap0 (delq lap1 lap))))
1700 : (t
1701 0 : (byte-compile-log-lap " %s %s\t-->\t%s"
1702 : lap0 lap1
1703 0 : (cons 'byte-goto (cdr lap1)))
1704 0 : (when (memq (car lap1) byte-goto-always-pop-ops)
1705 0 : (setq lap (delq lap0 lap)))
1706 0 : (setcar lap1 'byte-goto)))
1707 0 : (setq keep-going t))
1708 : ;;
1709 : ;; varref-X varref-X --> varref-X dup
1710 : ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
1711 : ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
1712 : ;; We don't optimize the const-X variations on this here,
1713 : ;; because that would inhibit some goto optimizations; we
1714 : ;; optimize the const-X case after all other optimizations.
1715 : ;;
1716 907 : ((and (memq (car lap0) '(byte-varref byte-stack-ref))
1717 182 : (progn
1718 182 : (setq tmp (cdr rest))
1719 182 : (setq tmp2 0)
1720 182 : (while (eq (car (car tmp)) 'byte-dup)
1721 0 : (setq tmp2 (1+ tmp2))
1722 182 : (setq tmp (cdr tmp)))
1723 182 : t)
1724 182 : (eq (if (eq 'byte-stack-ref (car lap0))
1725 178 : (+ tmp2 1 (cdr lap0))
1726 182 : (cdr lap0))
1727 182 : (cdr (car tmp)))
1728 907 : (eq (car lap0) (car (car tmp))))
1729 0 : (if (memq byte-optimize-log '(t byte))
1730 0 : (let ((str ""))
1731 0 : (setq tmp2 (cdr rest))
1732 0 : (while (not (eq tmp tmp2))
1733 0 : (setq tmp2 (cdr tmp2)
1734 0 : str (concat str " dup")))
1735 0 : (byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
1736 0 : lap0 str lap0 lap0 str)))
1737 0 : (setq keep-going t)
1738 0 : (setcar (car tmp) 'byte-dup)
1739 0 : (setcdr (car tmp) 0)
1740 0 : (setq rest tmp))
1741 : ;;
1742 : ;; TAG1: TAG2: --> TAG1: <deleted>
1743 : ;; (and other references to TAG2 are replaced with TAG1)
1744 : ;;
1745 907 : ((and (eq (car lap0) 'TAG)
1746 907 : (eq (car lap1) 'TAG))
1747 3 : (and (memq byte-optimize-log '(t byte))
1748 0 : (byte-compile-log " adjacent tags %d and %d merged"
1749 3 : (nth 1 lap1) (nth 1 lap0)))
1750 3 : (setq tmp3 lap)
1751 6 : (while (setq tmp2 (rassq lap0 tmp3))
1752 3 : (setcdr tmp2 lap1)
1753 3 : (setq tmp3 (cdr (memq tmp2 tmp3))))
1754 3 : (setq lap (delq lap0 lap)
1755 3 : keep-going t)
1756 : ;; replace references to tag in jump tables, if any
1757 3 : (dolist (table byte-compile-jump-tables)
1758 0 : (catch 'break
1759 0 : (maphash #'(lambda (value tag)
1760 0 : (when (equal tag lap0)
1761 : ;; each tag occurs only once in the jump table
1762 0 : (puthash value lap1 table)
1763 0 : (throw 'break nil)))
1764 3 : table))))
1765 : ;;
1766 : ;; unused-TAG: --> <deleted>
1767 : ;;
1768 904 : ((and (eq 'TAG (car lap0))
1769 80 : (not (rassq lap0 lap))
1770 : ;; make sure this tag isn't used in a jump-table
1771 10 : (cl-loop for table in byte-compile-jump-tables
1772 0 : when (member lap0 (hash-table-values table))
1773 904 : return nil finally return t))
1774 10 : (and (memq byte-optimize-log '(t byte))
1775 10 : (byte-compile-log " unused tag %d removed" (nth 1 lap0)))
1776 10 : (setq lap (delq lap0 lap)
1777 10 : keep-going t))
1778 : ;;
1779 : ;; goto ... --> goto <delete until TAG or end>
1780 : ;; return ... --> return <delete until TAG or end>
1781 : ;; (unless a jump-table is being used, where deleting may affect
1782 : ;; other valid case bodies)
1783 : ;;
1784 894 : ((and (memq (car lap0) '(byte-goto byte-return))
1785 53 : (not (memq (car lap1) '(TAG nil)))
1786 : ;; FIXME: Instead of deferring simply when jump-tables are
1787 : ;; being used, keep a list of tags used for switch tags and
1788 : ;; use them instead (see `byte-compile-inline-lapcode').
1789 894 : (not byte-compile-jump-tables))
1790 0 : (setq tmp rest)
1791 0 : (let ((i 0)
1792 0 : (opt-p (memq byte-optimize-log '(t lap)))
1793 : str deleted)
1794 0 : (while (and (setq tmp (cdr tmp))
1795 0 : (not (eq 'TAG (car (car tmp)))))
1796 0 : (if opt-p (setq deleted (cons (car tmp) deleted)
1797 0 : str (concat str " %s")
1798 0 : i (1+ i))))
1799 0 : (if opt-p
1800 0 : (let ((tagstr
1801 0 : (if (eq 'TAG (car (car tmp)))
1802 0 : (format "%d:" (car (cdr (car tmp))))
1803 0 : (or (car tmp) ""))))
1804 0 : (if (< i 6)
1805 0 : (apply 'byte-compile-log-lap-1
1806 0 : (concat " %s" str
1807 0 : " %s\t-->\t%s <deleted> %s")
1808 0 : lap0
1809 0 : (nconc (nreverse deleted)
1810 0 : (list tagstr lap0 tagstr)))
1811 0 : (byte-compile-log-lap
1812 : " %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
1813 : lap0 i (if (= i 1) "" "s")
1814 0 : tagstr lap0 tagstr))))
1815 0 : (rplacd rest tmp))
1816 0 : (setq keep-going t))
1817 : ;;
1818 : ;; <safe-op> unbind --> unbind <safe-op>
1819 : ;; (this may enable other optimizations.)
1820 : ;;
1821 894 : ((and (eq 'byte-unbind (car lap1))
1822 894 : (memq (car lap0) byte-after-unbind-ops))
1823 0 : (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
1824 0 : (setcar rest lap1)
1825 0 : (setcar (cdr rest) lap0)
1826 0 : (setq keep-going t))
1827 : ;;
1828 : ;; varbind-X unbind-N --> discard unbind-(N-1)
1829 : ;; save-excursion unbind-N --> unbind-(N-1)
1830 : ;; save-restriction unbind-N --> unbind-(N-1)
1831 : ;;
1832 894 : ((and (eq 'byte-unbind (car lap1))
1833 0 : (memq (car lap0) '(byte-varbind byte-save-excursion
1834 0 : byte-save-restriction))
1835 894 : (< 0 (cdr lap1)))
1836 0 : (if (zerop (setcdr lap1 (1- (cdr lap1))))
1837 0 : (delq lap1 rest))
1838 0 : (if (eq (car lap0) 'byte-varbind)
1839 0 : (setcar rest (cons 'byte-discard 0))
1840 0 : (setq lap (delq lap0 lap)))
1841 0 : (byte-compile-log-lap " %s %s\t-->\t%s %s"
1842 : lap0 (cons (car lap1) (1+ (cdr lap1)))
1843 : (if (eq (car lap0) 'byte-varbind)
1844 : (car rest)
1845 : (car (cdr rest)))
1846 : (if (and (/= 0 (cdr lap1))
1847 : (eq (car lap0) 'byte-varbind))
1848 : (car (cdr rest))
1849 0 : ""))
1850 0 : (setq keep-going t))
1851 : ;;
1852 : ;; goto*-X ... X: goto-Y --> goto*-Y
1853 : ;; goto-X ... X: return --> return
1854 : ;;
1855 894 : ((and (memq (car lap0) byte-goto-ops)
1856 78 : (memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
1857 894 : '(byte-goto byte-return)))
1858 0 : (cond ((and (not (eq tmp lap0))
1859 0 : (or (eq (car lap0) 'byte-goto)
1860 0 : (eq (car tmp) 'byte-goto)))
1861 0 : (byte-compile-log-lap " %s [%s]\t-->\t%s"
1862 0 : (car lap0) tmp tmp)
1863 0 : (if (eq (car tmp) 'byte-return)
1864 0 : (setcar lap0 'byte-return))
1865 0 : (setcdr lap0 (cdr tmp))
1866 0 : (setq keep-going t))))
1867 : ;;
1868 : ;; goto-*-else-pop X ... X: goto-if-* --> whatever
1869 : ;; goto-*-else-pop X ... X: discard --> whatever
1870 : ;;
1871 894 : ((and (memq (car lap0) '(byte-goto-if-nil-else-pop
1872 894 : byte-goto-if-not-nil-else-pop))
1873 22 : (memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
1874 22 : (eval-when-compile
1875 22 : (cons 'byte-discard byte-conditional-ops)))
1876 894 : (not (eq lap0 (car tmp))))
1877 0 : (setq tmp2 (car tmp))
1878 0 : (setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
1879 : byte-goto-if-nil)
1880 : (byte-goto-if-not-nil-else-pop
1881 0 : byte-goto-if-not-nil))))
1882 0 : (if (memq (car tmp2) tmp3)
1883 0 : (progn (setcar lap0 (car tmp2))
1884 0 : (setcdr lap0 (cdr tmp2))
1885 0 : (byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
1886 0 : (car lap0) tmp2 lap0))
1887 : ;; Get rid of the -else-pop's and jump one step further.
1888 0 : (or (eq 'TAG (car (nth 1 tmp)))
1889 0 : (setcdr tmp (cons (byte-compile-make-tag)
1890 0 : (cdr tmp))))
1891 0 : (byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
1892 0 : (car lap0) tmp2 (nth 1 tmp3))
1893 0 : (setcar lap0 (nth 1 tmp3))
1894 0 : (setcdr lap0 (nth 1 tmp)))
1895 0 : (setq keep-going t))
1896 : ;;
1897 : ;; const goto-X ... X: goto-if-* --> whatever
1898 : ;; const goto-X ... X: discard --> whatever
1899 : ;;
1900 894 : ((and (eq (car lap0) 'byte-constant)
1901 317 : (eq (car lap1) 'byte-goto)
1902 0 : (memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
1903 0 : (eval-when-compile
1904 1 : (cons 'byte-discard byte-conditional-ops)))
1905 894 : (not (eq lap1 (car tmp))))
1906 0 : (setq tmp2 (car tmp))
1907 0 : (cond ((when (consp (cdr lap0))
1908 0 : (memq (car tmp2)
1909 0 : (if (null (car (cdr lap0)))
1910 : '(byte-goto-if-nil byte-goto-if-nil-else-pop)
1911 : '(byte-goto-if-not-nil
1912 0 : byte-goto-if-not-nil-else-pop))))
1913 0 : (byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
1914 0 : lap0 tmp2 lap0 tmp2)
1915 0 : (setcar lap1 (car tmp2))
1916 0 : (setcdr lap1 (cdr tmp2))
1917 : ;; Let next step fix the (const,goto-if*) sequence.
1918 0 : (setq rest (cons nil rest))
1919 0 : (setq keep-going t))
1920 0 : ((or (consp (cdr lap0))
1921 0 : (eq (car tmp2) 'byte-discard))
1922 : ;; Jump one step further
1923 0 : (byte-compile-log-lap
1924 : " %s goto [%s]\t-->\t<deleted> goto <skip>"
1925 0 : lap0 tmp2)
1926 0 : (or (eq 'TAG (car (nth 1 tmp)))
1927 0 : (setcdr tmp (cons (byte-compile-make-tag)
1928 0 : (cdr tmp))))
1929 0 : (setcdr lap1 (car (cdr tmp)))
1930 0 : (setq lap (delq lap0 lap))
1931 0 : (setq keep-going t))))
1932 : ;;
1933 : ;; X: varref-Y ... varset-Y goto-X -->
1934 : ;; X: varref-Y Z: ... dup varset-Y goto-Z
1935 : ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
1936 : ;; (This is so usual for while loops that it is worth handling).
1937 : ;;
1938 : ;; Here again, we could do it for stack-ref/stack-set, but
1939 : ;; that's replacing a stack-ref-Y with a stack-ref-0, which
1940 : ;; is a very minor improvement (if any), at the cost of
1941 : ;; more stack use and more byte-code. Let's not do it.
1942 : ;;
1943 894 : ((and (eq (car lap1) 'byte-varset)
1944 0 : (eq (car lap2) 'byte-goto)
1945 0 : (not (memq (cdr lap2) rest)) ;Backwards jump
1946 0 : (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
1947 0 : 'byte-varref)
1948 0 : (eq (cdr (car tmp)) (cdr lap1))
1949 894 : (not (memq (car (cdr lap1)) byte-boolean-vars)))
1950 : ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
1951 0 : (let ((newtag (byte-compile-make-tag)))
1952 0 : (byte-compile-log-lap
1953 : " %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
1954 : (nth 1 (cdr lap2)) (car tmp)
1955 : lap1 lap2
1956 : (nth 1 (cdr lap2)) (car tmp)
1957 : (nth 1 newtag) 'byte-dup lap1
1958 : (cons 'byte-goto newtag)
1959 0 : )
1960 0 : (setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
1961 0 : (setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
1962 0 : (setq add-depth 1)
1963 0 : (setq keep-going t))
1964 : ;;
1965 : ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
1966 : ;; (This can pull the loop test to the end of the loop)
1967 : ;;
1968 894 : ((and (eq (car lap0) 'byte-goto)
1969 28 : (eq (car lap1) 'TAG)
1970 28 : (eq lap1
1971 28 : (cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
1972 0 : (memq (car (car tmp))
1973 : '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
1974 894 : byte-goto-if-nil-else-pop)))
1975 : ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
1976 : ;; lap0 lap1 (cdr lap0) (car tmp))
1977 0 : (let ((newtag (byte-compile-make-tag)))
1978 0 : (byte-compile-log-lap
1979 : "%s %s: ... %s: %s\t-->\t%s ... %s:"
1980 : lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
1981 : (cons (cdr (assq (car (car tmp))
1982 : '((byte-goto-if-nil . byte-goto-if-not-nil)
1983 : (byte-goto-if-not-nil . byte-goto-if-nil)
1984 : (byte-goto-if-nil-else-pop .
1985 : byte-goto-if-not-nil-else-pop)
1986 : (byte-goto-if-not-nil-else-pop .
1987 : byte-goto-if-nil-else-pop))))
1988 : newtag)
1989 :
1990 : (nth 1 newtag)
1991 0 : )
1992 0 : (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
1993 0 : (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
1994 : ;; We can handle this case but not the -if-not-nil case,
1995 : ;; because we won't know which non-nil constant to push.
1996 0 : (setcdr rest (cons (cons 'byte-constant
1997 0 : (byte-compile-get-constant nil))
1998 0 : (cdr rest))))
1999 0 : (setcar lap0 (nth 1 (memq (car (car tmp))
2000 : '(byte-goto-if-nil-else-pop
2001 : byte-goto-if-not-nil
2002 : byte-goto-if-nil
2003 : byte-goto-if-not-nil
2004 0 : byte-goto byte-goto))))
2005 0 : )
2006 0 : (setq keep-going t))
2007 907 : )
2008 907 : (setq rest (cdr rest)))
2009 15 : )
2010 : ;; Cleanup stage:
2011 : ;; Rebuild byte-compile-constants / byte-compile-variables.
2012 : ;; Simple optimizations that would inhibit other optimizations if they
2013 : ;; were done in the optimizing loop, and optimizations which there is no
2014 : ;; need to do more than once.
2015 15 : (setq byte-compile-constants nil
2016 15 : byte-compile-variables nil)
2017 15 : (setq rest lap)
2018 15 : (byte-compile-log-lap " ---- final pass")
2019 467 : (while rest
2020 452 : (setq lap0 (car rest)
2021 452 : lap1 (nth 1 rest))
2022 452 : (if (memq (car lap0) byte-constref-ops)
2023 163 : (if (memq (car lap0) '(byte-constant byte-constant2))
2024 161 : (unless (memq (cdr lap0) byte-compile-constants)
2025 138 : (setq byte-compile-constants (cons (cdr lap0)
2026 161 : byte-compile-constants)))
2027 2 : (unless (memq (cdr lap0) byte-compile-variables)
2028 1 : (setq byte-compile-variables (cons (cdr lap0)
2029 452 : byte-compile-variables)))))
2030 452 : (cond (;;
2031 : ;; const-C varset-X const-C --> const-C dup varset-X
2032 : ;; const-C varbind-X const-C --> const-C dup varbind-X
2033 : ;;
2034 452 : (and (eq (car lap0) 'byte-constant)
2035 161 : (eq (car (nth 2 rest)) 'byte-constant)
2036 60 : (eq (cdr lap0) (cdr (nth 2 rest)))
2037 452 : (memq (car lap1) '(byte-varbind byte-varset)))
2038 0 : (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s"
2039 0 : lap0 lap1 lap0 lap0 lap1)
2040 0 : (setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
2041 0 : (setcar (cdr rest) (cons 'byte-dup 0))
2042 0 : (setq add-depth 1))
2043 : ;;
2044 : ;; const-X [dup/const-X ...] --> const-X [dup ...] dup
2045 : ;; varref-X [dup/varref-X ...] --> varref-X [dup ...] dup
2046 : ;;
2047 452 : ((memq (car lap0) '(byte-constant byte-varref))
2048 163 : (setq tmp rest
2049 163 : tmp2 nil)
2050 163 : (while (progn
2051 163 : (while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
2052 163 : (and (eq (cdr lap0) (cdr (car tmp)))
2053 163 : (eq (car lap0) (car (car tmp)))))
2054 0 : (setcar tmp (cons 'byte-dup 0))
2055 163 : (setq tmp2 t))
2056 163 : (if tmp2
2057 0 : (byte-compile-log-lap
2058 163 : " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0)))
2059 : ;;
2060 : ;; unbind-N unbind-M --> unbind-(N+M)
2061 : ;;
2062 289 : ((and (eq 'byte-unbind (car lap0))
2063 289 : (eq 'byte-unbind (car lap1)))
2064 0 : (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
2065 : (cons 'byte-unbind
2066 0 : (+ (cdr lap0) (cdr lap1))))
2067 0 : (setq lap (delq lap0 lap))
2068 0 : (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
2069 :
2070 : ;;
2071 : ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
2072 : ;; stack-set-M [discard/discardN ...] --> discardN
2073 : ;;
2074 289 : ((and (eq (car lap0) 'byte-stack-set)
2075 15 : (memq (car lap1) '(byte-discard byte-discardN))
2076 5 : (progn
2077 : ;; See if enough discard operations follow to expose or
2078 : ;; destroy the value stored by the stack-set.
2079 5 : (setq tmp (cdr rest))
2080 5 : (setq tmp2 (1- (cdr lap0)))
2081 5 : (setq tmp3 0)
2082 10 : (while (memq (car (car tmp)) '(byte-discard byte-discardN))
2083 5 : (setq tmp3
2084 5 : (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
2085 : 1
2086 5 : (cdr (car tmp)))))
2087 5 : (setq tmp (cdr tmp)))
2088 289 : (>= tmp3 tmp2)))
2089 : ;; Do the optimization.
2090 5 : (setq lap (delq lap0 lap))
2091 5 : (setcar lap1
2092 5 : (if (= tmp2 tmp3)
2093 : ;; The value stored is the new TOS, so pop one more
2094 : ;; value (to get rid of the old value) using the
2095 : ;; TOS-preserving discard operator.
2096 : 'byte-discardN-preserve-tos
2097 : ;; Otherwise, the value stored is lost, so just use a
2098 : ;; normal discard.
2099 5 : 'byte-discardN))
2100 5 : (setcdr lap1 (1+ tmp3))
2101 5 : (setcdr (cdr rest) tmp)
2102 5 : (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
2103 5 : lap0 lap1))
2104 :
2105 : ;;
2106 : ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
2107 : ;; discardN-(X+Y)
2108 : ;;
2109 284 : ((and (memq (car lap0)
2110 : '(byte-discard byte-discardN
2111 284 : byte-discardN-preserve-tos))
2112 284 : (memq (car lap1) '(byte-discard byte-discardN)))
2113 0 : (setq lap (delq lap0 lap))
2114 0 : (byte-compile-log-lap
2115 : " %s %s\t-->\t(discardN %s)"
2116 : lap0 lap1
2117 : (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2118 0 : (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2119 0 : (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
2120 0 : (if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
2121 0 : (setcar lap1 'byte-discardN))
2122 :
2123 : ;;
2124 : ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
2125 : ;; discardN-preserve-tos-(X+Y)
2126 : ;;
2127 284 : ((and (eq (car lap0) 'byte-discardN-preserve-tos)
2128 284 : (eq (car lap1) 'byte-discardN-preserve-tos))
2129 0 : (setq lap (delq lap0 lap))
2130 0 : (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
2131 0 : (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
2132 :
2133 : ;;
2134 : ;; discardN-preserve-tos return --> return
2135 : ;; dup return --> return
2136 : ;; stack-set-N return --> return ; where N is TOS-1
2137 : ;;
2138 284 : ((and (eq (car lap1) 'byte-return)
2139 10 : (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
2140 10 : (and (eq (car lap0) 'byte-stack-set)
2141 284 : (= (cdr lap0) 1))))
2142 : ;; The byte-code interpreter will pop the stack for us, so
2143 : ;; we can just leave stuff on it.
2144 5 : (setq lap (delq lap0 lap))
2145 5 : (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
2146 452 : )
2147 452 : (setq rest (cdr rest)))
2148 15 : (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
2149 15 : lap)
2150 :
2151 : (provide 'byte-opt)
2152 :
2153 :
2154 : ;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles
2155 : ;; itself, compile some of its most used recursive functions (at load time).
2156 : ;;
2157 : (eval-when-compile
2158 : (or (byte-code-function-p (symbol-function 'byte-optimize-form))
2159 : (assq 'byte-code (symbol-function 'byte-optimize-form))
2160 : (let ((byte-optimize nil)
2161 : (byte-compile-warnings nil))
2162 : (mapc (lambda (x)
2163 : (or noninteractive (message "compiling %s..." x))
2164 : (byte-compile x)
2165 : (or noninteractive (message "compiling %s...done" x)))
2166 : '(byte-optimize-form
2167 : byte-optimize-body
2168 : byte-optimize-predicate
2169 : byte-optimize-binary-predicate
2170 : ;; Inserted some more than necessary, to speed it up.
2171 : byte-optimize-form-code-walker
2172 : byte-optimize-lapcode))))
2173 : nil)
2174 :
2175 : ;;; byte-opt.el ends here
|