[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] feature/byte-tail-recursion ca611bd: Optimize tail recursi
From: |
Vibhav Pant |
Subject: |
[Emacs-diffs] feature/byte-tail-recursion ca611bd: Optimize tail recursive calls while byte compiling. |
Date: |
Fri, 24 Feb 2017 10:28:40 -0500 (EST) |
branch: feature/byte-tail-recursion
commit ca611bda9cd462aa6d92cdaad1db9783afb27e8e
Author: Vibhav Pant <address@hidden>
Commit: Vibhav Pant <address@hidden>
Optimize tail recursive calls while byte compiling.
* 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.
---
lisp/emacs-lisp/byte-opt.el | 91 +++++++++++++++++++++++++++++++++++++++++++++
lisp/emacs-lisp/bytecomp.el | 29 +++++++++++----
2 files changed, 112 insertions(+), 8 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 004f2e2..a38571a 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 25513bd..efe8640 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.