;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler.
-;;; Copyright (c) 1991 Free Software Foundation, Inc.
+;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; 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.
-;;;
+;; ========================================================================
+;; "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 '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)
+;; (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)) -> (progn B A)
+;;;(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 ...)) -> (progn B ... A)
+;;;(disassemble (lambda (x) (car (list (foo) 42 (bar)))))
+
+;;;;; (cdr (list A B ...)) -> (progn A (list B ...))
+;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar)))))
-;;; 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.
;;; 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."))
form)
;; else
(if (and (consp fn) (eq (car fn) 'autoload))
- (load (nth 1 fn)))
+ (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)
(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)))))))
+ (let (string)
+ (fetch-bytecode fn)
+ (setq string (aref fn 1))
+ (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)))
+ (cdr form)))
+ (if (eq (car-safe fn) 'lambda)
+ (cons fn (cdr form))
+ ;; Give up on inlining.
+ form))))))
;;; ((lambda ...) ...)
;;;
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
+ (setq body (mapcar 'byte-optimize-form body))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
(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
(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
+ (setq form (compiler-macroexpand form)))))
+ (byte-optimize-form form for-effect))
((not (symbolp fn))
(or (eq 'mocklisp (car-safe fn)) ; ha!
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))))))
;; (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)
;;; (actually, it would be safe if we know the sole arg
;;; is not a marker).
;; ((null (cdr (cdr form))) (nth 1 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)
;; (- 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))
;;; 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)
(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))
(delq 0 (copy-sequence form)))))
((and (eq (car-safe form) 'logior)
(memq -1 form))
- (delq -1 (copy-sequence form)))
+ (cons 'progn (cdr form)))
(form))))
(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))))
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)))))
(put 'nth 'byte-optimizer 'byte-optimize-nth)
(defun byte-optimize-nth (form)
- (if (memq (nth 1 form) '(0 1))
+ (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))))
(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)
+ (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 (natnump (setq count (1- count)))
+ (while (>= (setq count (1- count)) 0)
(setq form (list 'cdr form)))
form)))
+
+(put 'concat 'byte-optimizer 'byte-optimize-concat)
+(defun byte-optimize-concat (form)
+ (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)))
\f
;;; enumerating those functions which need not be called if the returned
;;; value is not used. That is, something like
;;; I wonder if I missed any :-\)
(let ((side-effect-free-fns
- '(% * + - / /= 1+ 1- < <= = > >= append aref ash assoc assq boundp
- buffer-file-name buffer-local-variables buffer-modified-p
- buffer-substring capitalize car cdr concat coordinates-in-window-p
- copy-marker count-lines documentation downcase elt fboundp featurep
+ '(% * + - / /= 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
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
- format get get-buffer get-buffer-window getenv get-file-buffer length
- logand logior lognot logxor lsh marker-buffer max member memq min mod
- next-window nth nthcdr previous-window rassq regexp-quote reverse
- string< string= string-lessp string-equal substring user-variable-p
- window-buffer window-edges window-height window-hscroll window-width
+ 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
+ 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
+ window-buffer window-dedicated-p window-edges window-height
+ window-hscroll window-minibuffer-p window-width
zerop))
- ;; could also add plusp, minusp, signum. If anyone ever defines
- ;; these, they will certainly be side-effect free.
(side-effect-and-error-free-fns
- '(arrayp atom bobp bolp buffer-end buffer-list buffer-size
- buffer-string bufferp char-or-string-p commandp cons consp
- current-buffer dot dot-marker eobp eolp eq eql equal
- get-largest-window identity integerp integer-or-marker-p
- interactive-p keymapp list listp make-marker mark mark-marker
- markerp minibuffer-window natnump nlistp not null numberp
- one-window-p point point-marker processp selected-window sequencep
- stringp subrp symbolp syntax-table-p vector vectorp windowp)))
+ '(arrayp atom
+ bobp bolp 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
+ get-largest-window get-lru-window
+ identity ignore integerp integer-or-marker-p interactive-p
+ invocation-directory invocation-name
+ keymapp 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
+ user-real-login-name user-real-uid user-uid
+ vector vectorp
+ 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)))
;;; 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)
;; As byte-decompile-bytecode, but updates
;; byte-compile-{constants, variables, tag-number}.
-;; If the optional 3rd arg is true, then `return' opcodes are replaced
+;; If MAKE-SPLICEABLE is true, then `return' opcodes are replaced
;; with `goto's destined for the end of the code.
-(defun byte-decompile-bytecode-1 (bytes constvec &optional make-splicable)
+;; That is for use by the compiler.
+;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
+;; In that case, we put a pc value into the list
+;; 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
lap tmp
endtag
(retcount 0))
(while (not (= ptr length))
+ (or make-spliceable
+ (setq lap (cons ptr lap)))
(setq op (aref bytes ptr)
optr ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
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)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
- ((and make-splicable
+ ((and make-spliceable
(eq op 'byte-return))
(if (= ptr (1- length))
(setq op nil)
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
- (cond ((setq tmp (assq (car (car rest)) tags))
+ (cond ((numberp (car rest)))
+ ((setq tmp (assq (car (car rest)) tags))
;; this addr is jumped to
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(if endtag
(setq lap (cons (cons nil endtag) lap)))
;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
- (mapcar 'cdr (nreverse lap))))
+ (mapcar (function (lambda (elt)
+ (if (numberp elt)
+ elt
+ (cdr elt))))
+ (nreverse lap))))
\f
;;; peephole optimizer
(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?
- "Byte-codes that can be moved past an unbind."))
+ 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
'(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
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.
+;;; This crock is because of the way DEFVAR_BOOL variables work.
;;; Consider the code
;;;
;;; (defun foo (flag)
;;; 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 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)
+ '(abbrev-all-caps abbrevs-changed byte-debug-flag byte-metering-on
+ cannot-suspend check-markers-debug-flag completion-auto-help
+ completion-ignore-case cursor-in-echo-area debug-on-next-call
+ debug-on-quit delete-exited-processes enable-recursive-minibuffers
+ garbage-collection-messages highlight-nonselected-windows
+ indent-tabs-mode inherit-process-coding-system inhibit-eol-conversion
+ inhibit-local-menu-bar-menus insert-default-directory inverse-video
+ keyword-symbols-constant-flag load-convert-to-unibyte
+ load-force-doc-strings load-in-progress menu-prompting
+ minibuffer-allow-text-properties minibuffer-auto-raise
+ mode-line-inverse-video multiple-frames no-redraw-on-reenter
+ noninteractive parse-sexp-ignore-comments parse-sexp-lookup-properties
+ pop-up-frames pop-up-windows print-escape-multibyte
+ print-escape-newlines
+ print-escape-nonascii print-quoted scroll-preserve-screen-position
+ system-uses-terminfo truncate-partial-width-windows use-dialog-box
+ 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.")
(if opt-p
(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
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (eq (cdr lap0) 'byte-constant)
+ (if (not (eq (car lap0) 'byte-constant))
(or (memq (cdr lap0) byte-compile-variables)
(setq byte-compile-variables (cons (cdr lap0)
byte-compile-variables)))
(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)
;;