-;;; 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, 2003, 2004,
+;; 2005, 2006 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Maintainer: FSF
;; Keywords: internal
;; This file is part of GNU Emacs.
;; 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, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
-;;; This file has been censored by the Communications Decency Act.
-;;; That law was passed under the guise of a ban on pornography, but
-;;; it bans far more than that. This file did not contain pornography,
-;;; but it was censored nonetheless.
-
-;;; For information on US government censorship of the Internet, and
-;;; what you can do to bring back freedom of the press, see the web
-;;; site http://www.vtw.org/
-
;; ========================================================================
;; "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
+;; 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))
+;; (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
;; (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 'mocklisp-arguments 'binding-is-magic t)
;; (put 'inhibit-quit 'binding-is-magic t)
;; (put 'quit-flag 'binding-is-magic t)
;; (put 't 'binding-is-magic t)
;; Simple defsubsts often produce forms like
;; (let ((v1 (f1)) (v2 (f2)) ...)
;; (FN v1 v2 ...))
-;; It would be nice if we could optimize this to
+;; 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
+;; 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
+;; 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
;;
;; 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
+;; 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))
;;
;; 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
+;; 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
;; 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).
+;; 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
+;; 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)
+;; ;; 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) (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) (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))))
+;; (disassemble (lambda (x) (eq (if (point) 'a 'b) 'c)))
+;; (disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
-;;;;; (car (cons A B)) -> (progn B A)
-;;;(disassemble (lambda (x) (car (cons (foo) 42))))
+;; ;; (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)))))
+;; ;; (cdr (cons A B)) -> (progn A B)
+;; (disassemble (lambda (x) (cdr (cons 42 (foo)))))
-;;;;; (car (list A B ...)) -> (progn B ... A)
-;;;(disassemble (lambda (x) (car (list (foo) 42 (bar)))))
+;; ;; (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)))))
+;; ;; (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)))
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)))
\f
;;; byte-compile optimizers to support inlining
"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))))
(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))
- (progn
- (load (nth 1 fn))
- (setq fn (or (cdr (assq name byte-compile-function-environment))
- (and (fboundp name) (symbol-function name))))))
- (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)
(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 (list 'lambda (aref fn 0)
- (list 'byte-code string (aref fn 2) (aref fn 3)))
+ (cons `(lambda ,(aref fn 0)
+ (byte-code ,string ,(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)))))))
+ (if (eq (car-safe fn) 'lambda)
+ (cons fn (cdr form))
+ ;; Give up on inlining.
+ form))))))
-;;; ((lambda ...) ...)
-;;;
+;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
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))
(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)
- (setq body (mapcar 'byte-optimize-form body))
- (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))))
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).
;; 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))))
(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))))
(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 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
(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
(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
(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
(symbolp (car-safe form))
(get (car-safe form) 'cl-compiler-macro)
(not (eq form
- (setq form (compiler-macroexpand 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 "value returned by `%s' is not used"
+ (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
(nreverse result)))
\f
-;;; 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)
(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))))
(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
(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) (cons 'progn (cdr form)))
(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)
(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)
(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
(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)))
(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))
(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)))
(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)))
(put 'nth 'byte-optimizer 'byte-optimize-nth)
(defun byte-optimize-nth (form)
- (if (and (= (safe-length form) 3) (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)
- (if (and (= (safe-length form) 3) (not (memq (nth 1 form) '(0 1 2))))
- (byte-optimize-predicate form)
- (let ((count (nth 1 form)))
- (setq form (nth 2 form))
- (while (>= (setq count (1- count)) 0)
- (setq form (list 'cdr form)))
- 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-concat)
-(defun byte-optimize-concat (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)
+(put 'string-to-syntax '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 signaling the error at compile-time."
(let ((args (cdr form))
(constant t))
(while (and args constant)
(setq constant nil))
(setq args (cdr args)))
(if constant
- (eval form)
+ (list 'quote (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))))
\f
-;;; 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)))
(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)
(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)
;; 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)))
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)
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
byte-member byte-assq byte-quo byte-rem)
byte-compile-side-effect-and-error-free-ops))
-;;; 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.
-;;;
-(defconst byte-boolean-vars
- '(abbrev-all-caps abbrevs-changed byte-metering-on
- cannot-suspend completion-auto-help completion-ignore-case
- cursor-in-echo-area debug-on-next-call debug-on-quit
- delete-exited-processes enable-recursive-minibuffers
- highlight-nonselected-windows indent-tabs-mode inhibit-local-menu-bar-menus
- insert-default-directory inverse-video load-force-doc-strings
- load-in-progress menu-prompting minibuffer-auto-raise
- mode-line-inverse-video multiple-frames no-redraw-on-reenter noninteractive
- parse-sexp-ignore-comments pop-up-frames pop-up-windows
- print-escape-newlines system-uses-terminfo truncate-partial-width-windows
- visible-bell vms-stmlf-recfm words-include-escapes)
- "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
(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"
;; 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
str (concat str " %s")
i (1+ i))))
(if opt-p
- (let ((tagstr
+ (let ((tagstr
(if (eq 'TAG (car (car tmp)))
(format "%d:" (car (cdr (car tmp))))
(or (car tmp) ""))))
(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)))
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (not (eq (car 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)
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
-(provide 'byte-optimize)
+(provide 'byte-opt)
\f
;; To avoid "lisp nesting exceeds max-lisp-eval-depth" when this file compiles
(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
byte-optimize-lapcode))))
nil)
+;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1
;;; byte-opt.el ends here