mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-16 17:24:23 +00:00
Move some constants into the peephole optimiser
* lisp/emacs-lisp/byte-opt.el (byte-tagref-ops, byte-conditional-ops) (byte-after-unbind-ops, byte-compile-side-effect-and-error-free-ops) (byte-compile-side-effect-free-ops): Move into the constant pool... * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): ...here, bringing comments up to date.
This commit is contained in:
Mattias Engdegård
parent
2ed5179179
commit
0ccc246465
1 changed files with 73 additions and 105 deletions
|
|
@ -2153,108 +2153,76 @@ See Info node `(elisp) Integer Basics'."
|
|||
|
||||
;;; peephole optimizer
|
||||
|
||||
(defconst byte-tagref-ops (cons 'TAG byte-goto-ops))
|
||||
(eval-when-compile
|
||||
(defconst byte-opt--side-effect-and-error-free-ops
|
||||
'( byte-stack-ref byte-constant byte-dup byte-symbolp byte-consp
|
||||
byte-stringp byte-listp byte-integerp byte-numberp byte-eq byte-not
|
||||
byte-car-safe byte-cdr-safe
|
||||
byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN
|
||||
byte-point byte-point-max byte-point-min
|
||||
byte-following-char byte-preceding-char
|
||||
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
|
||||
byte-current-buffer))
|
||||
|
||||
(defconst byte-conditional-ops
|
||||
'(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
|
||||
byte-goto-if-not-nil-else-pop))
|
||||
|
||||
(defconst byte-after-unbind-ops
|
||||
'(byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard
|
||||
byte-discardN byte-discardN-preserve-tos
|
||||
byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
|
||||
byte-not
|
||||
byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN
|
||||
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.
|
||||
;;
|
||||
;; In particular, `byte-eq' isn't here despite `eq' being nominally
|
||||
;; pure because it is currently affected by `symbols-with-pos-enabled'
|
||||
;; and so cannot be sunk past an unwind op that might end a binding of
|
||||
;; that variable. Yes, this is unsatisfactory.
|
||||
"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-integerp byte-numberp byte-eq byte-not byte-car-safe
|
||||
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-list3 byte-list4
|
||||
byte-listN byte-point byte-point-max
|
||||
byte-point-min byte-following-char byte-preceding-char
|
||||
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
|
||||
byte-current-buffer byte-stack-ref))
|
||||
|
||||
(defconst byte-compile-side-effect-free-ops
|
||||
(append
|
||||
'(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-equal byte-gtr byte-lss byte-leq byte-geq byte-diff
|
||||
byte-negate byte-plus byte-max byte-min byte-mult byte-char-after
|
||||
byte-char-syntax byte-buffer-substring byte-string= byte-string<
|
||||
byte-nthcdr byte-elt byte-member byte-assq byte-quo byte-rem
|
||||
byte-substring)
|
||||
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.
|
||||
|
||||
;; The variable `byte-boolean-vars' is now primitive and updated
|
||||
;; automatically by DEFVAR_BOOL.
|
||||
(defconst byte-opt--side-effect-free-ops
|
||||
(append
|
||||
'( 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-equal byte-gtr byte-lss byte-leq byte-geq byte-diff
|
||||
byte-negate byte-plus byte-max byte-min byte-mult byte-char-after
|
||||
byte-char-syntax byte-buffer-substring byte-string= byte-string<
|
||||
byte-nthcdr byte-elt byte-member byte-assq byte-quo byte-rem
|
||||
byte-substring)
|
||||
byte-opt--side-effect-and-error-free-ops))
|
||||
)
|
||||
|
||||
(defun byte-optimize-lapcode (lap &optional _for-effect)
|
||||
"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 ((side-effect-free (if byte-compile-delete-errors
|
||||
byte-compile-side-effect-free-ops
|
||||
byte-compile-side-effect-and-error-free-ops))
|
||||
;; Ops taking and produce a single value on the stack.
|
||||
(unary-ops '( byte-not byte-length byte-list1 byte-nreverse
|
||||
byte-car byte-cdr byte-car-safe byte-cdr-safe
|
||||
byte-symbolp byte-consp byte-stringp
|
||||
byte-listp byte-integerp byte-numberp
|
||||
byte-add1 byte-sub1 byte-negate
|
||||
;; There are more of these but the list is
|
||||
;; getting long and the gain is typically small.
|
||||
))
|
||||
;; Ops producing a single result without looking at the stack.
|
||||
(producer-ops '( byte-constant byte-varref
|
||||
byte-point byte-point-max byte-point-min
|
||||
byte-following-char byte-preceding-char
|
||||
byte-current-column
|
||||
byte-eolp byte-eobp byte-bolp byte-bobp
|
||||
byte-current-buffer byte-widen))
|
||||
(add-depth 0)
|
||||
(keep-going 'first-time)
|
||||
;; Create a cons cell as head of the list so that removing the first
|
||||
;; element does not need special-casing: `setcdr' always works.
|
||||
(lap-head (cons nil lap)))
|
||||
(let* ((side-effect-free
|
||||
(if byte-compile-delete-errors
|
||||
(eval-when-compile byte-opt--side-effect-free-ops)
|
||||
(eval-when-compile byte-opt--side-effect-and-error-free-ops)))
|
||||
|
||||
(conditional-ops
|
||||
'( byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
|
||||
byte-goto-if-not-nil-else-pop))
|
||||
(conditional-or-discard-ops (cons 'discard conditional-ops))
|
||||
|
||||
;; Ops that can be sunk past an unbind.
|
||||
;; This means they have to commute with anything else, which rules
|
||||
;; out ones like `byte-car-safe' and `byte-equal'.
|
||||
;; In particular, `byte-eq' isn't here despite `eq' being
|
||||
;; nominally pure because it is currently affected by
|
||||
;; `symbols-with-pos-enabled'. Yes, this is unsatisfactory.
|
||||
(after-unbind-ops
|
||||
'( byte-constant byte-dup byte-stack-ref byte-stack-set byte-discard
|
||||
byte-discardN byte-discardN-preserve-tos
|
||||
byte-symbolp byte-consp byte-stringp byte-listp byte-numberp
|
||||
byte-integerp byte-not
|
||||
byte-cons byte-list1 byte-list2 byte-list3 byte-list4 byte-listN))
|
||||
|
||||
;; Ops taking and produce a single value on the stack.
|
||||
(unary-ops '( byte-not byte-length byte-list1 byte-nreverse
|
||||
byte-car byte-cdr byte-car-safe byte-cdr-safe
|
||||
byte-symbolp byte-consp byte-stringp
|
||||
byte-listp byte-integerp byte-numberp
|
||||
byte-add1 byte-sub1 byte-negate
|
||||
;; There are more of these but the list is
|
||||
;; getting long and the gain is typically small.
|
||||
))
|
||||
;; Ops producing a single result without looking at the stack.
|
||||
(producer-ops '( byte-constant byte-varref
|
||||
byte-point byte-point-max byte-point-min
|
||||
byte-following-char byte-preceding-char
|
||||
byte-current-column
|
||||
byte-eolp byte-eobp byte-bolp byte-bobp
|
||||
byte-current-buffer byte-widen))
|
||||
(add-depth 0)
|
||||
(keep-going 'first-time)
|
||||
;; Create a cons cell as head of the list so that removing the first
|
||||
;; element does not need special-casing: `setcdr' always works.
|
||||
(lap-head (cons nil lap)))
|
||||
(while keep-going
|
||||
(byte-compile-log-lap " ---- %s pass"
|
||||
(if (eq keep-going 'first-time) "first" "next"))
|
||||
|
|
@ -2332,6 +2300,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
((and (eq 'byte-varref (car lap2))
|
||||
(eq (cdr lap1) (cdr lap2))
|
||||
(memq (car lap1) '(byte-varset byte-varbind))
|
||||
;; Can't optimise away varref for DEFVAR_BOOL vars
|
||||
;; because what we put in might not be what we get out.
|
||||
(let ((tmp (memq (car (cdr lap2)) byte-boolean-vars)))
|
||||
(and
|
||||
(not (and tmp (not (eq (car lap0) 'byte-constant))))
|
||||
|
|
@ -2430,7 +2400,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
;; const goto-if-* --> whatever
|
||||
;;
|
||||
((and (eq 'byte-constant (car lap0))
|
||||
(memq (car lap1) byte-conditional-ops)
|
||||
(memq (car lap1) conditional-ops)
|
||||
;; Must be an actual constant, not a closure variable.
|
||||
(consp (cdr lap0)))
|
||||
(cond ((if (memq (car lap1) '(byte-goto-if-nil
|
||||
|
|
@ -2559,7 +2529,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
;; (this may enable other optimizations.)
|
||||
;;
|
||||
((and (eq 'byte-unbind (car lap1))
|
||||
(memq (car lap0) byte-after-unbind-ops))
|
||||
(memq (car lap0) after-unbind-ops))
|
||||
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
|
||||
(setcar rest lap1)
|
||||
(setcar (cdr rest) lap0)
|
||||
|
|
@ -2674,9 +2644,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
byte-goto-if-not-nil-else-pop))
|
||||
(let ((tmp (cdr (memq (cdr lap0) (cdr lap-head)))))
|
||||
(and
|
||||
(memq (caar tmp)
|
||||
(eval-when-compile
|
||||
(cons 'byte-discard byte-conditional-ops)))
|
||||
(memq (caar tmp) conditional-or-discard-ops)
|
||||
(not (eq lap0 (car tmp)))
|
||||
(let ((tmp2 (car tmp))
|
||||
(tmp3 (assq (car lap0)
|
||||
|
|
@ -2709,9 +2677,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
(eq (car lap1) 'byte-goto)
|
||||
(let ((tmp (cdr (memq (cdr lap1) (cdr lap-head)))))
|
||||
(and
|
||||
(memq (caar tmp)
|
||||
(eval-when-compile
|
||||
(cons 'byte-discard byte-conditional-ops)))
|
||||
(memq (caar tmp) conditional-or-discard-ops)
|
||||
(not (eq lap1 (car tmp)))
|
||||
(let ((tmp2 (car tmp)))
|
||||
(cond ((and (consp (cdr lap0))
|
||||
|
|
@ -2761,6 +2727,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
|
|||
(and
|
||||
(eq (car (car tmp)) 'byte-varref)
|
||||
(eq (cdr (car tmp)) (cdr lap1))
|
||||
;; Can't optimise away varref for DEFVAR_BOOL vars
|
||||
;; because what we put in might not be what we get out.
|
||||
(not (memq (car (cdr lap1)) byte-boolean-vars))
|
||||
(let ((newtag (byte-compile-make-tag)))
|
||||
(byte-compile-log-lap
|
||||
|
|
|
|||
Loading…
Reference in a new issue