LAP optimiser: more stack reduction hoisting

Hoisting stack reduction ops allows them to coalesce and/or cancel out
pushing ops, and for useful operations to sink and combine, such as
not + goto-if-[not-]nil.

* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode):
Add the rule

  UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY

where UNARY pops and pushes one value.

Generalise the rule

  const discardN-preserve-tos --> discardN const

to any 0-ary op, not just const: varref, point, etc.

1 files changed, 43 insertions, 24 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 833e88887f9..1fa8e8bdf8b 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -2042,6 +2042,22 @@ 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
@@ -2421,12 +2437,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
              ;;                 const, varref, point etc.
              ;;
              ((and (eq (car (nth 2 rest)) 'byte-return)
-                   (memq (car lap1) '( 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))
+                   (memq (car lap1) producer-ops)
                    (or (memq (car lap0) '( byte-discard byte-discardN
                                            byte-discardN-preserve-tos
                                            byte-stack-set))
@@ -2438,26 +2449,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
                                     lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
 
              ;;
-             ;; discardN-preserve-tos OP return  -->  OP return
-             ;; dup                   OP return  -->  OP return
-             ;;  where OP is 1->1 in stack use, like `not'.
+             ;; (discardN-preserve-tos|dup) UNARY return  -->  UNARY return
+             ;;  where UNARY takes and produces a single value on the stack
              ;;
              ;; FIXME: ideally we should run this backwards, so that we could do
              ;;   discardN-preserve-tos OP1...OPn return -> OP1..OPn return
              ;; but that would require a different approach.
              ;;
              ((and (eq (car (nth 2 rest)) 'byte-return)
-                   (memq (car lap1)
-                         '( byte-not
-                            byte-symbolp byte-consp byte-stringp
-                            byte-listp byte-integerp byte-numberp
-                            byte-list1
-                            byte-car byte-cdr byte-car-safe byte-cdr-safe
-                            byte-length
-                            byte-add1 byte-sub1 byte-negate byte-nreverse
-                            ;; There are more of these but the list is
-                            ;; getting long and the gain is small.
-                            ))
+                   (memq (car lap1) unary-ops)
                    (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
                        (and (eq (car lap0) 'byte-stack-set)
                             (eql (cdr lap0) 1))))
@@ -2785,14 +2785,32 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
                           (push newjmp (cdr rest)))
                         t)))))
 
+             ;;
+             ;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY
+             ;;  where UNARY takes and produces a single value on the stack
+             ;;
+             ((and (memq (car lap0) unary-ops)
+                   (or (eq (car lap1) 'byte-discardN-preserve-tos)
+                       (and (eq (car lap1) 'byte-stack-set)
+                            (eql (cdr lap1) 1)))
+                   ;; unless followed by return (which will eat the discard)
+                   (not (eq (car lap2) 'byte-return)))
+              (setq keep-going t)
+              (byte-compile-log-lap "  %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+              (setcar rest lap1)
+              (setcar (cdr rest) lap0))
+
              ;;
-             ;; const discardN-preserve-tos ==> discardN const
-             ;; const stack-set(1)          ==> discard const
+             ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER
+             ;;  where PRODUCER pushes a result without looking at the stack:
+             ;;                 const, varref, point etc.
              ;;
-             ((and (eq (car lap0) 'byte-constant)
+             ((and (memq (car lap0) producer-ops)
                    (or (eq (car lap1) 'byte-discardN-preserve-tos)
                        (and (eq (car lap1) 'byte-stack-set)
-                            (eql (cdr lap1) 1))))
+                            (eql (cdr lap1) 1)))
+                   ;; unless followed by return (which will eat the discard)
+                   (not (eq (car lap2) 'byte-return)))
               (setq keep-going t)
               (let ((newdiscard (if (eql (cdr lap1) 1)
                                     (cons 'byte-discard nil)
@@ -2801,6 +2819,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
                  "  %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
                 (setf (car rest) newdiscard)
                 (setf (cadr rest) lap0)))
+
              (t
               ;; If no rule matched, advance and try again.
               (setq prev (cdr prev))))))))