master 66439d3 3/4: * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Add 2 new opts

[Stefan Monnier]

branch: master
commit 66439d31ad2a63753d29e4582b76b36b9363d96b
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Add 2 new opts
    
    This introduces two new optimizations.  They're designed for code like
    
        (while
            (let (...)
              (if ... (progn blabla t) (progn blabla nil)))
          ...)
    
    and they allow the elimination of the test internal to `while` since
    we can immediately know when we return `t` or `nil` what the result
    of the test will be.
    
    `cl-labels` tends to generate this kind of code when it applies the
    tail-call optimization.
---
 lisp/emacs-lisp/byte-opt.el | 31 +++++++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 620bd91..cfa4070 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -2056,6 +2056,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to 
be of no importance."
          (setcdr (cdr rest) tmp)
          (byte-compile-log-lap "  %s [discard/discardN]...\t-->\t%s"
                                lap0 lap1))
+
         ;;
         ;; discardN-preserve-tos return  -->  return
         ;; dup return  -->  return
@@ -2071,6 +2072,36 @@ If FOR-EFFECT is non-nil, the return value is assumed to 
be of no importance."
          (setq lap (delq lap0 lap))
          (byte-compile-log-lap "  %s %s\t-->\t%s" lap0 lap1 lap1))
 
+        ;;
+        ;; goto-X ... X: discard  ==>  discard goto-Y ... X: discard Y:
+        ;;
+        ((and (eq (car lap0) 'byte-goto)
+              (setq tmp (cdr (memq (cdr lap0) lap)))
+              (memq (caar tmp) '(byte-discard byte-discardN
+                                 byte-discardN-preserve-tos)))
+         (byte-compile-log-lap
+          "  goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
+          (car tmp) (car tmp))
+         (setq keep-going t)
+         (let* ((newtag (byte-compile-make-tag))
+                ;; Make a copy, since we sometimes modify insts in-place!
+                (newdiscard (cons (caar tmp) (cdar tmp)))
+                (newjmp (cons (car lap0) newtag)))
+           (push newtag (cdr tmp))     ;Push new tag after the discard.
+           (setcar rest newdiscard)
+           (push newjmp (cdr rest))))
+
+        ;;
+        ;; const discardN-preserve-tos ==> discardN const
+        ;;
+        ((and (eq (car lap0) 'byte-constant)
+              (eq (car lap1) 'byte-discardN-preserve-tos))
+         (setq keep-going t)
+         (let ((newdiscard (cons 'byte-discardN (cdr lap1))))
+           (byte-compile-log-lap
+            "  %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
+           (setf (car rest) newdiscard)
+           (setf (cadr rest) lap0)))
         )
        (setq rest (cdr rest)))
       )