Mercurial > hg > xemacs-beta
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, |