-;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler.
+;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler.
;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
-;; Author: Jamie Zawinski <jwz@netscape.com>
-;; Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Authors: Jamie Zawinski <jwz@jwz.org>
+;; Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Martin Buchholz <martin@xemacs.org>
;; Keywords: internal
;; This file is part of XEmacs.
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with XEmacs; see the file COPYING. If not, write to the
+;; along with XEmacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-;;; Synched up with: FSF 19.30.
+;;; Synched up with: FSF 20.7.
;;; Commentary:
;; 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
;; 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.)
;;
;; HA! RMS removed the following paragraph from his version of
-;; byte-opt.el.
+;; byte-optimize.el.
;;
;; 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 board, in the interpreter and compiler, and just FIX all of
;; the code that relies on dynamic scope of non-defvarred variables.
;; Other things to consider:
;; Associative math should recognize subcalls to identical function:
-;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2))))
+;;(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))))
+;;(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
+;;(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
;; 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)))))
+;;(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)))))
+;;(disassemble #'(lambda (x) (cdr (list 42 (foo) (bar)))))
;;; Code:
(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)
- (if (not (consp arg))
- (if (and (symbolp arg)
- (string-match "^byte-" (symbol-name arg)))
- (intern (substring (symbol-name arg) 5))
- arg)
- (if (integerp (setq c (car arg)))
- (error "non-symbolic byte-op %s" c))
- (if (eq c 'TAG)
- (setq c arg)
- (setq a (cond ((memq c byte-goto-ops)
- (car (cdr (cdr arg))))
- ((memq c byte-constref-ops)
- (car (cdr arg)))
- (t (cdr arg))))
- (setq c (symbol-name c))
- (if (string-match "^byte-." c)
- (setq c (intern (substring c 5)))))
- (if (eq c 'constant) (setq c 'const))
- (if (and (eq (cdr arg) 0)
- (not (memq c '(unbind call const))))
- c
- (format "(%s %s)" c a))))
- args)))))
+ (let (c a)
+ (mapcar
+ #'(lambda (arg)
+ (if (not (consp arg))
+ (if (and (symbolp arg)
+ (string-match "^byte-" (symbol-name arg)))
+ (intern (substring (symbol-name arg) 5))
+ arg)
+ (if (integerp (setq c (car arg)))
+ (error "non-symbolic byte-op %s" c))
+ (if (eq c 'TAG)
+ (setq c arg)
+ (setq a (cond ((memq c byte-goto-ops)
+ (car (cdr (cdr arg))))
+ ((memq c byte-constref-ops)
+ (car (cdr arg)))
+ (t (cdr arg))))
+ (setq c (symbol-name c))
+ (if (string-match "^byte-." c)
+ (setq c (intern (substring c 5)))))
+ (if (eq c 'constant) (setq c 'const))
+ (if (and (eq (cdr arg) 0)
+ (not (memq c '(unbind call const))))
+ c
+ (format "(%s %s)" c a))))
+ args)))))
(defmacro byte-compile-log-lap (format-string &rest args)
(list 'and
(defun byte-optimize-inline-handler (form)
"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)))
- (cdr 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)))
+ (cdr form))))
;; Splice the given lap code into the current instruction stream.
(cons fn (cdr form)))))))
;;; ((lambda ...) ...)
-;;;
+;;;
(defun byte-compile-unfold-lambda (form &optional name)
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
- (let ((newform
+ (let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
(cons 'progn body))))
;; are more deeply nested are optimized first.
(cons fn
(cons
- (mapcar '(lambda (binding)
- (if (symbolp binding)
- binding
- (if (cdr (cdr binding))
- (byte-compile-warn "malformed let binding: %s"
- (prin1-to-string binding)))
- (list (car binding)
- (byte-optimize-form (nth 1 binding) nil))))
- (nth 1 form))
+ (mapcar
+ #'(lambda (binding)
+ (if (symbolp binding)
+ binding
+ (if (cdr (cdr binding))
+ (byte-compile-warn "malformed let binding: %s"
+ (prin1-to-string binding)))
+ (list (car binding)
+ (byte-optimize-form (nth 1 binding) nil))))
+ (nth 1 form))
(byte-optimize-body (cdr (cdr form)) for-effect))))
((eq fn 'cond)
(cons fn
- (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"
- (prin1-to-string clause))
- clause))
- (cdr form))))
+ (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"
+ (prin1-to-string clause))
+ clause))
+ (cdr form))))
((eq fn 'progn)
;; as an extra added bonus, this simplifies (progn <x>) --> <x>
(if (cdr (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)
(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
(if (and (cdr form) (null backwards))
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
- (and backwards
- (cons fn (nreverse backwards))))
+ (when backwards
+ ;; Now optimize the rest of the forms. We need the return
+ ;; values. We already did the car.
+ (setcdr backwards
+ (mapcar 'byte-optimize-form (cdr backwards))))
+ (cons fn (nreverse backwards)))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
(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
(setq form (macroexpand form
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
-
+
((not (symbolp fn))
(or (eq 'mocklisp (car-safe fn)) ; ha!
(byte-compile-warn "%s is a malformed function"
;; 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
;; First, optimize all sub-forms of this one.
(setq form (byte-optimize-form-code-walker form for-effect))
;;
- ;; after optimizing all subforms, optimize this form until it doesn't
+ ;; After optimizing all subforms, optimize this form until it doesn't
;; optimize any further. This means that some forms will be passed through
;; the optimizer many times, but that's necessary to make the for-effect
;; processing do as much as possible.
(progn
;; (if (equal form new) (error "bogus optimizer -- %s" opt))
(byte-compile-log " %s\t==>\t%s" form new)
- (setq new (byte-optimize-form new for-effect))
- new)
+ (byte-optimize-form new for-effect))
form)))
(defun byte-optimize-body (forms all-for-effect)
- ;; optimize the cdr of a progn or implicit progn; all forms is a list of
+ ;; Optimize the cdr of a progn or implicit progn; `forms' is a list of
;; forms, all but the last of which are optimized with the assumption that
- ;; they are being called for effect. the last is for-effect as well if
- ;; all-for-effect is true. returns a new list of forms.
+ ;; they are being called for effect. The last is for-effect as well if
+ ;; all-for-effect is true. Returns a new list of forms.
(let ((rest forms)
(result nil)
fe new)
;; 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)
(list (apply fun (nreverse constants)))))))))
form))
-(defun byte-optimize-plus (form)
- (setq form (byte-optimize-delay-constants-math form 1 '+))
- (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
- ;;(setq form (byte-optimize-associative-two-args-math form))
- (cond ((null (cdr form))
- (condition-case ()
- (eval form)
- (error form)))
-
- ;; `add1' and `sub1' are a marginally fewer instructions
- ;; than `plus' and `minus', so use them when possible.
- ((and (null (nthcdr 3 form))
- (eq (nth 2 form) 1))
- (list '1+ (nth 1 form))) ; (+ x 1) --> (1+ x)
- ((and (null (nthcdr 3 form))
- (eq (nth 1 form) 1))
- (list '1+ (nth 2 form))) ; (+ 1 x) --> (1+ x)
- ((and (null (nthcdr 3 form))
- (eq (nth 2 form) -1))
- (list '1- (nth 1 form))) ; (+ x -1) --> (1- x)
- ((and (null (nthcdr 3 form))
- (eq (nth 1 form) -1))
- (list '1- (nth 2 form))) ; (+ -1 x) --> (1- x)
-
-;;; 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))
- (t form)))
+;;; It is not safe to optimize calls to arithmetic ops with one arg
+;;; away entirely (actually, it would be safe if we know the sole arg
+;;; is not a marker or if it appears in other arithmetic).
-(defun byte-optimize-minus (form)
- ;; Put constants at the end, except the last constant.
- (setq form (byte-optimize-delay-constants-math form 2 '+))
- ;; Now only first and last element can be a number.
- (let ((last (car (reverse (nthcdr 3 form)))))
- (cond ((eq 0 last)
- ;; (- x y ... 0) --> (- x y ...)
- (setq form (copy-sequence form))
- (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 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))))))))
- (setq 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).
-;;; (if (eq (nth 2 form) 0)
-;;; (nth 1 form) ; (- x 0) --> x
- (byte-optimize-predicate
- (if (and (null (cdr (cdr (cdr form))))
- (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
- (cons (car form) (cdr (cdr form)))
- form))
-;;; )
- )
-
- ;; `add1' and `sub1' are a marginally fewer instructions than `plus'
- ;; and `minus', so use them when possible.
- (cond ((and (null (nthcdr 3 form))
- (eq (nth 2 form) 1))
- (list '1- (nth 1 form))) ; (- x 1) --> (1- x)
- ((and (null (nthcdr 3 form))
- (eq (nth 2 form) -1))
- (list '1+ (nth 1 form))) ; (- x -1) --> (1+ x)
- (t
- form))
- )
+;;; But this degree of paranoia is normally unjustified, so optimize unless
+;;; the user has done (declaim (safety 3)). Implemented in bytecomp.el.
+
+(defun byte-optimize-plus (form)
+ (byte-optimize-predicate (byte-optimize-delay-constants-math form 1 '+)))
(defun byte-optimize-multiply (form)
(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).
-;;; ((null (cdr (cdr form))) (nth 1 form))
- ((let ((last (car (reverse 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)
- (memq t (mapcar 'symbolp (cdr form))))
- (prog1 (setq form (delq 2 (copy-sequence form)))
- (while (not (symbolp (car (setq form (cdr form))))))
- (setcar form (list '+ (car form) (car form)))))
- (form))))))
-
-(defsubst byte-compile-butlast (form)
- (nreverse (cdr (reverse form))))
+ ;; If there is a constant integer in FORM, it is now the last element.
+
+ (case (car (last form))
+ ;; (* x y 0) --> (progn x y 0)
+ (0 (cons 'progn (cdr form)))
+ (t (byte-optimize-predicate form))))
+
+(defun byte-optimize-minus (form)
+ ;; Put constants at the end, except the first arg.
+ (setq form (byte-optimize-delay-constants-math form 2 '+))
+ ;; Now only the first and last args can be integers.
+ (let ((last (car (last (nthcdr 3 form)))))
+ (cond
+ ;; If form is (- CONST foo... CONST), merge first and last.
+ ((and (numberp (nth 1 form)) (numberp last))
+ (decf (nth 1 form) last)
+ (butlast form))
+
+ ;; (- 0 ...) -->
+ ((eq 0 (nth 1 form))
+ (case (length form)
+ ;; (- 0) --> 0
+ (2 0)
+ ;; (- 0 x) --> (- x)
+ (3 `(- ,(nth 2 form)))
+ ;; (- 0 x y ...) --> (- (- x) y ...)
+ (t `(- (- ,(nth 2 form)) ,@(nthcdr 3 form)))))
+
+ (t (byte-optimize-predicate form)))))
(defun byte-optimize-divide (form)
+ ;; Put constants at the end, except the first arg.
(setq form (byte-optimize-delay-constants-math form 2 '*))
- (let ((last (car (reverse (cdr (cdr form))))))
- (if (numberp last)
- (cond ((= (length form) 3)
- (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))
- (setq form (cons (car form)
- (cons (/ (nth 1 form) last)
- (byte-compile-butlast (cdr (cdr form)))))
- last nil))))
- (cond
-;;; ((null (cdr (cdr form)))
-;;; (nth 1 form))
- ((eq (nth 1 form) 0)
- (append '(progn) (cdr (cdr form)) '(0)))
- ((eq last -1)
- (list '- (if (nthcdr 3 form)
- (byte-compile-butlast form)
- (nth 1 form))))
- (form))))
+ ;; Now only the first and last args can be integers.
+ (let ((last (car (last (nthcdr 3 form)))))
+ (cond
+ ;; If form is (/ CONST foo... CONST), merge first and last.
+ ((and (numberp (nth 1 form)) (numberp last))
+ (condition-case nil
+ (cons (nth 0 form)
+ (cons (/ (nth 1 form) last)
+ (butlast (cdr (cdr form)))))
+ (error form)))
+
+ ;; (/ 0 x y) --> (progn x y 0)
+ ((eq (nth 1 form) 0)
+ (append '(progn) (cdr (cdr form)) '(0)))
+
+ ;; We don't have to check for divide-by-zero because `/' does.
+ (t (byte-optimize-predicate form)))))
(defun byte-optimize-logmumble (form)
(setq form (byte-optimize-delay-constants-math form 1 (car form)))
(setq ok (byte-compile-constp (car rest))
rest (cdr rest)))
(if ok
- (condition-case ()
+ (condition-case err
(list 'quote (eval form))
- (error form))
+ (error
+ (byte-compile-warn "evaluating %s: %s" form err)
+ form))
form)))
(defun byte-optimize-identity (form)
(if (= 1 (length (cdr form))) "" "s"))
form))
+(defun byte-optimize-car (form)
+ (let ((arg (cadr form)))
+ (cond
+ ((and (byte-compile-trueconstp arg)
+ (not (and (consp arg)
+ (eq (car arg) 'quote)
+ (listp (cadr arg)))))
+ (byte-compile-warn
+ "taking car of a constant: %s" arg)
+ form)
+ ((and (eq (car-safe arg) 'cons)
+ (eq (length arg) 3))
+ `(prog1 ,(nth 1 arg) ,(nth 2 arg)))
+ ((eq (car-safe arg) 'list)
+ `(prog1 ,@(cdr arg)))
+ (t
+ (byte-optimize-predicate form)))))
+
+(defun byte-optimize-cdr (form)
+ (let ((arg (cadr form)))
+ (cond
+ ((and (byte-compile-trueconstp arg)
+ (not (and (consp arg)
+ (eq (car arg) 'quote)
+ (listp (cadr arg)))))
+ (byte-compile-warn
+ "taking cdr of a constant: %s" arg)
+ form)
+ ((and (eq (car-safe arg) 'cons)
+ (eq (length arg) 3))
+ `(progn ,(nth 1 arg) ,(nth 2 arg)))
+ ((eq (car-safe arg) 'list)
+ (if (> (length arg) 2)
+ `(progn ,(cadr arg) (list ,@(cddr arg)))
+ (cadr arg)))
+ (t
+ (byte-optimize-predicate form)))))
+
(put 'identity 'byte-optimizer 'byte-optimize-identity)
(put '+ 'byte-optimizer 'byte-optimize-plus)
(put '* 'byte-optimizer 'byte-optimize-multiply)
(put '- 'byte-optimizer 'byte-optimize-minus)
(put '/ 'byte-optimizer 'byte-optimize-divide)
+(put '% 'byte-optimizer 'byte-optimize-predicate)
(put 'max 'byte-optimizer 'byte-optimize-associative-math)
(put 'min 'byte-optimizer 'byte-optimize-associative-math)
(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
(put 'string< 'byte-optimizer 'byte-optimize-predicate)
(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
+(put 'length 'byte-optimizer 'byte-optimize-predicate)
(put 'logand 'byte-optimizer 'byte-optimize-logmumble)
(put 'logior 'byte-optimizer 'byte-optimize-logmumble)
(put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
(put 'lognot 'byte-optimizer 'byte-optimize-predicate)
-(put 'car 'byte-optimizer 'byte-optimize-predicate)
-(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
+(put 'car 'byte-optimizer 'byte-optimize-car)
+(put 'cdr 'byte-optimizer 'byte-optimize-cdr)
(put 'car-safe 'byte-optimizer 'byte-optimize-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,
+;; I think this may some times be necessary to reduce eg. (quote 5) to 5,
;; so arithmetic optimizers recognize the numeric constant. - Hallvard
(put 'quote 'byte-optimizer 'byte-optimize-quote)
(defun byte-optimize-quote (form)
(byte-optimize-predicate form)
(nth 1 form))))
+;;; For the byte optimizer, `cond' is just overly sweet syntactic sugar.
+;;; So we rewrite (cond ...) in terms of `if' and `or',
+;;; which are easier to optimize.
(defun byte-optimize-cond (form)
- ;; if any clauses have a literal nil as their test, throw them away.
- ;; if any clause has a literal non-nil constant as its test, throw
- ;; away all following clauses.
- (let (rest)
- ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
- (while (setq rest (assq nil (cdr form)))
- (setq form (delq rest (copy-sequence form))))
- (if (memq nil (cdr form))
- (setq form (delq nil (copy-sequence form))))
- (setq rest form)
- (while (setq rest (cdr rest))
- (cond ((byte-compile-trueconstp (car-safe (car rest)))
- (cond ((eq rest (cdr form))
- (setq form
- (if (cdr (car rest))
- (if (cdr (cdr (car rest)))
- (cons 'progn (cdr (car rest)))
- (nth 1 (car rest)))
- (car (car rest)))))
- ((cdr rest)
- (setq form (copy-sequence form))
- (setcdr (memq (car rest) form) nil)))
- (setq rest nil)))))
- ;;
- ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
- (if (eq 'cond (car-safe form))
- (let ((clauses (cdr form)))
- (if (and (consp (car clauses))
- (null (cdr (car clauses))))
- (list 'or (car (car clauses))
- (byte-optimize-cond
- (cons (car form) (cdr (cdr form)))))
- form))
- form))
+ (byte-optimize-cond-1 (cdr form)))
+
+(defun byte-optimize-cond-1 (clauses)
+ (cond
+ ((null clauses) nil)
+ ((consp (car clauses))
+ (nconc
+ (case (length (car clauses))
+ (1 `(or ,(nth 0 (car clauses))))
+ (2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
+ (t `(if ,(nth 0 (car clauses)) (progn ,@(cdr (car clauses))))))
+ (when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
+ (t (error "malformed cond clause %s" (car clauses)))))
(defun byte-optimize-if (form)
;; (if <true-constant> <then> <else...>) ==> <then>
(put 'if 'byte-optimizer 'byte-optimize-if)
(put 'while 'byte-optimizer 'byte-optimize-while)
+;; The supply of bytecodes is small and constrained by backward compatibility.
+;; Several functions have byte-coded versions and hence are very efficient.
+;; Related functions which can be expressed in terms of the byte-coded
+;; ones should be transformed into bytecoded calls for efficiency.
+;; This is especially the case for functions with a backward- and
+;; forward- version, but with a bytecode only for the forward one.
+
+;; Some programmers have hand-optimized calls like (backward-char)
+;; into the call (forward-char -1).
+;; But it's so much nicer for the byte-compiler to do this automatically!
+
+;; (char-before) ==> (char-after (1- (point)))
+(put 'char-before 'byte-optimizer 'byte-optimize-char-before)
+(defun byte-optimize-char-before (form)
+ `(char-after
+ ,(cond
+ ((null (nth 1 form))
+ '(1- (point)))
+ ((equal '(point) (nth 1 form))
+ '(1- (point)))
+ (t `(1- (or ,(nth 1 form) (point)))))
+ ,@(cdr (cdr form))))
+
+;; (backward-char n) ==> (forward-char (- n))
+(put 'backward-char 'byte-optimizer 'byte-optimize-backward-char)
+(defun byte-optimize-backward-char (form)
+ `(forward-char
+ ,(typecase (nth 1 form)
+ (null -1)
+ (integer (- (nth 1 form)))
+ (t `(- (or ,(nth 1 form) 1))))
+ ,@(cdr (cdr form))))
+
+;; (backward-word n) ==> (forward-word (- n))
+(put 'backward-word 'byte-optimizer 'byte-optimize-backward-word)
+(defun byte-optimize-backward-word (form)
+ `(forward-word
+ ,(typecase (nth 1 form)
+ (null -1)
+ (integer (- (nth 1 form)))
+ (t `(- (or ,(nth 1 form) 1))))
+ ,@(cdr (cdr form))))
+
+;; The following would be a valid optimization of the above kind, but
+;; the gain in performance is very small, since the saved funcall is
+;; counterbalanced by the necessity of adding a bytecode for (point).
+;;
+;; Also, users are more likely to have modified the behavior of
+;; delete-char via advice or some similar mechanism. This is much
+;; less of a problem for the previous functions because it wouldn't
+;; make sense to modify the behaviour of `backward-char' without also
+;; modifying `forward-char', for example.
+
+;; (delete-char n) ==> (delete-region (point) (+ (point) n))
+;; (put 'delete-char 'byte-optimizer 'byte-optimize-delete-char)
+;; (defun byte-optimize-delete-char (form)
+;; (case (length (cdr form))
+;; (0 `(delete-region (point) (1+ (point))))
+;; (1 `(delete-region (point) (+ (point) ,(nth 1 form))))
+;; (t form)))
+
;; byte-compile-negation-optimizer lives in bytecomp.el
;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
-
(defun byte-optimize-funcall (form)
;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
;; (funcall 'foo ...) ==> (foo ...)
(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"
(prin1-to-string last))
(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
+;;; 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))
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
+ ;; hash-table functions
+ make-hash-table copy-hash-table
+ gethash
+ hash-table-count
+ hash-table-rehash-size
+ hash-table-rehash-threshold
+ hash-table-size
+ hash-table-test
+ hash-table-type
+ ;;
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
+ parse-colon-path plist-get 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
;; XEmacs change: window-edges -> window-pixel-edges
window-buffer window-dedicated-p window-pixel-edges window-height
window-hscroll window-minibuffer-p window-width
- zerop))
+ zerop
+ ;; functions defined by cl
+ oddp evenp plusp minusp
+ abs expt signum last butlast ldiff
+ pairlis gcd lcm
+ isqrt floor* ceiling* truncate* round* mod* rem* subseq
+ list-length getf
+ ))
(side-effect-and-error-free-fns
'(arrayp atom
bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp
dot dot-marker eobp eolp eq eql equal eventp extentp
extent-live-p floatp framep frame-live-p
get-largest-window get-lru-window
+ hash-table-p
identity ignore integerp integer-or-marker-p interactive-p
invocation-directory invocation-name
- ;; keymapp may autoload in XEmacs, so not on this list!
- list listp
+ keymapp list listp
make-marker mark mark-marker markerp memory-limit minibuffer-window
;; mouse-movement-p not in XEmacs
natnump nlistp not null number-or-marker-p numberp
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)))
- (while side-effect-and-error-free-fns
- (put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
- (setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
- nil)
+ window-configuration-p window-live-p windowp
+ ;; Functions defined by cl
+ eql floatp-safe list* subst acons equalp random-state-p
+ copy-tree sublis
+ )))
+ (dolist (fn side-effect-free-fns)
+ (put fn 'side-effect-free t))
+ (dolist (fn side-effect-and-error-free-fns)
+ (put fn 'side-effect-free 'error-free)))
(defun byte-compile-splice-in-already-compiled-code (form)
;; form is (byte-code "..." [...] n)
- (if (not (memq byte-optimize '(t lap)))
+ (if (not (memq byte-optimize '(t byte)))
(byte-compile-normal-call form)
(byte-inline-lapcode
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
;; fetch and return the offset for the current opcode.
;; return NIL if this opcode has no offset
;; OP, PTR and BYTES are used and set dynamically
- (defvar op)
- (defvar ptr)
- (defvar bytes)
+ (declare (special op ptr bytes))
(cond ((< op byte-nth)
(let ((tem (logand op 7)))
(setq op (logand op 248))
(if endtag
(setq lap (cons (cons nil endtag) lap)))
;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
- (mapcar (function (lambda (elt)
- (if (numberp elt)
- elt
- (cdr elt))))
+ (mapcar #'(lambda (elt) (if (numberp elt) elt (cdr elt)))
(nreverse lap))))
\f
(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
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
;;; varbind pop-up-windows
;;; not
;;;
-;;; we break the program, because it will appear that pop-up-windows and
+;;; 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.
;;;
(defun byte-optimize-lapcode (lap &optional for-effect)
"Simple peephole optimizer. LAP is both modified and returned."
- (let (lap0 ;; off0 unused
- lap1 ;; off1
- lap2 ;; off2
+ (let (lap0
+ lap1
+ lap2
+ variable-frequency
(keep-going 'first-time)
(add-depth 0)
rest tmp tmp2 tmp3
;; 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)))
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
- ;; need to do more than once.
+ ;; need to do more than once.
(setq byte-compile-constants nil
- byte-compile-variables nil)
+ byte-compile-variables nil
+ variable-frequency (make-hash-table :test 'eq))
(setq rest lap)
(while rest
(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)
- (setq byte-compile-constants (cons (cdr lap0)
- byte-compile-constants)))))
+ (case (car lap0)
+ ((byte-varref byte-varset byte-varbind)
+ (incf (gethash (cdr lap0) variable-frequency 0))
+ (unless (memq (cdr lap0) byte-compile-variables)
+ (push (cdr lap0) byte-compile-variables)))
+ ((byte-constant)
+ (unless (memq (cdr lap0) byte-compile-constants)
+ (push (cdr lap0) byte-compile-constants))))
(cond (;;
- ;; const-C varset-X const-C --> const-C dup varset-X
+ ;; 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)
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
(setq rest (cdr rest)))
+ ;; Since the first 6 entries of the compiled-function constants
+ ;; vector are most efficient for varref/set/bind ops, we sort by
+ ;; reference count. This generates maximally space efficient and
+ ;; pretty time-efficient byte-code. See `byte-compile-constants-vector'.
+ (setq byte-compile-variables
+ (sort byte-compile-variables
+ #'(lambda (v1 v2)
+ (< (gethash v1 variable-frequency)
+ (gethash v2 variable-frequency)))))
+ ;; Another hack - put the most used variable in position 6, for
+ ;; better locality of reference with adjoining constants.
+ (let ((tail (last byte-compile-variables 6)))
+ (setq byte-compile-variables
+ (append (nbutlast byte-compile-variables 6)
+ (nreverse tail))))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
(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)))
- '(byte-optimize-form
- byte-optimize-body
- byte-optimize-predicate
- byte-optimize-binary-predicate
- ;; Inserted some more than necessary, to speed it up.
- byte-optimize-form-code-walker
- byte-optimize-lapcode))))
+ (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-binary-predicate
+ ;; Inserted some more than necessary, to speed it up.
+ byte-optimize-form-code-walker
+ byte-optimize-lapcode))))
nil)
;;; byte-optimize.el ends here
projects / chise / xemacs-chise.git.1 / blobdiff