From: Vibhav Pant Date: Fri, 24 Feb 2017 15:20:51 +0000 (+0530) Subject: Optimize tail recursive calls while byte compiling. X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=refs%2Fheads%2Ffeature%2Fbyte-tail-recursion;p=emacs.git 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. --- 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 ) 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 . ) + (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.