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