Optimize tail recursive calls while byte compiling.feature/byte-tail-recursion

* lisp/emacs-lisp/byte-opt.el (byte-optimize-stack-adjustment)
  (byte-optimize-conv-return-goto), (byte-optimize-copy-ops),
  (byte-optimize-called-function), (byte-optimize-lapcode-tail-recursion):
  New functions.

* lisp/emacs-lisp/bytecomp.el: Add variables b-c-current-{defun,
  arglist}.
  (byte-compile-file-form-defmumble), (byte-compile): Set them.
  (byte-compile-out-toplevel): Use byte-optimize-lapcode-tail-recursion.

2 files changed, 112 insertions, 8 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 004f2e28653..a38571a245a 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -2148,6 +2148,97 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
     (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
   lap)
 
+;; Tail recursion optimization
+
+(defun byte-optimize-stack-adjustment (op)
+  (and (not (eq (car op) 'TAG))
+       (byte-compile-stack-adjustment
+        (car op)
+        (if (consp (cdr op)) (nth 1 op) (cdr op)))))
+
+(defun byte-optimize-conv-return-goto (lap n)
+  (let ((arglist (reverse byte-compile-current-arglist))
+        (args-copied 0)
+        args current-arg-lapcode op current-arg)
+    (while (/= args-copied (length arglist))
+      (cl-decf n)
+      (cl-multiple-value-setq (current-arg-lapcode n)
+        (byte-optimize-copy-ops lap n -1 nil))
+      (setq current-arg (assq (nth args-copied arglist)
+                              byte-compile-variables))
+      (cl-assert current-arg)
+      (push `(,@current-arg-lapcode (byte-varset ,@current-arg))
+            args)
+      (cl-incf args-copied))
+    (apply #'append args)))
+
+;; recursively copy ops from lap until depth is met
+(defun byte-optimize-copy-ops (lap n depth ops)
+  (let* ((op (nth n lap))
+         (depth-op (byte-optimize-stack-adjustment op))
+         (new-depth (and depth-op (+ depth depth-op))))
+    (push op ops)
+    (if (zerop new-depth)
+        (cl-values ops n)
+      (byte-optimize-copy-ops lap (1- n) (or new-depth depth) ops))))
+
+(defun byte-optimize-called-function (lap n)
+  "Return:
+The function name being called at N in LAP
+The index from where the call lapcode starts \(ie, where
+\(byte-constant <func-name>) is\).
+
+N should point to a `byte-call' op in LAP."
+  (let* ((op (nth n lap))
+         (depth (byte-compile-stack-adjustment (car op) (cdr op))))
+    (cl-assert (eq (car op) 'byte-call))
+    (while (/= depth 0)
+      (setq op (nth (cl-decf n) lap))
+      (cl-incf depth (or (byte-optimize-stack-adjustment op) 0)))
+    ;; we should be at (byte-constant . <func-name>)
+    (setq op (nth (cl-decf n) lap))
+    (cl-assert (eq (car op) 'byte-constant))
+    (cl-values (cadr op) n)))
+
+(defun byte-optimize-lapcode-tail-recursion (lap)
+  (let ((n (1- (length lap)))
+        (func-start-tag (nth 0 lap))
+        op)
+    (unless (eq (car func-start-tag) 'TAG)
+      (push (setq func-start-tag (byte-compile-make-tag)) lap)
+      (setcdr (cdr func-start-tag) 0)
+      (cl-incf n))
+    (while (>= n 0)
+      (setq op (nth n lap))
+      (when (eq (car op) 'byte-return)
+        ;; `byte-optimize-lapcode' merges redundant tags,
+        ;; so we only need to subtract once.
+        (let* ((call-op-n (if (eq (car (nth (1- n) lap)) 'TAG)
+                              (- n 2)
+                            (1- n))) ;; index of the potential `byte-call' op
+               (op-call (nth call-op-n lap)) ;; the op at call-op-n
+               func-name ;; name of the function being called
+               func-call-start-n) ;; from where the actual call lapcode start
+          (when (and (eq (car op-call) 'byte-call) ;; this is a tail call
+                     (progn
+                       (cl-multiple-value-setq (func-name func-call-start-n)
+                         (byte-optimize-called-function lap call-op-n))
+                       ;; this is a (tail) recursive call
+                       (eq byte-compile-current-defun func-name))
+                     (not (or (memq '&optional byte-compile-current-arglist)
+                              (memq '&rest byte-compile-current-arglist))))
+            ;; "Lift" the calling lapcode out of LAP, and replace it with
+            ;; our new tail call code.
+            (setq lap (append
+                       (cl-subseq lap 0 func-call-start-n)
+                       (byte-optimize-conv-return-goto lap call-op-n)
+                       `((byte-unbind-all)
+                         (byte-goto . ,func-start-tag))
+                       (cl-subseq lap (1+ n)))
+                  n (length lap)))))
+      (cl-decf n))
+    lap))
+
 (provide 'byte-opt)
 
 
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 25513bd0248..efe86404fcf 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -197,6 +197,7 @@ adds `c' to it; otherwise adds `.elc'."
 ;; that doesn't define this function, so this seems to be a reasonable
 ;; thing to do.
 (autoload 'byte-decompile-bytecode "byte-opt")
+(autoload 'byte-optimize-lapcode-tail-recursion "byte-opt")
 
 (defcustom byte-compile-verbose
   (and (not noninteractive) (> baud-rate search-slow-speed))
@@ -1000,6 +1001,8 @@ Each function's symbol gets added to `byte-compile-noruntime-functions'."
 (defvar byte-compile-current-file nil)
 (defvar byte-compile-current-group nil)
 (defvar byte-compile-current-buffer nil)
+(defvar byte-compile-current-defun nil)
+(defvar byte-compile-current-arglist nil)
 
 ;; Log something that isn't a warning.
 (defmacro byte-compile-log (format-string &rest args)
@@ -2538,7 +2541,9 @@ not to take responsibility for the actual compilation of the code."
           ;; Tell the caller that we didn't compile it yet.
           nil)
 
-      (let* ((code (byte-compile-lambda (cons arglist body) t)))
+      (let* ((byte-compile-current-defun name)
+             (byte-compile-current-arglist arglist)
+             (code (byte-compile-lambda (cons arglist body) t)))
         (if this-one
             ;; A definition in b-c-initial-m-e should always take precedence
             ;; during compilation, so don't let it be redefined.  (Bug#8647)
@@ -2668,11 +2673,13 @@ If FORM is a lambda or a macro, byte-compile it as a function."
           (setq fun (byte-compile--reify-function fun)))
         ;; Expand macros.
         (setq fun (byte-compile-preprocess fun))
-        (setq fun (byte-compile-top-level fun nil 'eval))
-        (if macro (push 'macro fun))
-        (if (symbolp form)
-            (fset form fun)
-          fun)))))))
+        (let ((byte-compile-current-defun (and (symbolp form) form))
+              (byte-compile-current-arglist (nth 1 (cadr fun))))
+          (setq fun (byte-compile-top-level fun nil 'eval))
+          (if macro (push 'macro fun))
+          (if (symbolp form)
+              (fset form fun)
+            fun))))))))
 
 (defun byte-compile-sexp (sexp)
   "Compile and return SEXP."
@@ -2923,9 +2930,15 @@ for symbols generated by the byte compiler itself."
 		(caar tmp))))))
   (byte-compile-out 'byte-return 0)
   (setq byte-compile-output (nreverse byte-compile-output))
-  (if (memq byte-optimize '(t byte))
+  (when (memq byte-optimize '(t byte))
+    (setq byte-compile-output
+          (byte-optimize-lapcode byte-compile-output))
+    ;; Do tail recursion optimization after `byte-optimize-lapcode',
+    ;; since the lapcode now contains more than a single `byte-return',
+    ;; allowing us to optimize multiple tail recursive calls
+    (when byte-compile-current-defun
       (setq byte-compile-output
-	    (byte-optimize-lapcode byte-compile-output)))
+            (byte-optimize-lapcode-tail-recursion byte-compile-output))))
 
   ;; Decompile trivial functions:
   ;; only constants and variables, or a single funcall except in lambdas.