comparison lisp/byte-optimize.el @ 412:697ef44129c6 r21-2-14

Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents a86b2b5e0111
children
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
1 ;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler. 1 ;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler.
2 2
3 ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. 3 ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
4 4
5 ;; Author: Jamie Zawinski <jwz@jwz.org> 5 ;; Author: Jamie Zawinski <jwz@netscape.com>
6 ;; Hallvard Furuseth <hbf@ulrik.uio.no> 6 ;; Hallvard Furuseth <hbf@ulrik.uio.no>
7 ;; Keywords: internal 7 ;; Keywords: internal
8 8
9 ;; This file is part of XEmacs. 9 ;; This file is part of XEmacs.
10 10
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
19 ;; General Public License for more details. 19 ;; General Public License for more details.
20 20
21 ;; You should have received a copy of the GNU General Public License 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 22 ;; along with XEmacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
25 25
26 ;;; Synched up with: FSF 19.30. 26 ;;; Synched up with: FSF 19.30.
27 27
30 ;; ======================================================================== 30 ;; ========================================================================
31 ;; "No matter how hard you try, you can't make a racehorse out of a pig. 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." 32 ;; You can, however, make a faster pig."
33 ;; 33 ;;
34 ;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code 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 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 36 ;; still not going to make it go faster than 70 mph, but it might be easier
37 ;; to get it there. 37 ;; to get it there.
38 ;; 38 ;;
39 39
40 ;; TO DO: 40 ;; TO DO:
62 ;; others? 62 ;; others?
63 ;; 63 ;;
64 ;; Simple defsubsts often produce forms like 64 ;; Simple defsubsts often produce forms like
65 ;; (let ((v1 (f1)) (v2 (f2)) ...) 65 ;; (let ((v1 (f1)) (v2 (f2)) ...)
66 ;; (FN v1 v2 ...)) 66 ;; (FN v1 v2 ...))
67 ;; It would be nice if we could optimize this to 67 ;; It would be nice if we could optimize this to
68 ;; (FN (f1) (f2) ...) 68 ;; (FN (f1) (f2) ...)
69 ;; but we can't unless FN is dynamically-safe (it might be dynamically 69 ;; but we can't unless FN is dynamically-safe (it might be dynamically
70 ;; referring to the bindings that the lambda arglist established.) 70 ;; referring to the bindings that the lambda arglist established.)
71 ;; One of the uncountable lossages introduced by dynamic scope... 71 ;; One of the uncountable lossages introduced by dynamic scope...
72 ;; 72 ;;
73 ;; Maybe there should be a control-structure that says "turn on 73 ;; Maybe there should be a control-structure that says "turn on
74 ;; fast-and-loose type-assumptive optimizations here." Then when 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 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. 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 77 ;; But, this won't win much because of (you guessed it) dynamic
78 ;; scope. Anything down the stack could change the value. 78 ;; scope. Anything down the stack could change the value.
79 ;; (Another reason it doesn't work is that it is perfectly valid 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 80 ;; to call car with a null argument.) A better approach might
81 ;; be to allow type-specification of the form 81 ;; be to allow type-specification of the form
82 ;; (put 'foo 'arg-types '(float (list integer) dynamic)) 82 ;; (put 'foo 'arg-types '(float (list integer) dynamic))
107 ;; (funcall fn (car list)) 107 ;; (funcall fn (car list))
108 ;; (tail-map fn (cdr list))))) 108 ;; (tail-map fn (cdr list)))))
109 ;; 109 ;;
110 ;; However, if there was even a single let-binding around the COND, 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" 111 ;; it could not be byte-compiled, because there would be an "unbind"
112 ;; byte-op between the final "call" and "return." Adding a 112 ;; byte-op between the final "call" and "return." Adding a
113 ;; Bunbind_all byteop would fix this. 113 ;; Bunbind_all byteop would fix this.
114 ;; 114 ;;
115 ;; (defun foo (x y z) ... (foo a b c)) 115 ;; (defun foo (x y z) ... (foo a b c))
116 ;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) 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) 117 ;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return)
129 ;; overflow. I don't believe there is any way around this without lexical 129 ;; overflow. I don't believe there is any way around this without lexical
130 ;; scope. 130 ;; scope.
131 ;; 131 ;;
132 ;; Wouldn't it be nice if Emacs Lisp had lexical scope. 132 ;; Wouldn't it be nice if Emacs Lisp had lexical scope.
133 ;; 133 ;;
134 ;; Idea: the form (lexical-scope) in a file means that the file may be 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 135 ;; compiled lexically. This proclamation is file-local. Then, within
136 ;; that file, "let" would establish lexical bindings, and "let-dynamic" 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.) 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 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 139 ;; always be dynamic, and attempting to do a lexical binding of them
140 ;; should simply do a dynamic binding instead. 140 ;; should simply do a dynamic binding instead.
141 ;; But! We need to know about variables that were not necessarily defvarred 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.) 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. 143 ;; Fdefvar() would have to be modified to add something to the plist.
144 ;; 144 ;;
145 ;; A major disadvantage of this scheme is that the interpreter and compiler 145 ;; A major disadvantage of this scheme is that the interpreter and compiler
146 ;; would have different semantics for files compiled with (dynamic-scope). 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 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 148 ;; modify the interpreter to obey this (unless the loader was hacked
149 ;; in some grody way, but that's a really bad idea.) 149 ;; in some grody way, but that's a really bad idea.)
150 ;; 150 ;;
151 ;; HA! RMS removed the following paragraph from his version of 151 ;; HA! RMS removed the following paragraph from his version of
152 ;; byte-optimize.el. 152 ;; byte-optimize.el.
153 ;; 153 ;;
154 ;; Really the Right Thing is to make lexical scope the default across 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 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. 156 ;; the code that relies on dynamic scope of non-defvarred variables.
157 157
158 ;; Other things to consider: 158 ;; Other things to consider:
159 159
160 ;; Associative math should recognize subcalls to identical function: 160 ;; Associative math should recognize subcalls to identical function:
164 ;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1)))) 164 ;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1))))
165 ;; An awful lot of functions always return a non-nil value. If they're 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. 166 ;; error free also they may act as true-constants.
167 167
168 ;;(disassemble #'(lambda (x) (and (point) (foo)))) 168 ;;(disassemble #'(lambda (x) (and (point) (foo))))
169 ;; When 169 ;; When
170 ;; - all but one arguments to a function are constant 170 ;; - all but one arguments to a function are constant
171 ;; - the non-constant argument is an if-expression (cond-expression?) 171 ;; - the non-constant argument is an if-expression (cond-expression?)
172 ;; then the outer function can be distributed. If the guarding 172 ;; then the outer function can be distributed. If the guarding
173 ;; condition is side-effect-free [assignment-free] then the other 173 ;; condition is side-effect-free [assignment-free] then the other
174 ;; arguments may be any expressions. Since, however, the code size 174 ;; arguments may be any expressions. Since, however, the code size
293 (cdr form))) 293 (cdr form)))
294 (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) 294 (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
295 (cons fn (cdr form))))))) 295 (cons fn (cdr form)))))))
296 296
297 ;;; ((lambda ...) ...) 297 ;;; ((lambda ...) ...)
298 ;;; 298 ;;;
299 (defun byte-compile-unfold-lambda (form &optional name) 299 (defun byte-compile-unfold-lambda (form &optional name)
300 (or name (setq name "anonymous lambda")) 300 (or name (setq name "anonymous lambda"))
301 (let ((lambda (car form)) 301 (let ((lambda (car form))
302 (values (cdr form))) 302 (values (cdr form)))
303 (if (compiled-function-p lambda) 303 (if (compiled-function-p lambda)
348 (progn 348 (progn
349 (or (eq values 'too-few) 349 (or (eq values 'too-few)
350 (byte-compile-warn 350 (byte-compile-warn
351 "attempt to open-code %s with too many arguments" name)) 351 "attempt to open-code %s with too many arguments" name))
352 form) 352 form)
353 (let ((newform 353 (let ((newform
354 (if bindings 354 (if bindings
355 (cons 'let (cons (nreverse bindings) body)) 355 (cons 'let (cons (nreverse bindings) body))
356 (cons 'progn body)))) 356 (cons 'progn body))))
357 (byte-compile-log " %s\t==>\t%s" form newform) 357 (byte-compile-log " %s\t==>\t%s" form newform)
358 newform))))) 358 newform)))))
433 ((eq fn 'prog2) 433 ((eq fn 'prog2)
434 (cons 'prog2 434 (cons 'prog2
435 (cons (byte-optimize-form (nth 1 form) t) 435 (cons (byte-optimize-form (nth 1 form) t)
436 (cons (byte-optimize-form (nth 2 form) for-effect) 436 (cons (byte-optimize-form (nth 2 form) for-effect)
437 (byte-optimize-body (cdr (cdr (cdr form))) t))))) 437 (byte-optimize-body (cdr (cdr (cdr form))) t)))))
438 438
439 ((memq fn '(save-excursion save-restriction save-current-buffer)) 439 ((memq fn '(save-excursion save-restriction save-current-buffer))
440 ;; those subrs which have an implicit progn; it's not quite good 440 ;; those subrs which have an implicit progn; it's not quite good
441 ;; enough to treat these like normal function calls. 441 ;; enough to treat these like normal function calls.
442 ;; This can turn (save-excursion ...) into (save-excursion) which 442 ;; This can turn (save-excursion ...) into (save-excursion) which
443 ;; will be optimized away in the lap-optimize pass. 443 ;; will be optimized away in the lap-optimize pass.
444 (cons fn (byte-optimize-body (cdr form) for-effect))) 444 (cons fn (byte-optimize-body (cdr form) for-effect)))
445 445
446 ((eq fn 'with-output-to-temp-buffer) 446 ((eq fn 'with-output-to-temp-buffer)
447 ;; this is just like the above, except for the first argument. 447 ;; this is just like the above, except for the first argument.
448 (cons fn 448 (cons fn
449 (cons 449 (cons
450 (byte-optimize-form (nth 1 form) nil) 450 (byte-optimize-form (nth 1 form) nil)
451 (byte-optimize-body (cdr (cdr form)) for-effect)))) 451 (byte-optimize-body (cdr (cdr form)) for-effect))))
452 452
453 ((eq fn 'if) 453 ((eq fn 'if)
454 (cons fn 454 (cons fn
455 (cons (byte-optimize-form (nth 1 form) nil) 455 (cons (byte-optimize-form (nth 1 form) nil)
456 (cons 456 (cons
457 (byte-optimize-form (nth 2 form) for-effect) 457 (byte-optimize-form (nth 2 form) for-effect)
458 (byte-optimize-body (nthcdr 3 form) for-effect))))) 458 (byte-optimize-body (nthcdr 3 form) for-effect)))))
459 459
460 ((memq fn '(and or)) ; remember, and/or are control structures. 460 ((memq fn '(and or)) ; remember, and/or are control structures.
461 ;; take forms off the back until we can't any more. 461 ;; take forms off the back until we can't any more.
462 ;; In the future it could conceivably be a problem that the 462 ;; In the future it could conceivably be a problem that the
463 ;; subexpressions of these forms are optimized in the reverse 463 ;; subexpressions of these forms are optimized in the reverse
464 ;; order, but it's ok for now. 464 ;; order, but it's ok for now.
471 (setq backwards (cdr backwards))) 471 (setq backwards (cdr backwards)))
472 (if (and (cdr form) (null backwards)) 472 (if (and (cdr form) (null backwards))
473 (byte-compile-log 473 (byte-compile-log
474 " all subforms of %s called for effect; deleted" form)) 474 " all subforms of %s called for effect; deleted" form))
475 (and backwards 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)))) 476 (cons fn (nreverse backwards))))
481 (cons fn (mapcar 'byte-optimize-form (cdr form))))) 477 (cons fn (mapcar 'byte-optimize-form (cdr form)))))
482 478
483 ((eq fn 'interactive) 479 ((eq fn 'interactive)
484 (byte-compile-warn "misplaced interactive spec: %s" 480 (byte-compile-warn "misplaced interactive spec: %s"
485 (prin1-to-string form)) 481 (prin1-to-string form))
486 nil) 482 nil)
487 483
488 ((memq fn '(defun defmacro function 484 ((memq fn '(defun defmacro function
489 condition-case save-window-excursion)) 485 condition-case save-window-excursion))
490 ;; These forms are compiled as constants or by breaking out 486 ;; These forms are compiled as constants or by breaking out
491 ;; all the subexpressions and compiling them separately. 487 ;; all the subexpressions and compiling them separately.
492 form) 488 form)
498 ;; unwind-protect itself. (The protected part is always for effect, 494 ;; unwind-protect itself. (The protected part is always for effect,
499 ;; but that isn't handled properly yet.) 495 ;; but that isn't handled properly yet.)
500 (cons fn 496 (cons fn
501 (cons (byte-optimize-form (nth 1 form) for-effect) 497 (cons (byte-optimize-form (nth 1 form) for-effect)
502 (cdr (cdr form))))) 498 (cdr (cdr form)))))
503 499
504 ((eq fn 'catch) 500 ((eq fn 'catch)
505 ;; the body of a catch is compiled (and thus optimized) as a 501 ;; 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 502 ;; 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 503 ;; for-effect. The body should have the same for-effect status
508 ;; as the catch form itself, but that isn't handled properly yet. 504 ;; as the catch form itself, but that isn't handled properly yet.
516 ;; by the time that is reached. 512 ;; by the time that is reached.
517 ((not (eq form 513 ((not (eq form
518 (setq form (macroexpand form 514 (setq form (macroexpand form
519 byte-compile-macro-environment)))) 515 byte-compile-macro-environment))))
520 (byte-optimize-form form for-effect)) 516 (byte-optimize-form form for-effect))
521 517
522 ((not (symbolp fn)) 518 ((not (symbolp fn))
523 (or (eq 'mocklisp (car-safe fn)) ; ha! 519 (or (eq 'mocklisp (car-safe fn)) ; ha!
524 (byte-compile-warn "%s is a malformed function" 520 (byte-compile-warn "%s is a malformed function"
525 (prin1-to-string fn))) 521 (prin1-to-string fn)))
526 form) 522 form)
534 nil))) 530 nil)))
535 (byte-compile-log " %s called for effect; deleted" fn) 531 (byte-compile-log " %s called for effect; deleted" fn)
536 ;; appending a nil here might not be necessary, but it can't hurt. 532 ;; appending a nil here might not be necessary, but it can't hurt.
537 (byte-optimize-form 533 (byte-optimize-form
538 (cons 'progn (append (cdr form) '(nil))) t)) 534 (cons 'progn (append (cdr form) '(nil))) t))
539 535
540 (t 536 (t
541 ;; Otherwise, no args can be considered to be for-effect, 537 ;; Otherwise, no args can be considered to be for-effect,
542 ;; even if the called function is for-effect, because we 538 ;; even if the called function is for-effect, because we
543 ;; don't know anything about that function. 539 ;; don't know anything about that function.
544 (cons fn (mapcar 'byte-optimize-form (cdr form))))))) 540 (cons fn (mapcar 'byte-optimize-form (cdr form)))))))
604 ((not (symbolp ,form))) 600 ((not (symbolp ,form)))
605 ((eq ,form t)) 601 ((eq ,form t))
606 ((keywordp ,form)))) 602 ((keywordp ,form))))
607 603
608 ;; If the function is being called with constant numeric args, 604 ;; If the function is being called with constant numeric args,
609 ;; evaluate as much as possible at compile-time. This optimizer 605 ;; evaluate as much as possible at compile-time. This optimizer
610 ;; assumes that the function is associative, like + or *. 606 ;; assumes that the function is associative, like + or *.
611 (defun byte-optimize-associative-math (form) 607 (defun byte-optimize-associative-math (form)
612 (let ((args nil) 608 (let ((args nil)
613 (constants nil) 609 (constants nil)
614 (rest (cdr form))) 610 (rest (cdr form)))
701 697
702 (defun byte-optimize-plus (form) 698 (defun byte-optimize-plus (form)
703 (setq form (byte-optimize-delay-constants-math form 1 '+)) 699 (setq form (byte-optimize-delay-constants-math form 1 '+))
704 (if (memq 0 form) (setq form (delq 0 (copy-sequence form)))) 700 (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
705 ;;(setq form (byte-optimize-associative-two-args-math form)) 701 ;;(setq form (byte-optimize-associative-two-args-math form))
706 702 (cond ((null (cdr form))
707 (case (length (cdr form)) 703 (condition-case ()
708 ((0) ; (+) 704 (eval form)
709 (condition-case () 705 (error form)))
710 (eval form) 706
711 (error form))) 707 ;; `add1' and `sub1' are a marginally fewer instructions
712 708 ;; than `plus' and `minus', so use them when possible.
713 ;; It is not safe to delete the function entirely 709 ((and (null (nthcdr 3 form))
714 ;; (actually, it would be safe if we knew the sole arg 710 (eq (nth 2 form) 1))
715 ;; is not a marker). 711 (list '1+ (nth 1 form))) ; (+ x 1) --> (1+ x)
716 ;; ((1) 712 ((and (null (nthcdr 3 form))
717 ;; (nth 1 form)) 713 (eq (nth 1 form) 1))
718 714 (list '1+ (nth 2 form))) ; (+ 1 x) --> (1+ x)
719 ((2) ; (+ x y) 715 ((and (null (nthcdr 3 form))
720 (byte-optimize-predicate 716 (eq (nth 2 form) -1))
721 (cond 717 (list '1- (nth 1 form))) ; (+ x -1) --> (1- x)
722 ;; `add1' and `sub1' are a marginally fewer instructions 718 ((and (null (nthcdr 3 form))
723 ;; than `plus' and `minus', so use them when possible. 719 (eq (nth 1 form) -1))
724 ((eq (nth 1 form) 1) `(1+ ,(nth 2 form))) ; (+ 1 x) --> (1+ x) 720 (list '1- (nth 2 form))) ; (+ -1 x) --> (1- x)
725 ((eq (nth 2 form) 1) `(1+ ,(nth 1 form))) ; (+ x 1) --> (1+ x) 721
726 ((eq (nth 1 form) -1) `(1- ,(nth 2 form))) ; (+ -1 x) --> (1- x) 722 ;;; It is not safe to delete the function entirely
727 ((eq (nth 2 form) -1) `(1- ,(nth 1 form))) ; (+ x -1) --> (1- x) 723 ;;; (actually, it would be safe if we know the sole arg
728 (t form)))) 724 ;;; is not a marker).
729 725 ;; ((null (cdr (cdr form))) (nth 1 form))
730 (t (byte-optimize-predicate form)))) 726 (t form)))
731 727
732 (defun byte-optimize-minus (form) 728 (defun byte-optimize-minus (form)
733 ;; Put constants at the end, except the last constant. 729 ;; Put constants at the end, except the last constant.
734 (setq form (byte-optimize-delay-constants-math form 2 '+)) 730 (setq form (byte-optimize-delay-constants-math form 2 '+))
735 ;; Now only first and last element can be an integer. 731 ;; Now only first and last element can be a number.
736 (let ((last (last (nthcdr 3 form)))) 732 (let ((last (car (reverse (nthcdr 3 form)))))
737 (cond ((eq 0 last) 733 (cond ((eq 0 last)
738 ;; (- x y ... 0) --> (- x y ...) 734 ;; (- x y ... 0) --> (- x y ...)
739 (setq form (copy-sequence form)) 735 (setq form (copy-sequence form))
740 (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) 736 (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
741 ;; If form is (- CONST foo... CONST), merge first and last. 737 ;; If form is (- CONST foo... CONST), merge first and last.
742 ((and (numberp (nth 1 form)) 738 ((and (numberp (nth 1 form))
743 (numberp last)) 739 (numberp last))
744 (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) 740 (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
745 (delq last (copy-sequence (nthcdr 3 form)))))))) 741 (delq last (copy-sequence (nthcdr 3 form))))))))
746 742 (setq form
747 (case (length (cdr form)) 743 ;;; It is not safe to delete the function entirely
748 ((0) ; (-) 744 ;;; (actually, it would be safe if we know the sole arg
749 (condition-case () 745 ;;; is not a marker).
750 (eval form) 746 ;;; (if (eq (nth 2 form) 0)
751 (error form))) 747 ;;; (nth 1 form) ; (- x 0) --> x
752 748 (byte-optimize-predicate
753 ;; It is not safe to delete the function entirely 749 (if (and (null (cdr (cdr (cdr form))))
754 ;; (actually, it would be safe if we knew the sole arg 750 (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
755 ;; is not a marker). 751 (cons (car form) (cdr (cdr form)))
756 ;; ((1) 752 form))
757 ;; (nth 1 form) 753 ;;; )
758 754 )
759 ((2) ; (+ x y) 755
760 (byte-optimize-predicate 756 ;; `add1' and `sub1' are a marginally fewer instructions than `plus'
761 (cond 757 ;; and `minus', so use them when possible.
762 ;; `add1' and `sub1' are a marginally fewer instructions than `plus' 758 (cond ((and (null (nthcdr 3 form))
763 ;; and `minus', so use them when possible. 759 (eq (nth 2 form) 1))
764 ((eq (nth 2 form) 1) `(1- ,(nth 1 form))) ; (- x 1) --> (1- x) 760 (list '1- (nth 1 form))) ; (- x 1) --> (1- x)
765 ((eq (nth 2 form) -1) `(1+ ,(nth 1 form))) ; (- x -1) --> (1+ x) 761 ((and (null (nthcdr 3 form))
766 ((eq (nth 1 form) 0) `(- ,(nth 2 form))) ; (- 0 x) --> (- x) 762 (eq (nth 2 form) -1))
767 (t form)))) 763 (list '1+ (nth 1 form))) ; (- x -1) --> (1+ x)
768 764 (t
769 (t (byte-optimize-predicate form)))) 765 form))
766 )
770 767
771 (defun byte-optimize-multiply (form) 768 (defun byte-optimize-multiply (form)
772 (setq form (byte-optimize-delay-constants-math form 1 '*)) 769 (setq form (byte-optimize-delay-constants-math form 1 '*))
773 ;; If there is a constant integer in FORM, it is now the last element. 770 ;; If there is a constant in FORM, it is now the last element.
774 (cond ((null (cdr form)) 1) 771 (cond ((null (cdr form)) 1)
775 ;;; It is not safe to delete the function entirely 772 ;;; It is not safe to delete the function entirely
776 ;;; (actually, it would be safe if we know the sole arg 773 ;;; (actually, it would be safe if we know the sole arg
777 ;;; is not a marker or if it appears in other arithmetic). 774 ;;; is not a marker or if it appears in other arithmetic).
778 ;;; ((null (cdr (cdr form))) (nth 1 form)) 775 ;;; ((null (cdr (cdr form))) (nth 1 form))
779 ((let ((last (last form))) 776 ((let ((last (car (reverse form))))
780 (byte-optimize-predicate 777 (cond ((eq 0 last) (cons 'progn (cdr form)))
781 (cond ((eq 0 last) (cons 'progn (cdr form))) 778 ((eq 1 last) (delq 1 (copy-sequence form)))
782 ((eq 1 last) (delq 1 (copy-sequence form))) 779 ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
783 ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) 780 ((and (eq 2 last)
784 ((and (eq 2 last) 781 (memq t (mapcar 'symbolp (cdr form))))
785 (memq t (mapcar 'symbolp (cdr form)))) 782 (prog1 (setq form (delq 2 (copy-sequence form)))
786 (prog1 (setq form (delq 2 (copy-sequence form))) 783 (while (not (symbolp (car (setq form (cdr form))))))
787 (while (not (symbolp (car (setq form (cdr form)))))) 784 (setcar form (list '+ (car form) (car form)))))
788 (setcar form (list '+ (car form) (car form))))) 785 (form))))))
789 (form))))))) 786
787 (defsubst byte-compile-butlast (form)
788 (nreverse (cdr (reverse form))))
790 789
791 (defun byte-optimize-divide (form) 790 (defun byte-optimize-divide (form)
792 (setq form (byte-optimize-delay-constants-math form 2 '*)) 791 (setq form (byte-optimize-delay-constants-math form 2 '*))
793 ;; If there is a constant integer in FORM, it is now the last element. 792 (let ((last (car (reverse (cdr (cdr form))))))
794 (let ((last (last (cdr (cdr form)))))
795 (if (numberp last) 793 (if (numberp last)
796 (cond ((= (length form) 3) 794 (cond ((= (length form) 3)
797 (if (and (numberp (nth 1 form)) 795 (if (and (numberp (nth 1 form))
798 (not (zerop last)) 796 (not (zerop last))
799 (condition-case nil 797 (condition-case nil
800 (/ (nth 1 form) last) 798 (/ (nth 1 form) last)
801 (error nil))) 799 (error nil)))
802 (setq form (list 'progn (/ (nth 1 form) last))))) 800 (setq form (list 'progn (/ (nth 1 form) last)))))
803 ((= last 1) 801 ((= last 1)
804 (setq form (butlast form))) 802 (setq form (byte-compile-butlast form)))
805 ((numberp (nth 1 form)) 803 ((numberp (nth 1 form))
806 (setq form (cons (car form) 804 (setq form (cons (car form)
807 (cons (/ (nth 1 form) last) 805 (cons (/ (nth 1 form) last)
808 (butlast (cdr (cdr form))))) 806 (byte-compile-butlast (cdr (cdr form)))))
809 last nil)))) 807 last nil))))
810 (cond 808 (cond
811 ;;; ((null (cdr (cdr form))) 809 ;;; ((null (cdr (cdr form)))
812 ;;; (nth 1 form)) 810 ;;; (nth 1 form))
813 ((eq (nth 1 form) 0) 811 ((eq (nth 1 form) 0)
814 (append '(progn) (cdr (cdr form)) '(0))) 812 (append '(progn) (cdr (cdr form)) '(0)))
815 ((eq last -1) 813 ((eq last -1)
816 (list '- (if (nthcdr 3 form) 814 (list '- (if (nthcdr 3 form)
817 (butlast form) 815 (byte-compile-butlast form)
818 (nth 1 form)))) 816 (nth 1 form))))
819 (form)))) 817 (form))))
820 818
821 (defun byte-optimize-logmumble (form) 819 (defun byte-optimize-logmumble (form)
822 (setq form (byte-optimize-delay-constants-math form 1 (car form))) 820 (setq form (byte-optimize-delay-constants-math form 1 (car form)))
823 (byte-optimize-predicate 821 (byte-optimize-predicate
824 (cond ((memq 0 form) 822 (cond ((memq 0 form)
890 (put 'listp 'byte-optimizer 'byte-optimize-predicate) 888 (put 'listp 'byte-optimizer 'byte-optimize-predicate)
891 (put 'symbolp 'byte-optimizer 'byte-optimize-predicate) 889 (put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
892 (put 'stringp 'byte-optimizer 'byte-optimize-predicate) 890 (put 'stringp 'byte-optimizer 'byte-optimize-predicate)
893 (put 'string< 'byte-optimizer 'byte-optimize-predicate) 891 (put 'string< 'byte-optimizer 'byte-optimize-predicate)
894 (put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) 892 (put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
895 (put 'length 'byte-optimizer 'byte-optimize-predicate)
896 893
897 (put 'logand 'byte-optimizer 'byte-optimize-logmumble) 894 (put 'logand 'byte-optimizer 'byte-optimize-logmumble)
898 (put 'logior 'byte-optimizer 'byte-optimize-logmumble) 895 (put 'logior 'byte-optimizer 'byte-optimize-logmumble)
899 (put 'logxor 'byte-optimizer 'byte-optimize-logmumble) 896 (put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
900 (put 'lognot 'byte-optimizer 'byte-optimize-predicate) 897 (put 'lognot 'byte-optimizer 'byte-optimize-predicate)
903 (put 'cdr 'byte-optimizer 'byte-optimize-predicate) 900 (put 'cdr 'byte-optimizer 'byte-optimize-predicate)
904 (put 'car-safe 'byte-optimizer 'byte-optimize-predicate) 901 (put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
905 (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) 902 (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
906 903
907 904
908 ;; I'm not convinced that this is necessary. Doesn't the optimizer loop 905 ;; I'm not convinced that this is necessary. Doesn't the optimizer loop
909 ;; take care of this? - Jamie 906 ;; take care of this? - Jamie
910 ;; I think this may some times be necessary to reduce eg. (quote 5) to 5, 907 ;; I think this may some times be necessary to reduce eg. (quote 5) to 5,
911 ;; so arithmetic optimizers recognize the numeric constant. - Hallvard 908 ;; so arithmetic optimizers recognize the numeric constant. - Hallvard
912 (put 'quote 'byte-optimizer 'byte-optimize-quote) 909 (put 'quote 'byte-optimizer 'byte-optimize-quote)
913 (defun byte-optimize-quote (form) 910 (defun byte-optimize-quote (form)
1034 (put 'or 'byte-optimizer 'byte-optimize-or) 1031 (put 'or 'byte-optimizer 'byte-optimize-or)
1035 (put 'cond 'byte-optimizer 'byte-optimize-cond) 1032 (put 'cond 'byte-optimizer 'byte-optimize-cond)
1036 (put 'if 'byte-optimizer 'byte-optimize-if) 1033 (put 'if 'byte-optimizer 'byte-optimize-if)
1037 (put 'while 'byte-optimizer 'byte-optimize-while) 1034 (put 'while 'byte-optimizer 'byte-optimize-while)
1038 1035
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 1036 ;; byte-compile-negation-optimizer lives in bytecomp.el
1046 ;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer) 1037 ;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
1047 (put 'atom 'byte-optimizer 'byte-compile-negation-optimizer) 1038 (put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
1048 (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer) 1039 (put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
1049 1040
1110 (setq form (nth 2 form)) 1101 (setq form (nth 2 form))
1111 (while (>= (setq count (1- count)) 0) 1102 (while (>= (setq count (1- count)) 0)
1112 (setq form (list 'cdr form))) 1103 (setq form (list 'cdr form)))
1113 form))) 1104 form)))
1114 1105
1115 ;;; enumerating those functions which need not be called if the returned 1106 ;;; enumerating those functions which need not be called if the returned
1116 ;;; value is not used. That is, something like 1107 ;;; value is not used. That is, something like
1117 ;;; (progn (list (something-with-side-effects) (yow)) 1108 ;;; (progn (list (something-with-side-effects) (yow))
1118 ;;; (foo)) 1109 ;;; (foo))
1119 ;;; may safely be turned into 1110 ;;; may safely be turned into
1120 ;;; (progn (progn (something-with-side-effects) (yow)) 1111 ;;; (progn (progn (something-with-side-effects) (yow))
1148 ;; 1139 ;;
1149 int-to-string 1140 int-to-string
1150 length log log10 logand logb logior lognot logxor lsh 1141 length log log10 logand logb logior lognot logxor lsh
1151 marker-buffer max member memq min mod 1142 marker-buffer max member memq min mod
1152 next-window nth nthcdr number-to-string 1143 next-window nth nthcdr number-to-string
1153 parse-colon-path plist-get previous-window 1144 parse-colon-path previous-window
1154 radians-to-degrees rassq regexp-quote reverse round 1145 radians-to-degrees rassq regexp-quote reverse round
1155 sin sqrt string< string= string-equal string-lessp string-to-char 1146 sin sqrt string< string= string-equal string-lessp string-to-char
1156 string-to-int string-to-number substring symbol-plist 1147 string-to-int string-to-number substring symbol-plist
1157 tan upcase user-variable-p vconcat 1148 tan upcase user-variable-p vconcat
1158 ;; XEmacs change: window-edges -> window-pixel-edges 1149 ;; XEmacs change: window-edges -> window-pixel-edges
1162 ;; functions defined by cl 1153 ;; functions defined by cl
1163 oddp evenp plusp minusp 1154 oddp evenp plusp minusp
1164 abs expt signum last butlast ldiff 1155 abs expt signum last butlast ldiff
1165 pairlis gcd lcm 1156 pairlis gcd lcm
1166 isqrt floor* ceiling* truncate* round* mod* rem* subseq 1157 isqrt floor* ceiling* truncate* round* mod* rem* subseq
1167 list-length getf 1158 list-length get* getf
1168 )) 1159 ))
1169 (side-effect-and-error-free-fns 1160 (side-effect-and-error-free-fns
1170 '(arrayp atom 1161 '(arrayp atom
1171 bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp 1162 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 1163 car-safe case-table-p cdr-safe char-or-string-p char-table-p
1388 byte-point-min byte-following-char byte-preceding-char 1379 byte-point-min byte-following-char byte-preceding-char
1389 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp 1380 byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
1390 byte-current-buffer byte-interactive-p)) 1381 byte-current-buffer byte-interactive-p))
1391 1382
1392 (defconst byte-compile-side-effect-free-ops 1383 (defconst byte-compile-side-effect-free-ops
1393 (nconc 1384 (nconc
1394 '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref 1385 '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
1395 byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 1386 byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
1396 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate 1387 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
1397 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax 1388 byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
1398 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt 1389 byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
1420 ;;; varref flag 1411 ;;; varref flag
1421 ;;; dup 1412 ;;; dup
1422 ;;; varbind pop-up-windows 1413 ;;; varbind pop-up-windows
1423 ;;; not 1414 ;;; not
1424 ;;; 1415 ;;;
1425 ;;; we break the program, because it will appear that pop-up-windows and 1416 ;;; we break the program, because it will appear that pop-up-windows and
1426 ;;; old-pop-ups are not EQ when really they are. So we have to know what 1417 ;;; old-pop-ups are not EQ when really they are. So we have to know what
1427 ;;; the BOOL variables are, and not perform this optimization on them. 1418 ;;; the BOOL variables are, and not perform this optimization on them.
1428 ;;; 1419 ;;;
1429 1420
1430 ;;; This used to hold a large list of boolean variables, which had to 1421 ;;; This used to hold a large list of boolean variables, which had to
1600 ;; 1591 ;;
1601 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: 1592 ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X:
1602 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: 1593 ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X:
1603 ;; 1594 ;;
1604 ;; it is wrong to do the same thing for the -else-pop variants. 1595 ;; it is wrong to do the same thing for the -else-pop variants.
1605 ;; 1596 ;;
1606 ((and (or (eq 'byte-goto-if-nil (car lap0)) 1597 ((and (or (eq 'byte-goto-if-nil (car lap0))
1607 (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX 1598 (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
1608 (eq 'byte-goto (car lap1)) ; gotoY 1599 (eq 'byte-goto (car lap1)) ; gotoY
1609 (eq (cdr lap0) lap2)) ; TAG X 1600 (eq (cdr lap0) lap2)) ; TAG X
1610 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0)) 1601 (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
1703 (not (eq 'TAG (car (car tmp))))) 1694 (not (eq 'TAG (car (car tmp)))))
1704 (if opt-p (setq deleted (cons (car tmp) deleted) 1695 (if opt-p (setq deleted (cons (car tmp) deleted)
1705 str (concat str " %s") 1696 str (concat str " %s")
1706 i (1+ i)))) 1697 i (1+ i))))
1707 (if opt-p 1698 (if opt-p
1708 (let ((tagstr 1699 (let ((tagstr
1709 (if (eq 'TAG (car (car tmp))) 1700 (if (eq 'TAG (car (car tmp)))
1710 (format "%d:" (car (cdr (car tmp)))) 1701 (format "%d:" (car (cdr (car tmp))))
1711 (or (car tmp) "")))) 1702 (or (car tmp) ""))))
1712 (if (< i 6) 1703 (if (< i 6)
1713 (apply 'byte-compile-log-lap-1 1704 (apply 'byte-compile-log-lap-1
1885 (byte-goto-if-nil-else-pop . 1876 (byte-goto-if-nil-else-pop .
1886 byte-goto-if-not-nil-else-pop) 1877 byte-goto-if-not-nil-else-pop)
1887 (byte-goto-if-not-nil-else-pop . 1878 (byte-goto-if-not-nil-else-pop .
1888 byte-goto-if-nil-else-pop)))) 1879 byte-goto-if-nil-else-pop))))
1889 newtag) 1880 newtag)
1890 1881
1891 (nth 1 newtag) 1882 (nth 1 newtag)
1892 ) 1883 )
1893 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) 1884 (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
1894 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop) 1885 (if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
1895 ;; We can handle this case but not the -if-not-nil case, 1886 ;; We can handle this case but not the -if-not-nil case,