From bfd338aad9d1e6bf898fc19d23e1a5ca4e696316 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 18 Jan 2023 18:36:29 +0100 Subject: [PATCH] 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 -> 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) -> , N=K to any N, not just N=1. - Add the rule OP goto(X) Y: OP X: -> 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 - ;; pop --> - ;; ...including: - ;; const-X pop --> - ;; varref-X pop --> - ;; dup pop --> - ;; - ((and (eq 'byte-discard (car lap1)) + ;; + ;; PUSH(K) discard(N) --> discard(N-K), N>K + ;; PUSH(K) discard(N) --> , 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" lap0) - (setq lap (delq lap0 (delq lap1 lap)))) - ((eql tmp 0) - (byte-compile-log-lap - " %s discard\t-->\t 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" lap0 lap1) + (setcdr rest (cddr rest)) + (setq lap (delq lap0 lap))) + ((> net-pops 0) + (byte-compile-log-lap + " %s %s\t-->\t 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))) -- 2.39.5