X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/cb88b56ea9ea0a8c2e6ee5a2d61094d432ab93af..cf9a1b693fe26df8fedea0345270b812dbcbd6d3:/lisp/emacs-lisp/byte-opt.el diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 7bfa75dbaa..acb882dd9a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1,9 +1,11 @@ -;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler. +;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc. +;; Copyright (c) 1991, 1994, 2000, 2001, 2002, 2004 +;; Free Software Foundation, Inc. ;; Author: Jamie Zawinski ;; Hallvard Furuseth +;; Maintainer: FSF ;; Keywords: internal ;; This file is part of GNU Emacs. @@ -19,131 +21,178 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: -;;; ======================================================================== -;;; "No matter how hard you try, you can't make a racehorse out of a pig. -;;; you can, however, make a faster pig." -;;; -;;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code -;;; makes it be a VW Bug with fuel injection and a turbocharger... You're -;;; still not going to make it go faster than 70 mph, but it might be easier -;;; to get it there. -;;; - -;;; TO DO: -;;; -;;; (apply '(lambda (x &rest y) ...) 1 (foo)) -;;; -;;; collapse common subexpressions -;;; -;;; maintain a list of functions known not to access any global variables -;;; (actually, give them a 'dynamically-safe property) and then -;;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> -;;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) -;;; by recursing on this, we might be able to eliminate the entire let. -;;; However certain variables should never have their bindings optimized -;;; away, because they affect everything. -;;; (put 'debug-on-error 'binding-is-magic t) -;;; (put 'debug-on-abort 'binding-is-magic t) -;;; (put 'inhibit-quit 'binding-is-magic t) -;;; (put 'quit-flag 'binding-is-magic t) -;;; others? -;;; -;;; Simple defsubsts often produce forms like -;;; (let ((v1 (f1)) (v2 (f2)) ...) -;;; (FN v1 v2 ...)) -;;; It would be nice if we could optimize this to -;;; (FN (f1) (f2) ...) -;;; but we can't unless FN is dynamically-safe (it might be dynamically -;;; referring to the bindings that the lambda arglist established.) -;;; One of the uncountable lossages introduced by dynamic scope... -;;; -;;; Maybe there should be a control-structure that says "turn on -;;; fast-and-loose type-assumptive optimizations here." Then when -;;; we see a form like (car foo) we can from then on assume that -;;; the variable foo is of type cons, and optimize based on that. -;;; But, this won't win much because of (you guessed it) dynamic -;;; scope. Anything down the stack could change the value. -;;; -;;; It would be nice if redundant sequences could be factored out as well, -;;; when they are known to have no side-effects: -;;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 -;;; but beware of traps like -;;; (cons (list x y) (list x y)) -;;; -;;; Tail-recursion elimination is not really possible in Emacs Lisp. -;;; Tail-recursion elimination is almost always impossible when all variables -;;; have dynamic scope, but given that the "return" byteop requires the -;;; binding stack to be empty (rather than emptying it itself), there can be -;;; no truly tail-recursive Emacs Lisp functions that take any arguments or -;;; make any bindings. -;;; -;;; Here is an example of an Emacs Lisp function which could safely be -;;; byte-compiled tail-recursively: -;;; -;;; (defun tail-map (fn list) -;;; (cond (list -;;; (funcall fn (car list)) -;;; (tail-map fn (cdr list))))) -;;; -;;; However, if there was even a single let-binding around the COND, -;;; it could not be byte-compiled, because there would be an "unbind" -;;; byte-op between the final "call" and "return." Adding a -;;; Bunbind_all byteop would fix this. -;;; -;;; (defun foo (x y z) ... (foo a b c)) -;;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) -;;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) -;;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) -;;; -;;; this also can be considered tail recursion: -;;; -;;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) -;;; could generalize this by doing the optimization -;;; (goto X) ... X: (return) --> (return) -;;; -;;; But this doesn't solve all of the problems: although by doing tail- -;;; recursion elimination in this way, the call-stack does not grow, the -;;; binding-stack would grow with each recursive step, and would eventually -;;; overflow. I don't believe there is any way around this without lexical -;;; scope. -;;; -;;; Wouldn't it be nice if Emacs Lisp had lexical scope. -;;; -;;; Idea: the form (lexical-scope) in a file means that the file may be -;;; compiled lexically. This proclamation is file-local. Then, within -;;; that file, "let" would establish lexical bindings, and "let-dynamic" -;;; would do things the old way. (Or we could use CL "declare" forms.) -;;; We'd have to notice defvars and defconsts, since those variables should -;;; always be dynamic, and attempting to do a lexical binding of them -;;; should simply do a dynamic binding instead. -;;; But! We need to know about variables that were not necessarily defvarred -;;; in the file being compiled (doing a boundp check isn't good enough.) -;;; Fdefvar() would have to be modified to add something to the plist. -;;; -;;; A major disadvantage of this scheme is that the interpreter and compiler -;;; would have different semantics for files compiled with (dynamic-scope). -;;; Since this would be a file-local optimization, there would be no way to -;;; modify the interpreter to obey this (unless the loader was hacked -;;; in some grody way, but that's a really bad idea.) -;;; -;;; Really the Right Thing is to make lexical scope the default across -;;; the board, in the interpreter and compiler, and just FIX all of -;;; the code that relies on dynamic scope of non-defvarred variables. +;; ======================================================================== +;; "No matter how hard you try, you can't make a racehorse out of a pig. +;; You can, however, make a faster pig." +;; +;; Or, to put it another way, the emacs byte compiler is a VW Bug. This code +;; makes it be a VW Bug with fuel injection and a turbocharger... You're +;; still not going to make it go faster than 70 mph, but it might be easier +;; to get it there. +;; + +;; TO DO: +;; +;; (apply (lambda (x &rest y) ...) 1 (foo)) +;; +;; maintain a list of functions known not to access any global variables +;; (actually, give them a 'dynamically-safe property) and then +;; (let ( v1 v2 ... vM vN ) <...dynamically-safe...> ) ==> +;; (let ( v1 v2 ... vM ) vN <...dynamically-safe...> ) +;; by recursing on this, we might be able to eliminate the entire let. +;; However certain variables should never have their bindings optimized +;; away, because they affect everything. +;; (put 'debug-on-error 'binding-is-magic t) +;; (put 'debug-on-abort 'binding-is-magic t) +;; (put 'debug-on-next-call 'binding-is-magic t) +;; (put 'inhibit-quit 'binding-is-magic t) +;; (put 'quit-flag 'binding-is-magic t) +;; (put 't 'binding-is-magic t) +;; (put 'nil 'binding-is-magic t) +;; possibly also +;; (put 'gc-cons-threshold 'binding-is-magic t) +;; (put 'track-mouse 'binding-is-magic t) +;; others? +;; +;; Simple defsubsts often produce forms like +;; (let ((v1 (f1)) (v2 (f2)) ...) +;; (FN v1 v2 ...)) +;; It would be nice if we could optimize this to +;; (FN (f1) (f2) ...) +;; but we can't unless FN is dynamically-safe (it might be dynamically +;; referring to the bindings that the lambda arglist established.) +;; One of the uncountable lossages introduced by dynamic scope... +;; +;; Maybe there should be a control-structure that says "turn on +;; fast-and-loose type-assumptive optimizations here." Then when +;; we see a form like (car foo) we can from then on assume that +;; the variable foo is of type cons, and optimize based on that. +;; But, this won't win much because of (you guessed it) dynamic +;; scope. Anything down the stack could change the value. +;; (Another reason it doesn't work is that it is perfectly valid +;; to call car with a null argument.) A better approach might +;; be to allow type-specification of the form +;; (put 'foo 'arg-types '(float (list integer) dynamic)) +;; (put 'foo 'result-type 'bool) +;; It should be possible to have these types checked to a certain +;; degree. +;; +;; collapse common subexpressions +;; +;; It would be nice if redundant sequences could be factored out as well, +;; when they are known to have no side-effects: +;; (list (+ a b c) (+ a b c)) --> a b add c add dup list-2 +;; but beware of traps like +;; (cons (list x y) (list x y)) +;; +;; Tail-recursion elimination is not really possible in Emacs Lisp. +;; Tail-recursion elimination is almost always impossible when all variables +;; have dynamic scope, but given that the "return" byteop requires the +;; binding stack to be empty (rather than emptying it itself), there can be +;; no truly tail-recursive Emacs Lisp functions that take any arguments or +;; make any bindings. +;; +;; Here is an example of an Emacs Lisp function which could safely be +;; byte-compiled tail-recursively: +;; +;; (defun tail-map (fn list) +;; (cond (list +;; (funcall fn (car list)) +;; (tail-map fn (cdr list))))) +;; +;; However, if there was even a single let-binding around the COND, +;; it could not be byte-compiled, because there would be an "unbind" +;; byte-op between the final "call" and "return." Adding a +;; Bunbind_all byteop would fix this. +;; +;; (defun foo (x y z) ... (foo a b c)) +;; ... (const foo) (varref a) (varref b) (varref c) (call 3) END: (return) +;; ... (varref a) (varbind x) (varref b) (varbind y) (varref c) (varbind z) (goto 0) END: (unbind-all) (return) +;; ... (varref a) (varset x) (varref b) (varset y) (varref c) (varset z) (goto 0) END: (return) +;; +;; this also can be considered tail recursion: +;; +;; ... (const foo) (varref a) (call 1) (goto X) ... X: (return) +;; could generalize this by doing the optimization +;; (goto X) ... X: (return) --> (return) +;; +;; But this doesn't solve all of the problems: although by doing tail- +;; recursion elimination in this way, the call-stack does not grow, the +;; binding-stack would grow with each recursive step, and would eventually +;; overflow. I don't believe there is any way around this without lexical +;; scope. +;; +;; Wouldn't it be nice if Emacs Lisp had lexical scope. +;; +;; Idea: the form (lexical-scope) in a file means that the file may be +;; compiled lexically. This proclamation is file-local. Then, within +;; that file, "let" would establish lexical bindings, and "let-dynamic" +;; would do things the old way. (Or we could use CL "declare" forms.) +;; We'd have to notice defvars and defconsts, since those variables should +;; always be dynamic, and attempting to do a lexical binding of them +;; should simply do a dynamic binding instead. +;; But! We need to know about variables that were not necessarily defvarred +;; in the file being compiled (doing a boundp check isn't good enough.) +;; Fdefvar() would have to be modified to add something to the plist. +;; +;; A major disadvantage of this scheme is that the interpreter and compiler +;; would have different semantics for files compiled with (dynamic-scope). +;; Since this would be a file-local optimization, there would be no way to +;; modify the interpreter to obey this (unless the loader was hacked +;; in some grody way, but that's a really bad idea.) + +;; Other things to consider: + +;; ;; Associative math should recognize subcalls to identical function: +;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) +;; ;; This should generate the same as (1+ x) and (1- x) + +;; (disassemble (lambda (x) (cons (+ x 1) (- x 1)))) +;; ;; An awful lot of functions always return a non-nil value. If they're +;; ;; error free also they may act as true-constants. + +;; (disassemble (lambda (x) (and (point) (foo)))) +;; ;; When +;; ;; - all but one arguments to a function are constant +;; ;; - the non-constant argument is an if-expression (cond-expression?) +;; ;; then the outer function can be distributed. If the guarding +;; ;; condition is side-effect-free [assignment-free] then the other +;; ;; arguments may be any expressions. Since, however, the code size +;; ;; can increase this way they should be "simple". Compare: + +;; (disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) +;; (disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c)))) + +;; ;; (car (cons A B)) -> (prog1 A B) +;; (disassemble (lambda (x) (car (cons (foo) 42)))) + +;; ;; (cdr (cons A B)) -> (progn A B) +;; (disassemble (lambda (x) (cdr (cons 42 (foo))))) + +;; ;; (car (list A B ...)) -> (prog1 A B ...) +;; (disassemble (lambda (x) (car (list (foo) 42 (bar))))) + +;; ;; (cdr (list A B ...)) -> (progn A (list B ...)) +;; (disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) + ;;; Code: +(require 'bytecomp) + (defun byte-compile-log-lap-1 (format &rest args) (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well.")) + (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply 'format format (let (c a) - (mapcar '(lambda (arg) + (mapcar (lambda (arg) (if (not (consp arg)) (if (and (symbolp arg) (string-match "^byte-" (symbol-name arg))) @@ -169,10 +218,8 @@ args))))) (defmacro byte-compile-log-lap (format-string &rest args) - (list 'and - '(memq byte-optimize-log '(t byte)) - (cons 'byte-compile-log-lap-1 - (cons format-string args)))) + `(and (memq byte-optimize-log '(t byte)) + (byte-compile-log-lap-1 ,format-string ,@args))) ;;; byte-compile optimizers to support inlining @@ -183,17 +230,17 @@ "byte-optimize-handler for the `inline' special-form." (cons 'progn (mapcar - '(lambda (sexp) - (let ((fn (car-safe sexp))) - (if (and (symbolp fn) - (or (cdr (assq fn byte-compile-function-environment)) - (and (fboundp fn) - (not (or (cdr (assq fn byte-compile-macro-environment)) - (and (consp (setq fn (symbol-function fn))) - (eq (car fn) 'macro)) - (subrp fn)))))) - (byte-compile-inline-expand sexp) - sexp))) + (lambda (sexp) + (let ((f (car-safe sexp))) + (if (and (symbolp f) + (or (cdr (assq f byte-compile-function-environment)) + (not (or (not (fboundp f)) + (cdr (assq f byte-compile-macro-environment)) + (and (consp (setq f (symbol-function f))) + (eq (car f) 'macro)) + (subrp f))))) + (byte-compile-inline-expand sexp) + sexp))) (cdr form)))) @@ -204,31 +251,40 @@ (defun byte-inline-lapcode (lap) (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))) - (defun byte-compile-inline-expand (form) (let* ((name (car form)) (fn (or (cdr (assq name byte-compile-function-environment)) (and (fboundp name) (symbol-function name))))) (if (null fn) (progn - (byte-compile-warn "attempt to inline %s before it was defined" name) + (byte-compile-warn "attempt to inline `%s' before it was defined" + name) form) ;; else + (when (and (consp fn) (eq (car fn) 'autoload)) + (load (nth 1 fn)) + (setq fn (or (and (fboundp name) (symbol-function name)) + (cdr (assq name byte-compile-function-environment))))) (if (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn))) - (if (and (consp fn) (eq (car fn) 'autoload)) - (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) - (if (symbolp fn) + (error "File `%s' didn't define `%s'" (nth 1 fn) name)) + (if (and (symbolp fn) (not (eq fn t))) (byte-compile-inline-expand (cons fn (cdr form))) (if (byte-code-function-p fn) - (cons (list 'lambda (aref fn 0) - (list 'byte-code (aref fn 1) (aref fn 2) (aref fn 3))) - (cdr form)) - (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name)) - (cons fn (cdr form))))))) - -;;; ((lambda ...) ...) -;;; + (let (string) + (fetch-bytecode fn) + (setq string (aref fn 1)) + ;; Isn't it an error for `string' not to be unibyte?? --stef + (if (fboundp 'string-as-unibyte) + (setq string (string-as-unibyte string))) + (cons `(lambda ,(aref fn 0) + (byte-code ,string ,(aref fn 2) ,(aref fn 3))) + (cdr form))) + (if (eq (car-safe fn) 'lambda) + (cons fn (cdr form)) + ;; Give up on inlining. + form)))))) + +;; ((lambda ...) ...) (defun byte-compile-unfold-lambda (form &optional name) (or name (setq name "anonymous lambda")) (let ((lambda (car form)) @@ -268,7 +324,7 @@ bindings) values nil)) ((and (not optionalp) (null values)) - (byte-compile-warn "attempt to open-code %s with too few arguments" name) + (byte-compile-warn "attempt to open-code `%s' with too few arguments" name) (setq arglist nil values 'too-few)) (t (setq bindings (cons (list (car arglist) (car values)) @@ -279,9 +335,15 @@ (progn (or (eq values 'too-few) (byte-compile-warn - "attempt to open-code %s with too many arguments" name)) + "attempt to open-code `%s' with too many arguments" name)) form) - (let ((newform + + ;; The following leads to infinite recursion when loading a + ;; file containing `(defsubst f () (f))', and then trying to + ;; byte-compile that file. + ;(setq body (mapcar 'byte-optimize-form body))) + + (let ((newform (if bindings (cons 'let (cons (nreverse bindings) body)) (cons 'progn body)))) @@ -309,7 +371,7 @@ form)) ((eq fn 'quote) (if (cdr (cdr form)) - (byte-compile-warn "malformed quote form: %s" + (byte-compile-warn "malformed quote form: `%s'" (prin1-to-string form))) ;; map (quote nil) to nil to simplify optimizer logic. ;; map quoted constants to nil if for-effect (just because). @@ -325,11 +387,11 @@ ;; are more deeply nested are optimized first. (cons fn (cons - (mapcar '(lambda (binding) + (mapcar (lambda (binding) (if (symbolp binding) binding (if (cdr (cdr binding)) - (byte-compile-warn "malformed let binding: %s" + (byte-compile-warn "malformed let binding: `%s'" (prin1-to-string binding))) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) @@ -337,12 +399,12 @@ (byte-optimize-body (cdr (cdr form)) for-effect)))) ((eq fn 'cond) (cons fn - (mapcar '(lambda (clause) + (mapcar (lambda (clause) (if (consp clause) (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: %s" + (byte-compile-warn "malformed cond form: `%s'" (prin1-to-string clause)) clause)) (cdr form)))) @@ -364,28 +426,30 @@ (cons (byte-optimize-form (nth 1 form) t) (cons (byte-optimize-form (nth 2 form) for-effect) (byte-optimize-body (cdr (cdr (cdr form))) t))))) - - ((memq fn '(save-excursion save-restriction)) + + ((memq fn '(save-excursion save-restriction save-current-buffer)) ;; those subrs which have an implicit progn; it's not quite good ;; enough to treat these like normal function calls. ;; This can turn (save-excursion ...) into (save-excursion) which ;; will be optimized away in the lap-optimize pass. (cons fn (byte-optimize-body (cdr form) for-effect))) - + ((eq fn 'with-output-to-temp-buffer) ;; this is just like the above, except for the first argument. (cons fn (cons (byte-optimize-form (nth 1 form) nil) (byte-optimize-body (cdr (cdr form)) for-effect)))) - + ((eq fn 'if) + (when (< (length form) 3) + (byte-compile-warn "too few arguments for `if'")) (cons fn (cons (byte-optimize-form (nth 1 form) nil) (cons (byte-optimize-form (nth 2 form) for-effect) (byte-optimize-body (nthcdr 3 form) for-effect))))) - + ((memq fn '(and or)) ; remember, and/or are control structures. ;; take forms off the back until we can't any more. ;; In the future it could conceivably be a problem that the @@ -402,14 +466,14 @@ (byte-compile-log " all subforms of %s called for effect; deleted" form)) (and backwards - (cons fn (nreverse backwards)))) + (cons fn (nreverse (mapcar 'byte-optimize-form backwards))))) (cons fn (mapcar 'byte-optimize-form (cdr form))))) ((eq fn 'interactive) - (byte-compile-warn "misplaced interactive spec: %s" + (byte-compile-warn "misplaced interactive spec: `%s'" (prin1-to-string form)) nil) - + ((memq fn '(defun defmacro function condition-case save-window-excursion)) ;; These forms are compiled as constants or by breaking out @@ -425,7 +489,7 @@ (cons fn (cons (byte-optimize-form (nth 1 form) for-effect) (cdr (cdr form))))) - + ((eq fn 'catch) ;; the body of a catch is compiled (and thus optimized) as a ;; top-level form, so don't do it here. The tag is never @@ -435,6 +499,13 @@ (cons (byte-optimize-form (nth 1 form) nil) (cdr (cdr form))))) + ((eq fn 'ignore) + ;; Don't treat the args to `ignore' as being + ;; computed for effect. We want to avoid the warnings + ;; that might occur if they were treated that way. + ;; However, don't actually bother calling `ignore'. + `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form)))) + ;; If optimization is on, this is the only place that macros are ;; expanded. If optimization is off, then macroexpansion happens ;; in byte-compile-form. Otherwise, the macros are already expanded @@ -443,25 +514,45 @@ (setq form (macroexpand form byte-compile-macro-environment)))) (byte-optimize-form form for-effect)) - + + ;; Support compiler macros as in cl.el. + ((and (fboundp 'compiler-macroexpand) + (symbolp (car-safe form)) + (get (car-safe form) 'cl-compiler-macro) + (not (eq form + (with-no-warnings + (setq form (compiler-macroexpand form)))))) + (byte-optimize-form form for-effect)) + ((not (symbolp fn)) - (or (eq 'mocklisp (car-safe fn)) ; ha! - (byte-compile-warn "%s is a malformed function" - (prin1-to-string fn))) + (byte-compile-warn "`%s' is a malformed function" + (prin1-to-string fn)) form) ((and for-effect (setq tmp (get fn 'side-effect-free)) (or byte-compile-delete-errors (eq tmp 'error-free) + ;; Detect the expansion of (pop foo). + ;; There is no need to compile the call to `car' there. + (and (eq fn 'car) + (eq (car-safe (cadr form)) 'prog1) + (let ((var (cadr (cadr form))) + (last (nth 2 (cadr form)))) + (and (symbolp var) + (null (nthcdr 3 (cadr form))) + (eq (car-safe last) 'setq) + (eq (cadr last) var) + (eq (car-safe (nth 2 last)) 'cdr) + (eq (cadr (nth 2 last)) var)))) (progn - (byte-compile-warn "%s called for effect" - (prin1-to-string form)) + (byte-compile-warn "`%s' called for effect" + (prin1-to-string (car form))) nil))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. (byte-optimize-form (cons 'progn (append (cdr form) '(nil))) t)) - + (t ;; Otherwise, no args can be considered to be for-effect, ;; even if the called function is for-effect, because we @@ -513,24 +604,25 @@ (nreverse result))) -;;; some source-level optimizers -;;; -;;; when writing optimizers, be VERY careful that the optimizer returns -;;; something not EQ to its argument if and ONLY if it has made a change. -;;; This implies that you cannot simply destructively modify the list; -;;; you must return something not EQ to it if you make an optimization. -;;; -;;; It is now safe to optimize code such that it introduces new bindings. +;; some source-level optimizers +;; +;; when writing optimizers, be VERY careful that the optimizer returns +;; something not EQ to its argument if and ONLY if it has made a change. +;; This implies that you cannot simply destructively modify the list; +;; you must return something not EQ to it if you make an optimization. +;; +;; It is now safe to optimize code such that it introduces new bindings. ;; I'd like this to be a defsubst, but let's not be self-referential... (defmacro byte-compile-trueconstp (form) ;; Returns non-nil if FORM is a non-nil constant. - (` (cond ((consp (, form)) (eq (car (, form)) 'quote)) - ((not (symbolp (, form)))) - ((eq (, form) t))))) + `(cond ((consp ,form) (eq (car ,form) 'quote)) + ((not (symbolp ,form))) + ((eq ,form t)) + ((keywordp ,form)))) ;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer +;; evaluate as much as possible at compile-time. This optimizer ;; assumes that the function is associative, like + or *. (defun byte-optimize-associative-math (form) (let ((args nil) @@ -552,8 +644,10 @@ form))) ;; If the function is being called with constant numeric args, -;; evaluate as much as possible at compile-time. This optimizer -;; assumes that the function is nonassociative, like - or /. +;; evaluate as much as possible at compile-time. This optimizer +;; assumes that the function satisfies +;; (op x1 x2 ... xn) == (op ...(op (op x1 x2) x3) ...xn) +;; like - and /. (defun byte-optimize-nonassociative-math (form) (if (or (not (numberp (car (cdr form)))) (not (numberp (car (cdr (cdr form)))))) @@ -579,21 +673,44 @@ ;; (byte-optimize-two-args-right form) ;; form)) +(defun byte-optimize-approx-equal (x y) + (<= (* (abs (- x y)) 100) (abs (+ x y)))) + +;; Collect all the constants from FORM, after the STARTth arg, +;; and apply FUN to them to make one argument at the end. +;; For functions that can handle floats, that optimization +;; can be incorrect because reordering can cause an overflow +;; that would otherwise be avoided by encountering an arg that is a float. +;; We avoid this problem by (1) not moving float constants and +;; (2) not moving anything if it would cause an overflow. (defun byte-optimize-delay-constants-math (form start fun) ;; Merge all FORM's constants from number START, call FUN on them ;; and put the result at the end. - (let ((rest (nthcdr (1- start) form))) + (let ((rest (nthcdr (1- start) form)) + (orig form) + ;; t means we must check for overflow. + (overflow (memq fun '(+ *)))) (while (cdr (setq rest (cdr rest))) - (if (numberp (car rest)) + (if (integerp (car rest)) (let (constants) (setq form (copy-sequence form) rest (nthcdr (1- start) form)) (while (setq rest (cdr rest)) - (cond ((numberp (car rest)) + (cond ((integerp (car rest)) (setq constants (cons (car rest) constants)) (setcar rest nil)))) - (setq form (nconc (delq nil form) - (list (apply fun (nreverse constants)))))))) + ;; If necessary, check now for overflow + ;; that might be caused by reordering. + (if (and overflow + ;; We have overflow if the result of doing the arithmetic + ;; on floats is not even close to the result + ;; of doing it on integers. + (not (byte-optimize-approx-equal + (apply fun (mapcar 'float constants)) + (float (apply fun constants))))) + (setq form orig) + (setq form (nconc (delq nil form) + (list (apply fun (nreverse constants))))))))) form)) (defun byte-optimize-plus (form) @@ -604,10 +721,28 @@ (condition-case () (eval form) (error form))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). -;; ((null (cdr (cdr form))) (nth 1 form)) +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). +;;; ((null (cdr (cdr form))) (nth 1 form)) + ((null (cddr form)) + (if (numberp (nth 1 form)) + (nth 1 form) + form)) + ((and (null (nthcdr 3 form)) + (or (memq (nth 1 form) '(1 -1)) + (memq (nth 2 form) '(1 -1)))) + ;; Optimize (+ x 1) into (1+ x) and (+ x -1) into (1- x). + (let ((integer + (if (memq (nth 1 form) '(1 -1)) + (nth 1 form) + (nth 2 form))) + (other + (if (memq (nth 1 form) '(1 -1)) + (nth 2 form) + (nth 1 form)))) + (list (if (eq integer 1) '1+ '1-) + other))) (t form))) (defun byte-optimize-minus (form) @@ -619,14 +754,18 @@ ;; (- x y ... 0) --> (- x y ...) (setq form (copy-sequence form)) (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form)))) + ((equal (nthcdr 2 form) '(1)) + (setq form (list '1- (nth 1 form)))) + ((equal (nthcdr 2 form) '(-1)) + (setq form (list '1+ (nth 1 form)))) ;; If form is (- CONST foo... CONST), merge first and last. ((and (numberp (nth 1 form)) (numberp last)) (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) (delq last (copy-sequence (nthcdr 3 form)))))))) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker). +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker). ;;; (if (eq (nth 2 form) 0) ;;; (nth 1 form) ; (- x 0) --> x (byte-optimize-predicate @@ -641,12 +780,12 @@ (setq form (byte-optimize-delay-constants-math form 1 '*)) ;; If there is a constant in FORM, it is now the last element. (cond ((null (cdr form)) 1) -;;; It is not safe to delete the function entirely -;;; (actually, it would be safe if we know the sole arg -;;; is not a marker or if it appears in other arithmetic). +;;; It is not safe to delete the function entirely +;;; (actually, it would be safe if we know the sole arg +;;; is not a marker or if it appears in other arithmetic). ;;; ((null (cdr (cdr form))) (nth 1 form)) ((let ((last (car (reverse form)))) - (cond ((eq 0 last) (list 'progn (cdr form))) + (cond ((eq 0 last) (cons 'progn (cdr form))) ((eq 1 last) (delq 1 (copy-sequence form))) ((eq -1 last) (list '- (delq -1 (copy-sequence form)))) ((and (eq 2 last) @@ -664,8 +803,12 @@ (let ((last (car (reverse (cdr (cdr form)))))) (if (numberp last) (cond ((= (length form) 3) - ;; Don't shrink to less than two arguments--would get an error. - nil) + (if (and (numberp (nth 1 form)) + (not (zerop last)) + (condition-case nil + (/ (nth 1 form) last) + (error nil))) + (setq form (list 'progn (/ (nth 1 form) last))))) ((= last 1) (setq form (byte-compile-butlast form))) ((numberp (nth 1 form)) @@ -673,7 +816,7 @@ (cons (/ (nth 1 form) last) (byte-compile-butlast (cdr (cdr form))))) last nil)))) - (cond + (cond ;;; ((null (cdr (cdr form))) ;;; (nth 1 form)) ((eq (nth 1 form) 0) @@ -693,7 +836,7 @@ (delq 0 (copy-sequence form))))) ((and (eq (car-safe form) 'logior) (memq -1 form)) - (delq -1 (copy-sequence form))) + (cons 'progn (cdr form))) (form)))) @@ -738,7 +881,6 @@ (put '= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'eq 'byte-optimizer 'byte-optimize-binary-predicate) -(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate) (put 'equal 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) @@ -770,7 +912,7 @@ (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) -;; I'm not convinced that this is necessary. Doesn't the optimizer loop +;; I'm not convinced that this is necessary. Doesn't the optimizer loop ;; take care of this? - Jamie ;; I think this may some times be necessary to reduce ie (quote 5) to 5, ;; so arithmetic optimizers recognize the numeric constant. - Hallvard @@ -778,7 +920,7 @@ (defun byte-optimize-quote (form) (if (or (consp (nth 1 form)) (and (symbolp (nth 1 form)) - (not (memq (nth 1 form) '(nil t))))) + (not (byte-compile-const-symbol-p form)))) form (nth 1 form))) @@ -876,7 +1018,13 @@ (list 'if clause (nth 2 form)) form)) ((or (nth 3 form) (nthcdr 4 form)) - (list 'if (list 'not clause) + (list 'if + ;; Don't make a double negative; + ;; instead, take away the one that is there. + (if (and (consp clause) (memq (car clause) '(not null)) + (= (length clause) 2)) ; (not xxxx) or (not (xxxx)) + (nth 1 clause) + (list 'not clause)) (if (nthcdr 4 form) (cons 'progn (nthcdr 3 form)) (nth 3 form)))) @@ -884,6 +1032,8 @@ (list 'progn clause nil))))) (defun byte-optimize-while (form) + (when (< (length form) 2) + (byte-compile-warn "too few arguments for `while'")) (if (nth 1 form) form)) @@ -900,8 +1050,8 @@ (defun byte-optimize-funcall (form) - ;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...) - ;; (funcall 'foo ...) ==> (foo ...) + ;; (funcall (lambda ...) ...) ==> ((lambda ...) ...) + ;; (funcall foo ...) ==> (foo ...) (let ((fn (nth 1 form))) (if (memq (car-safe fn) '(quote function)) (cons (nth 1 fn) (cdr (cdr form))) @@ -917,9 +1067,9 @@ (if (listp (nth 1 last)) (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast - (mapcar '(lambda (x) (list 'quote x)) (nth 1 last)))) + (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) (byte-compile-warn - "last arg to apply can't be a literal atom: %s" + "last arg to apply can't be a literal atom: `%s'" (prin1-to-string last)) nil)) form))) @@ -938,7 +1088,8 @@ form) ;; The body is nil ((eq (car form) 'let) - (append '(progn) (mapcar 'car (mapcar 'cdr (nth 1 form))) '(nil))) + (append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form))) + '(nil))) (t (let ((binds (reverse (nth 1 form)))) (list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil))))) @@ -946,77 +1097,190 @@ (put 'nth 'byte-optimizer 'byte-optimize-nth) (defun byte-optimize-nth (form) - (if (memq (nth 1 form) '(0 1)) - (list 'car (if (zerop (nth 1 form)) - (nth 2 form) - (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form))) + (if (= (safe-length form) 3) + (if (memq (nth 1 form) '(0 1)) + (list 'car (if (zerop (nth 1 form)) + (nth 2 form) + (list 'cdr (nth 2 form)))) + (byte-optimize-predicate form)) + form)) (put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) (defun byte-optimize-nthcdr (form) - (let ((count (nth 1 form))) - (if (not (memq count '(0 1 2))) - (byte-optimize-predicate form) - (setq form (nth 2 form)) - (while (natnump (setq count (1- count))) - (setq form (list 'cdr form))) + (if (= (safe-length form) 3) + (if (memq (nth 1 form) '(0 1 2)) + (let ((count (nth 1 form))) + (setq form (nth 2 form)) + (while (>= (setq count (1- count)) 0) + (setq form (list 'cdr form))) + form) + (byte-optimize-predicate form)) + form)) + +(put 'concat 'byte-optimizer 'byte-optimize-pure-func) +(put 'symbol-name 'byte-optimizer 'byte-optimize-pure-func) +(put 'regexp-opt 'byte-optimizer 'byte-optimize-pure-func) +(put 'regexp-quote 'byte-optimizer 'byte-optimize-pure-func) +(defun byte-optimize-pure-func (form) + "Do constant folding for pure functions. +This assumes that the function will not have any side-effects and that +its return value depends solely on its arguments. +If the function can signal an error, this might change the semantics +of FORM by signalling the error at compile-time." + (let ((args (cdr form)) + (constant t)) + (while (and args constant) + (or (byte-compile-constp (car args)) + (setq constant nil)) + (setq args (cdr args))) + (if constant + (eval form) form))) + +;; Avoid having to write forward-... with a negative arg for speed. +;; Fixme: don't be limited to constant args. +(put 'backward-char 'byte-optimizer 'byte-optimize-backward-char) +(defun byte-optimize-backward-char (form) + (cond ((and (= 2 (safe-length form)) + (numberp (nth 1 form))) + (list 'forward-char (eval (- (nth 1 form))))) + ((= 1 (safe-length form)) + '(forward-char -1)) + (t form))) + +(put 'backward-word 'byte-optimizer 'byte-optimize-backward-word) +(defun byte-optimize-backward-word (form) + (cond ((and (= 2 (safe-length form)) + (numberp (nth 1 form))) + (list 'forward-word (eval (- (nth 1 form))))) + ((= 1 (safe-length form)) + '(forward-word -1)) + (t form))) + +(put 'char-before 'byte-optimizer 'byte-optimize-char-before) +(defun byte-optimize-char-before (form) + (cond ((= 2 (safe-length form)) + `(char-after (1- ,(nth 1 form)))) + ((= 1 (safe-length form)) + '(char-after (1- (point)))) + (t form))) + +;; Fixme: delete-char -> delete-region (byte-coded) +;; optimize string-as-unibyte, string-as-multibyte, string-make-unibyte, +;; string-make-multibyte for constant args. + +(put 'featurep 'byte-optimizer 'byte-optimize-featurep) +(defun byte-optimize-featurep (form) + ;; Emacs-21's byte-code doesn't run under XEmacs anyway, so we can + ;; safely optimize away this test. + (if (equal '((quote xemacs)) (cdr-safe form)) + nil + form)) + +(put 'set 'byte-optimizer 'byte-optimize-set) +(defun byte-optimize-set (form) + (let ((var (car-safe (cdr-safe form)))) + (cond + ((and (eq (car-safe var) 'quote) (consp (cdr var))) + `(setq ,(cadr var) ,@(cddr form))) + ((and (eq (car-safe var) 'make-local-variable) + (eq (car-safe (setq var (car-safe (cdr var)))) 'quote) + (consp (cdr var))) + `(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form)))) + (t form)))) -;;; enumerating those functions which need not be called if the returned -;;; value is not used. That is, something like -;;; (progn (list (something-with-side-effects) (yow)) -;;; (foo)) -;;; may safely be turned into -;;; (progn (progn (something-with-side-effects) (yow)) -;;; (foo)) -;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. - -;;; I wonder if I missed any :-\) +;; enumerating those functions which need not be called if the returned +;; value is not used. That is, something like +;; (progn (list (something-with-side-effects) (yow)) +;; (foo)) +;; may safely be turned into +;; (progn (progn (something-with-side-effects) (yow)) +;; (foo)) +;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. + +;; Some of these functions have the side effect of allocating memory +;; and it would be incorrect to replace two calls with one. +;; But we don't try to do those kinds of optimizations, +;; so it is safe to list such functions here. +;; Some of these functions return values that depend on environment +;; state, so that constant folding them would be wrong, +;; but we don't do constant folding based on this list. + +;; However, at present the only optimization we normally do +;; is delete calls that need not occur, and we only do that +;; with the error-free functions. + +;; I wonder if I missed any :-\) (let ((side-effect-free-fns '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan assoc assq boundp buffer-file-name buffer-local-variables buffer-modified-p - buffer-substring - capitalize car-less-than-car car cdr ceiling concat coordinates-in-window-p - copy-marker cos count-lines - default-boundp default-value documentation downcase - elt exp expt fboundp featurep + buffer-substring byte-code-function-p + capitalize car-less-than-car car cdr ceiling char-after char-before + char-equal char-to-string char-width + compare-strings concat coordinates-in-window-p + copy-alist copy-sequence copy-marker cos count-lines + decode-time default-boundp default-value documentation downcase + elt exp expt encode-time error-message-string + fboundp fceiling featurep ffloor file-directory-p file-exists-p file-locked-p file-name-absolute-p file-newer-than-file-p file-readable-p file-symlink-p file-writable-p - float floor format - get get-buffer get-buffer-window getenv get-file-buffer - int-to-string - length log log10 logand logb logior lognot logxor lsh - marker-buffer max member memq min mod + float float-time floor format format-time-string frame-visible-p + fround ftruncate + get gethash get-buffer get-buffer-window getenv get-file-buffer + hash-table-count + int-to-string intern-soft + keymap-parent + length local-variable-if-set-p local-variable-p log log10 logand + logb logior lognot logxor lsh + make-list make-string make-symbol + marker-buffer max member memq min mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string - parse-colon-path previous-window - radians-to-degrees rassq regexp-quote reverse round - sin sqrt string< string= string-equal string-lessp string-to-char - string-to-int string-to-number substring symbol-plist - tan upcase user-variable-p vconcat + parse-colon-path plist-get plist-member + prefix-numeric-value previous-window prin1-to-string propertize + radians-to-degrees rassq rassoc read-from-string regexp-quote + region-beginning region-end reverse round + sin sqrt string string< string= string-equal string-lessp string-to-char + string-to-int string-to-number substring sxhash symbol-function + symbol-name symbol-plist symbol-value string-make-unibyte + string-make-multibyte string-as-multibyte string-as-unibyte + tan truncate + unibyte-char-to-multibyte upcase user-full-name + user-login-name user-original-login-name user-variable-p + vconcat window-buffer window-dedicated-p window-edges window-height window-hscroll window-minibuffer-p window-width zerop)) (side-effect-and-error-free-fns '(arrayp atom - bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp + bobp bolp bool-vector-p + buffer-end buffer-list buffer-size buffer-string bufferp car-safe case-table-p cdr-safe char-or-string-p commandp cons consp - current-buffer - dot dot-marker eobp eolp eq eql equal eventp floatp framep + current-buffer current-global-map current-indentation + current-local-map current-minor-mode-maps current-time + current-time-string current-time-zone + eobp eolp eq equal eventp + floatp following-char framep get-largest-window get-lru-window + hash-table-p identity ignore integerp integer-or-marker-p interactive-p invocation-directory invocation-name - keymapp list listp + keymapp + line-beginning-position line-end-position list listp make-marker mark mark-marker markerp memory-limit minibuffer-window mouse-movement-p natnump nlistp not null number-or-marker-p numberp one-window-p overlayp - point point-marker point-min point-max processp - selected-window sequencep stringp subrp symbolp syntax-table-p - user-full-name user-login-name user-original-login-name + point point-marker point-min point-max preceding-char processp + recent-keys recursion-depth + safe-length selected-frame selected-window sequencep + standard-case-table standard-syntax-table stringp subrp symbolp + syntax-table syntax-table-p + this-command-keys this-command-keys-vector this-single-command-keys + this-single-command-raw-keys user-real-login-name user-real-uid user-uid - vector vectorp - window-configuration-p window-live-p windowp))) + vector vectorp visible-frame-list + wholenump window-configuration-p window-live-p windowp))) (while side-effect-free-fns (put (car side-effect-free-fns) 'side-effect-free t) (setq side-effect-free-fns (cdr side-effect-free-fns))) @@ -1042,13 +1306,13 @@ (defconst byte-constref-ops '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) -;;; This function extracts the bitfields from variable-length opcodes. -;;; Originally defined in disass.el (which no longer uses it.) +;; This function extracts the bitfields from variable-length opcodes. +;; Originally defined in disass.el (which no longer uses it.) (defun disassemble-offset () "Don't call this!" ;; fetch and return the offset for the current opcode. - ;; return NIL if this opcode has no offset + ;; return nil if this opcode has no offset ;; OP, PTR and BYTES are used and set dynamically (defvar op) (defvar ptr) @@ -1080,11 +1344,11 @@ (aref bytes ptr)))) -;;; This de-compiler is used for inline expansion of compiled functions, -;;; and by the disassembler. -;;; -;;; This list contains numbers, which are pc values, -;;; before each instruction. +;; This de-compiler is used for inline expansion of compiled functions, +;; and by the disassembler. +;; +;; This list contains numbers, which are pc values, +;; before each instruction. (defun byte-decompile-bytecode (bytes constvec) "Turns BYTECODE into lapcode, referring to CONSTVEC." (let ((byte-compile-constants nil) @@ -1102,10 +1366,9 @@ ;; before each insn (or its label). (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) - (ptr 0) optr tag tags op offset + (ptr 0) optr tags op offset lap tmp - endtag - (retcount 0)) + endtag) (while (not (= ptr length)) (or make-spliceable (setq lap (cons ptr lap))) @@ -1123,7 +1386,9 @@ tags))))))) ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t) ((memq op byte-constref-ops))) - (setq tmp (aref constvec offset) + (setq tmp (if (>= offset (length constvec)) + (list 'out-of-range offset) + (aref constvec offset)) offset (if (eq op 'byte-constant) (byte-compile-get-constant tmp) (or (assq tmp byte-compile-variables) @@ -1175,11 +1440,14 @@ (defconst byte-after-unbind-ops '(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp - byte-eq byte-equal byte-not + byte-eq byte-not byte-cons byte-list1 byte-list2 ; byte-list3 byte-list4 byte-interactive-p) ;; How about other side-effect-free-ops? Is it safe to move an ;; error invocation (such as from nth) out of an unwind-protect? + ;; No, it is not, because the unwind-protect forms can alter + ;; the inside of the object to which nth would apply. + ;; For the same reason, byte-equal was deleted from this list. "Byte-codes that can be moved past an unbind.") (defconst byte-compile-side-effect-and-error-free-ops @@ -1191,7 +1459,7 @@ byte-current-buffer byte-interactive-p)) (defconst byte-compile-side-effect-free-ops - (nconc + (nconc '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate @@ -1200,55 +1468,42 @@ byte-member byte-assq byte-quo byte-rem) byte-compile-side-effect-and-error-free-ops)) -;;; This piece of shit is because of the way DEFVAR_BOOL() variables work. -;;; Consider the code -;;; -;;; (defun foo (flag) -;;; (let ((old-pop-ups pop-up-windows) -;;; (pop-up-windows flag)) -;;; (cond ((not (eq pop-up-windows old-pop-ups)) -;;; (setq old-pop-ups pop-up-windows) -;;; ...)))) -;;; -;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is -;;; something else. But if we optimize -;;; -;;; varref flag -;;; varbind pop-up-windows -;;; varref pop-up-windows -;;; not -;;; to -;;; varref flag -;;; dup -;;; varbind pop-up-windows -;;; not -;;; -;;; we break the program, because it will appear that pop-up-windows and -;;; old-pop-ups are not EQ when really they are. So we have to know what -;;; the BOOL variables are, and not perform this optimization on them. -;;; -(defconst byte-boolean-vars - '(abbrev-all-caps abbrevs-changed byte-metering-on - check-protected-fields completion-auto-help completion-ignore-case - cursor-in-echo-area debug-on-next-call debug-on-quit - defining-kbd-macro delete-exited-processes - enable-recursive-minibuffers - highlight-nonselected-windows indent-tabs-mode - insert-default-directory inverse-video load-in-progress - menu-prompting mode-line-inverse-video no-redraw-on-reenter - noninteractive parse-sexp-ignore-comments pop-up-frames - pop-up-windows print-escape-newlines print-escape-newlines - truncate-partial-width-windows visible-bell vms-stmlf-recfm - words-include-escapes x-save-under) - "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t. -If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer -may generate incorrect code.") +;; This crock is because of the way DEFVAR_BOOL variables work. +;; Consider the code +;; +;; (defun foo (flag) +;; (let ((old-pop-ups pop-up-windows) +;; (pop-up-windows flag)) +;; (cond ((not (eq pop-up-windows old-pop-ups)) +;; (setq old-pop-ups pop-up-windows) +;; ...)))) +;; +;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is +;; something else. But if we optimize +;; +;; varref flag +;; varbind pop-up-windows +;; varref pop-up-windows +;; not +;; to +;; varref flag +;; dup +;; varbind pop-up-windows +;; not +;; +;; we break the program, because it will appear that pop-up-windows and +;; old-pop-ups are not EQ when really they are. So we have to know what +;; the BOOL variables are, and not perform this optimization on them. + +;; The variable `byte-boolean-vars' is now primitive and updated +;; automatically by DEFVAR_BOOL. (defun byte-optimize-lapcode (lap &optional for-effect) - "Simple peephole optimizer. LAP is both modified and returned." - (let (lap0 off0 - lap1 off1 - lap2 off2 + "Simple peephole optimizer. LAP is both modified and returned. +If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." + (let (lap0 + lap1 + lap2 (keep-going 'first-time) (add-depth 0) rest tmp tmp2 tmp3 @@ -1328,7 +1583,8 @@ may generate incorrect code.") (if (memq (car lap0) '(byte-constant byte-dup)) (progn (setq tmp (if (or (not tmp) - (memq (car (cdr lap0)) '(nil t))) + (byte-compile-const-symbol-p + (car (cdr lap0)))) (cdr lap0) (byte-compile-get-constant t))) (byte-compile-log-lap " %s %s %s\t-->\t%s %s %s" @@ -1383,7 +1639,7 @@ may generate incorrect code.") ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: ;; ;; it is wrong to do the same thing for the -else-pop variants. - ;; + ;; ((and (or (eq 'byte-goto-if-nil (car lap0)) (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX (eq 'byte-goto (car lap1)) ; gotoY @@ -1486,9 +1742,9 @@ may generate incorrect code.") str (concat str " %s") i (1+ i)))) (if opt-p - (let ((tagstr + (let ((tagstr (if (eq 'TAG (car (car tmp))) - (format "%d:" (cdr (car tmp))) + (format "%d:" (car (cdr (car tmp)))) (or (car tmp) "")))) (if (< i 6) (apply 'byte-compile-log-lap-1 @@ -1667,7 +1923,7 @@ may generate incorrect code.") (byte-goto-if-not-nil-else-pop . byte-goto-if-nil-else-pop)))) newtag) - + (nth 1 newtag) ) (setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp))) @@ -1700,20 +1956,21 @@ may generate incorrect code.") (setq lap0 (car rest) lap1 (nth 1 rest)) (if (memq (car lap0) byte-constref-ops) - (if (eq (cdr lap0) 'byte-constant) - (or (memq (cdr lap0) byte-compile-variables) - (setq byte-compile-variables (cons (cdr lap0) - byte-compile-variables))) - (or (memq (cdr lap0) byte-compile-constants) + (if (or (eq (car lap0) 'byte-constant) + (eq (car lap0) 'byte-constant2)) + (unless (memq (cdr lap0) byte-compile-constants) (setq byte-compile-constants (cons (cdr lap0) - byte-compile-constants))))) + byte-compile-constants))) + (unless (memq (cdr lap0) byte-compile-variables) + (setq byte-compile-variables (cons (cdr lap0) + byte-compile-variables))))) (cond (;; ;; const-C varset-X const-C --> const-C dup varset-X ;; const-C varbind-X const-C --> const-C dup varbind-X ;; (and (eq (car lap0) 'byte-constant) (eq (car (nth 2 rest)) 'byte-constant) - (eq (cdr lap0) (car (nth 2 rest))) + (eq (cdr lap0) (cdr (nth 2 rest))) (memq (car lap1) '(byte-varbind byte-varset))) (byte-compile-log-lap " %s %s %s\t-->\t%s dup %s" lap0 lap1 lap0 lap0 lap1) @@ -1735,7 +1992,7 @@ may generate incorrect code.") (setq tmp2 t)) (if tmp2 (byte-compile-log-lap - " %s [dup/%s]... %s\t-->\t%s dup..." lap0 lap0 lap0))) + " %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0))) ;; ;; unbind-N unbind-M --> unbind-(N+M) ;; @@ -1752,7 +2009,7 @@ may generate incorrect code.") (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) -(provide 'byte-optimize) +(provide 'byte-opt) ;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles @@ -1763,10 +2020,10 @@ may generate incorrect code.") (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) - (mapcar '(lambda (x) - (or noninteractive (message "compiling %s..." x)) - (byte-compile x) - (or noninteractive (message "compiling %s...done" x))) + (mapcar (lambda (x) + (or noninteractive (message "compiling %s..." x)) + (byte-compile x) + (or noninteractive (message "compiling %s...done" x))) '(byte-optimize-form byte-optimize-body byte-optimize-predicate @@ -1776,4 +2033,5 @@ may generate incorrect code.") byte-optimize-lapcode)))) nil) +;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1 ;;; byte-opt.el ends here