diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 343 |
1 files changed, 237 insertions, 106 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index a7edecfac73..bbe8135f04a 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -722,35 +722,83 @@ for speeding up processing.") ;; 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. -(defsubst byte-compile-trueconstp (form) +(defsubst byte-opt--bool-value-form (form) + "The form in FORM that yields its boolean value, possibly FORM itself." + (while (let ((head (car-safe form))) + (cond ((memq head '( progn inline save-excursion save-restriction + save-current-buffer)) + (setq form (car (last form))) + t) + ((memq head '(let let* setq setcar setcdr)) + (setq form (car (last (cddr form)))) + t) + ((memq head '( prog1 unwind-protect copy-sequence identity + reverse nreverse sort)) + (setq form (nth 1 form)) + t) + ((eq head 'mapc) + (setq form (nth 2 form)) + t)))) + form) + +(defun byte-compile-trueconstp (form) "Return non-nil if FORM always evaluates to a non-nil value." - (while (eq (car-safe form) 'progn) - (setq form (car (last (cdr form))))) + (setq form (byte-opt--bool-value-form form)) (cond ((consp form) - (pcase (car form) - ('quote (cadr form)) - ;; Can't use recursion in a defsubst. - ;; (`progn (byte-compile-trueconstp (car (last (cdr form))))) - )) + (let ((head (car form))) + ;; FIXME: Lots of other expressions are statically non-nil. + (cond ((memq head '(quote function)) (cadr form)) + ((eq head 'list) (cdr form)) + ((memq head + ;; FIXME: Replace this list with a function property? + '( length safe-length cons lambda + string make-string format concat + substring substring-no-properties string-replace + replace-regexp-in-string symbol-name make-symbol + mapconcat + vector make-vector vconcat make-record record + regexp-quote regexp-opt + buffer-string buffer-substring + buffer-substring-no-properties + current-buffer buffer-size + point point-min point-max + following-char preceding-char max-char + + - * / % 1+ 1- min max abs + logand logior lorxor lognot ash + number-to-string string-to-number + int-to-string char-to-string prin1-to-string + byte-to-string string-to-vector string-to-char + always)) + t) + ((eq head 'if) + (and (byte-compile-trueconstp (nth 2 form)) + (byte-compile-trueconstp (car (last (cdddr form)))))) + ((memq head '(not null)) + (byte-compile-nilconstp (cadr form))) + ((eq head 'or) + (and (cdr form) + (byte-compile-trueconstp (car (last (cdr form))))))))) ((not (symbolp form))) ((eq form t)) ((keywordp form)))) -(defsubst byte-compile-nilconstp (form) +(defun byte-compile-nilconstp (form) "Return non-nil if FORM always evaluates to a nil value." - (while (eq (car-safe form) 'progn) - (setq form (car (last (cdr form))))) - (cond ((consp form) - (pcase (car form) - ('quote (null (cadr form))) - ;; Can't use recursion in a defsubst. - ;; (`progn (byte-compile-nilconstp (car (last (cdr form))))) - )) - ((not (symbolp form)) nil) - ((null form)))) + (setq form (byte-opt--bool-value-form form)) + (or (not form) ; assume (quote nil) always being normalised to nil + (and (consp form) + (let ((head (car form))) + ;; FIXME: There are many other expressions that are statically nil. + (cond ((memq head '(while ignore)) t) + ((eq head 'if) + (and (byte-compile-nilconstp (nth 2 form)) + (byte-compile-nilconstp (car (last (cdddr form)))))) + ((memq head '(not null)) + (byte-compile-trueconstp (cadr form))) + ((eq head 'and) + (and (cdr form) + (byte-compile-nilconstp (car (last (cdr form))))))))))) ;; If the function is being called with constant integer args, ;; evaluate as much as possible at compile-time. This optimizer @@ -1077,35 +1125,91 @@ See Info node `(elisp) Integer Basics'." (nth 1 form))) (defun byte-optimize-and (form) - ;; Simplify if less than 2 args. - ;; if there is a literal nil in the args to `and', throw it and following - ;; forms away, and surround the `and' with (progn ... nil). - (cond ((null (cdr form))) - ((memq nil form) - (list 'progn - (byte-optimize-and - (prog1 (setq form (copy-sequence form)) - (while (nth 1 form) - (setq form (cdr form))) - (setcdr form nil))) - nil)) - ((null (cdr (cdr form))) - (nth 1 form)) - ((byte-optimize-constant-args form)))) + (let ((seq nil) + (new-args nil) + (nil-result nil) + (args (cdr form))) + (while + (and args + (let ((arg (car args))) + (cond + (seq ; previous arg was always-true + (push arg seq) + (unless (and (cdr args) (byte-compile-trueconstp arg)) + (push `(progn . ,(nreverse seq)) new-args) + (setq seq nil)) + t) + ((and (cdr args) (byte-compile-trueconstp arg)) + ;; Always-true arg: evaluate unconditionally. + (push arg seq) + t) + ((and arg (not (byte-compile-nilconstp arg))) + (push arg new-args) + t) + (t + ;; Throw away the remaining args; this one is always false. + (setq nil-result t) + (when arg + (push arg new-args)) ; keep possible side-effects + nil)))) + (setq args (cdr args))) + + (setq new-args (nreverse new-args)) + (if (equal new-args (cdr form)) + ;; Input is unchanged: keep original form, and don't represent + ;; a nil result explicitly because that would lead to infinite + ;; growth when the optimiser is iterated. + (setq nil-result nil) + (setq form (cons (car form) new-args))) + + (let ((new-form + (pcase form + ;; (and (progn ... X) ...) -> (progn ... (and X ...)) + (`(,head (progn . ,forms) . ,rest) + `(progn ,@(butlast forms) (,head ,(car (last forms)) . ,rest))) + (`(,_) t) ; (and) -> t + (`(,_ ,arg) arg) ; (and X) -> X + (_ (byte-optimize-constant-args form))))) + (if nil-result + `(progn ,new-form nil) + new-form)))) (defun byte-optimize-or (form) - ;; Throw away nil's, and simplify if less than 2 args. - ;; If there is a literal non-nil constant in the args to `or', throw away all - ;; following forms. - (setq form (remq nil form)) - (let ((rest form)) - (while (cdr (setq rest (cdr rest))) - (if (byte-compile-trueconstp (car rest)) - (setq form (copy-sequence form) - rest (setcdr (memq (car rest) form) nil)))) - (if (cdr (cdr form)) - (byte-optimize-constant-args form) - (nth 1 form)))) + (let ((seq nil) + (new-args nil) + (args (remq nil (cdr form)))) ; Discard nil arguments. + (while + (and args + (let ((arg (car args))) + (cond + (seq ; previous arg was always-false + (push arg seq) + (unless (and (cdr args) (byte-compile-nilconstp arg)) + (push `(progn . ,(nreverse seq)) new-args) + (setq seq nil)) + t) + ((and (cdr args) (byte-compile-nilconstp arg)) + ;; Always-false arg: evaluate unconditionally. + (push arg seq) + t) + (t + (push arg new-args) + ;; If this arg is always true, throw away the remaining args. + (not (byte-compile-trueconstp arg)))))) + (setq args (cdr args))) + + (setq new-args (nreverse new-args)) + ;; Keep original form unless the arguments changed. + (unless (equal new-args (cdr form)) + (setq form (cons (car form) new-args))) + + (pcase form + ;; (or (progn ... X) ...) -> (progn ... (or X ...)) + (`(,head (progn . ,forms) . ,rest) + `(progn ,@(butlast forms) (,head ,(car (last forms)) . ,rest))) + (`(,_) nil) ; (or) -> nil + (`(,_ ,arg) arg) ; (or X) -> X + (_ (byte-optimize-constant-args form))))) (defun byte-optimize-cond (form) ;; if any clauses have a literal nil as their test, throw them away. @@ -1142,55 +1246,82 @@ See Info node `(elisp) Integer Basics'." (and clauses form))) form)) +(defsubst byte-opt--negate (form) + "Negate FORM, avoiding double negation if already negated." + (if (and (consp form) (memq (car form) '(not null))) + (cadr form) + `(not ,form))) + (defun byte-optimize-if (form) - ;; (if (progn <insts> <test>) <rest>) ==> (progn <insts> (if <test> <rest>)) - ;; (if <true-constant> <then> <else...>) ==> <then> - ;; (if <false-constant> <then> <else...>) ==> (progn <else...>) - ;; (if <test> nil <else...>) ==> (if (not <test>) (progn <else...>)) - ;; (if <test> <then> nil) ==> (if <test> <then>) - (let ((clause (nth 1 form))) - (cond ((and (eq (car-safe clause) 'progn) - (proper-list-p clause)) - (if (null (cddr clause)) - ;; A trivial `progn'. - (byte-optimize-if `(,(car form) ,(cadr clause) ,@(nthcdr 2 form))) - (nconc (butlast clause) - (list - (byte-optimize-if - `(,(car form) ,(car (last clause)) ,@(nthcdr 2 form))))))) - ((byte-compile-trueconstp clause) - `(progn ,clause ,(nth 2 form))) - ((byte-compile-nilconstp clause) - `(progn ,clause ,@(nthcdr 3 form))) - ((nth 2 form) - (if (equal '(nil) (nthcdr 3 form)) - (list (car form) clause (nth 2 form)) - form)) - ((or (nth 3 form) (nthcdr 4 form)) - (list (car form) - ;; 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)))) - (t - (list 'progn clause nil))))) + (let ((condition (nth 1 form)) + (then (nth 2 form)) + (else (nthcdr 3 form))) + (cond + ;; (if (progn ... X) ...) -> (progn ... (if X ...)) + ((eq (car-safe condition) 'progn) + (nconc (butlast condition) + (list + (byte-optimize-if + `(,(car form) ,(car (last condition)) ,@(nthcdr 2 form)))))) + ;; (if TRUE THEN ...) -> (progn TRUE THEN) + ((byte-compile-trueconstp condition) + `(progn ,condition ,then)) + ;; (if FALSE THEN ELSE...) -> (progn FALSE ELSE...) + ((byte-compile-nilconstp condition) + (if else + `(progn ,condition ,@else) + condition)) + ;; (if X nil t) -> (not X) + ((and (eq then nil) (eq else '(t))) + `(not ,condition)) + ;; (if X t [nil]) -> (not (not X)) + ((and (eq then t) (or (null else) (eq else '(nil)))) + `(not ,(byte-opt--negate condition))) + ;; (if VAR VAR X...) -> (or VAR (progn X...)) + ((and (symbolp condition) (eq condition then)) + `(or ,then ,(if (cdr else) + `(progn . ,else) + (car else)))) + ;; (if X THEN nil) -> (if X THEN) + (then + (if (equal else '(nil)) + (list (car form) condition then) + form)) + ;; (if X nil ELSE...) -> (if (not X) (progn ELSE...)) + ((or (car else) (cdr else)) + (list (car form) (byte-opt--negate condition) + (if (cdr else) + `(progn . ,else) + (car else)))) + ;; (if X nil nil) -> (progn X nil) + (t + (list 'progn condition nil))))) (defun byte-optimize-while (form) + ;; FIXME: This check does not belong here, move! (when (< (length form) 2) (byte-compile-warn-x form "too few arguments for `while'")) - (if (nth 1 form) - form)) + (let ((condition (nth 1 form))) + (if (byte-compile-nilconstp condition) + condition + form))) + +(defun byte-optimize-not (form) + (and (= (length form) 2) + (let ((arg (nth 1 form))) + (cond ((null arg) t) + ((macroexp-const-p arg) nil) + ((byte-compile-nilconstp arg) `(progn ,arg t)) + ((byte-compile-trueconstp arg) `(progn ,arg nil)) + (t form))))) (put 'and 'byte-optimizer #'byte-optimize-and) (put 'or 'byte-optimizer #'byte-optimize-or) (put 'cond 'byte-optimizer #'byte-optimize-cond) (put 'if 'byte-optimizer #'byte-optimize-if) (put 'while 'byte-optimizer #'byte-optimize-while) +(put 'not 'byte-optimizer #'byte-optimize-not) +(put 'null 'byte-optimizer #'byte-optimize-not) ;; byte-compile-negation-optimizer lives in bytecomp.el (put '/= 'byte-optimizer #'byte-compile-negation-optimizer) @@ -1207,25 +1338,26 @@ See Info node `(elisp) Integer Basics'." form))) (defun byte-optimize-apply (form) - ;; If the last arg is a literal constant, turn this into a funcall. - ;; The funcall optimizer can then transform (funcall 'foo ...) -> (foo ...). - (if (= (length form) 2) - ;; single-argument `apply' is not worth optimizing (bug#40968) - form - (let ((fn (nth 1 form)) - (last (nth (1- (length form)) form))) ; I think this really is fastest - (or (if (or (null last) - (eq (car-safe last) 'quote)) - (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)))) + (let ((len (length form))) + (if (>= len 2) + (let ((fn (nth 1 form)) + (last (nth (1- len) form))) + (cond + ;; (apply F ... '(X Y ...)) -> (funcall F ... 'X 'Y ...) + ((or (null last) + (eq (car-safe last) 'quote)) + (let ((last-value (nth 1 last))) + (if (listp last-value) + `(funcall ,fn ,@(butlast (cddr form)) + ,@(mapcar (lambda (x) (list 'quote x)) last-value)) (byte-compile-warn-x - last - "last arg to apply can't be a literal atom: `%s'" - last) - nil)) - form)))) + last "last arg to apply can't be a literal atom: `%s'" last) + nil))) + ;; (apply F ... (list X Y ...)) -> (funcall F ... X Y ...) + ((eq (car-safe last) 'list) + `(funcall ,fn ,@(butlast (cddr form)) ,@(cdr last))) + (t form))) + form))) (put 'funcall 'byte-optimizer #'byte-optimize-funcall) (put 'apply 'byte-optimizer #'byte-optimize-apply) @@ -2478,8 +2610,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; itself, compile some of its most used recursive functions (at load time). ;; (eval-when-compile - (or (byte-code-function-p (symbol-function 'byte-optimize-form)) - (subr-native-elisp-p (symbol-function 'byte-optimize-form)) + (or (compiled-function-p (symbol-function 'byte-optimize-form)) (assq 'byte-code (symbol-function 'byte-optimize-form)) (let ((byte-optimize nil) (byte-compile-warnings nil)) |