[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master bfd338aad9d 2/2: LAP peephole optimisation improvements
|
From: |
Mattias Engdegård |
|
Subject: |
master bfd338aad9d 2/2: LAP peephole optimisation improvements |
|
Date: |
Thu, 2 Feb 2023 08:47:37 -0500 (EST) |
branch: master
commit bfd338aad9d1e6bf898fc19d23e1a5ca4e696316
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>
LAP peephole optimisation improvements
- Since discardN-preserve-tos(1) and stack-set(1) have the same
effect, treat them as equivalent in all transformations.
- Move the rule
discardN-preserve-tos(X) discardN-preserve-tos(Y)
--> discardN-preserve-tos(X+Y)
from the final pass to the main iteration since it may enable
further optimisations.
- Don't apply the rule
goto(X) ... X: DISCARD --> DISCARD goto(Y) ... X: DISCARD Y:
when DISCARD could be merged or deleted instead, which is even better.
- Add the rule
OP const return -> <deleted> const return
where OP is effect-free.
- Generalise the push-pop annihilation rule to
PUSH(K) discard(N) -> discard(N-K), N>K
PUSH(K) discard(N) -> <deleted>, N=K
to any N, not just N=1.
- Add the rule
OP goto(X) Y: OP X: -> <deleted> Y: OP X:
for any operation OP.
* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode):
Make the changes described above.
---
lisp/emacs-lisp/byte-opt.el | 128 +++++++++++++++++++++++++++++++-------------
1 file changed, 90 insertions(+), 38 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 9eb48f5fe0b..861cf95b1ff 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -2042,31 +2042,29 @@ If FOR-EFFECT is non-nil, the return value is assumed
to be of no importance."
;; optimized but sequences like "dup varset TAG1: discard" are not.
;; You may be tempted to change this; resist that temptation.
(cond
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((and (eq 'byte-discard (car lap1))
+ ;;
+ ;; PUSH(K) discard(N) --> <deleted> discard(N-K), N>K
+ ;; PUSH(K) discard(N) --> <deleted>, N=K
+ ;; where PUSH(K) is a side-effect-free op such as const, varref, dup
+ ;;
+ ((and (memq (car lap1) '(byte-discard byte-discardN))
(memq (car lap0) side-effect-free))
(setq keep-going t)
- (setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
- (setq rest (cdr rest))
- (cond ((eql tmp 1)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
- (setq lap (delq lap0 (delq lap1 lap))))
- ((eql tmp 0)
- (byte-compile-log-lap
- " %s discard\t-->\t<deleted> discard" lap0)
- (setq lap (delq lap0 lap)))
- ((eql tmp -1)
- (byte-compile-log-lap
- " %s discard\t-->\tdiscard discard" lap0)
- (setcar lap0 'byte-discard)
- (setcdr lap0 0))
- (t (error "Optimizer error: too much on the stack"))))
+ (let* ((pushes (aref byte-stack+-info (symbol-value (car lap0))))
+ (pops (if (eq (car lap1) 'byte-discardN) (cdr lap1) 1))
+ (net-pops (- pops pushes)))
+ (cond ((= net-pops 0)
+ (byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1)
+ (setcdr rest (cddr rest))
+ (setq lap (delq lap0 lap)))
+ ((> net-pops 0)
+ (byte-compile-log-lap
+ " %s %s\t-->\t<deleted> discard(%d)" lap0 lap1 net-pops)
+ (setcar rest (if (eql net-pops 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN net-pops)))
+ (setcdr rest (cddr rest)))
+ (t (error "Optimizer error: too much on the stack")))))
;;
;; goto*-X X: --> X:
;;
@@ -2353,6 +2351,40 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(setcar lap0 'byte-return))
(setcdr lap0 (cdr tmp))
(setq keep-going t))))
+
+ ;;
+ ;; OP goto(X) Y: OP X: -> Y: OP X:
+ ;;
+ ((and (eq (car lap1) 'byte-goto)
+ (eq (car lap2) 'TAG)
+ (let ((lap3 (nth 3 rest)))
+ (and (eq (car lap0) (car lap3))
+ (eq (cdr lap0) (cdr lap3))
+ (eq (cdr lap1) (nth 4 rest)))))
+ (byte-compile-log-lap " %s %s %s %s %s\t-->\t%s %s %s"
+ lap0 lap1 lap2
+ (nth 3 rest) (nth 4 rest)
+ lap2 (nth 3 rest) (nth 4 rest))
+ (setcdr rest (cddr rest))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))
+
+ ;;
+ ;; OP const return --> const return
+ ;; where OP is side-effect-free (or mere stack manipulation).
+ ;;
+ ((and (eq (car lap1) 'byte-constant)
+ (eq (car (nth 2 rest)) 'byte-return)
+ (or (memq (car lap0) '( byte-discard byte-discardN
+ byte-discardN-preserve-tos
+ byte-stack-set))
+ (memq (car lap0) side-effect-free)))
+ (setq keep-going t)
+ (setq add-depth 1) ; in case we get rid of too much stack reduction
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
+ lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
+
;;
;; goto-*-else-pop X ... X: goto-if-* --> whatever
;; goto-*-else-pop X ... X: discard --> whatever
@@ -2491,6 +2523,24 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
)
(setq keep-going t))
+ ;;
+ ;; discardN-preserve-tos(X) discardN-preserve-tos(Y)
+ ;; --> discardN-preserve-tos(X+Y)
+ ;; where stack-set(1) is accepted as discardN-preserve-tos(1)
+ ;;
+ ((and (or (eq (car lap0) 'byte-discardN-preserve-tos)
+ (and (eq (car lap0) 'byte-stack-set) (eql (cdr lap0) 1)))
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set) (eql (cdr lap1) 1))))
+ (setq keep-going t)
+ (let ((new-op (cons 'byte-discardN-preserve-tos
+ ;; This happens to work even when either
+ ;; op is stack-set(1).
+ (+ (cdr lap0) (cdr lap1)))))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new-op)
+ (setcar rest new-op)
+ (setcdr rest (cddr rest))))
+
;;
;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
;; stack-set-M [discard/discardN ...] --> discardN
@@ -2529,7 +2579,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
;;
;; discardN-preserve-tos return --> return
;; dup return --> return
- ;; stack-set-N return --> return ; where N is TOS-1
+ ;; stack-set(1) return --> return
;;
((and (eq (car lap1) 'byte-return)
(or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
@@ -2546,8 +2596,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
;;
((and (eq (car lap0) 'byte-goto)
(setq tmp (cdr (memq (cdr lap0) lap)))
- (memq (caar tmp) '(byte-discard byte-discardN
- byte-discardN-preserve-tos)))
+ (or (memq (caar tmp) '(byte-discard byte-discardN))
+ ;; Make sure we don't hoist a discardN-preserve-tos
+ ;; that really should be merged or deleted instead.
+ (and (eq (caar tmp) 'byte-discardN-preserve-tos)
+ (let ((next (cadr tmp)))
+ (not (or (memq (car next)
'(byte-discardN-preserve-tos
+ byte-return))
+ (and (eq (car next) 'byte-stack-set)
+ (eql (cdr next) 1))))))))
(byte-compile-log-lap
" goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
(car tmp) (car tmp))
@@ -2562,11 +2619,16 @@ If FOR-EFFECT is non-nil, the return value is assumed
to be of no importance."
;;
;; const discardN-preserve-tos ==> discardN const
+ ;; const stack-set(1) ==> discard const
;;
((and (eq (car lap0) 'byte-constant)
- (eq (car lap1) 'byte-discardN-preserve-tos))
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1))))
(setq keep-going t)
- (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+ (let ((newdiscard (if (eql (cdr lap1) 1)
+ (cons 'byte-discard nil)
+ (cons 'byte-discardN (cdr lap1)))))
(byte-compile-log-lap
" %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
(setf (car rest) newdiscard)
@@ -2651,16 +2713,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to
be of no importance."
(setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
(setcar lap1 'byte-discardN))
-
- ;;
- ;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
- ;; discardN-preserve-tos-(X+Y)
- ;;
- ((and (eq (car lap0) 'byte-discardN-preserve-tos)
- (eq (car lap1) 'byte-discardN-preserve-tos))
- (setq lap (delq lap0 lap))
- (setcdr lap1 (+ (cdr lap0) (cdr lap1)))
- (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))