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