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