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.

1 files 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)))