[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 3b9dad8: * lisp/subr.el (letrec): Optimize some non-recursive bin
From: |
Stefan Monnier |
Subject: |
master 3b9dad8: * lisp/subr.el (letrec): Optimize some non-recursive bindings |
Date: |
Fri, 8 Jan 2021 18:44:23 -0500 (EST) |
branch: master
commit 3b9dad88e02f05773c599808266febf3e4128222
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
* lisp/subr.el (letrec): Optimize some non-recursive bindings
* lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Look inside bytecode
objects as well.
* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels):
* test/lisp/subr-tests.el (subr--tests-letrec): New tests.
---
lisp/emacs-lisp/macroexp.el | 2 +-
lisp/subr.el | 25 ++++++++++++++++++++++---
test/lisp/emacs-lisp/cl-macs-tests.el | 8 ++++++++
test/lisp/subr-tests.el | 9 +++++++++
4 files changed, 40 insertions(+), 4 deletions(-)
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index d5fda52..3784497 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -499,7 +499,7 @@ test of free variables in the following ways:
(dolist (binding (macroexp--fgrep bindings (pop sexp)))
(push binding res)
(setq bindings (remove binding bindings))))
- (if (vectorp sexp)
+ (if (or (vectorp sexp) (byte-code-function-p sexp))
;; With backquote, code can appear within vectors as well.
;; This wouldn't be needed if we `macroexpand-all' before
;; calling macroexp--fgrep, OTOH.
diff --git a/lisp/subr.el b/lisp/subr.el
index b92744c..bc0c417 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1874,9 +1874,28 @@ all symbols are bound before any of the VALUEFORMs are
evalled."
;; As a special-form, we could implement it more efficiently (and cleanly,
;; making the vars actually unbound during evaluation of the binders).
(declare (debug let) (indent 1))
- `(let ,(mapcar #'car binders)
- ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
- ,@body))
+ ;; Use plain `let*' for the non-recursive definitions.
+ ;; This only handles the case where the first few definitions are not
+ ;; recursive. Nothing as fancy as an SCC analysis.
+ (let ((seqbinds nil))
+ ;; Our args haven't yet been macro-expanded, so `macroexp--fgrep'
+ ;; may fail to see references that will be introduced later by
+ ;; macroexpansion. We could call `macroexpand-all' to avoid that,
+ ;; but in order to avoid that, we instead check to see if the binders
+ ;; appear in the macroexp environment, since that's how references can be
+ ;; introduced later on.
+ (unless (macroexp--fgrep binders macroexpand-all-environment)
+ (while (and binders
+ (null (macroexp--fgrep binders (nth 1 (car binders)))))
+ (push (pop binders) seqbinds)))
+ (let ((nbody (if (null binders)
+ (macroexp-progn body)
+ `(let ,(mapcar #'car binders)
+ ,@(mapcar (lambda (binder) `(setq ,@binder)) binders)
+ ,@body))))
+ (if seqbinds
+ `(let* ,(nreverse seqbinds) ,nbody)
+ nbody))))
(defmacro dlet (binders &rest body)
"Like `let*' but using dynamic scoping."
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el
b/test/lisp/emacs-lisp/cl-macs-tests.el
index 446983c..7774ed3 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -610,4 +610,12 @@ collection clause."
;; Just make sure the function can be instrumented.
(edebug-defun)))
+;;; cl-labels
+
+(ert-deftest cl-macs--labels ()
+ ;; Simple recursive function.
+ (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0)))
+ (should (equal (len (make-list 42 t)) 42)))
+ )
+
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 2118530..e082620 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -433,6 +433,15 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350."
(should (equal (flatten-tree '(1 ("foo" "bar") 2))
'(1 "foo" "bar" 2))))
+(ert-deftest subr--tests-letrec ()
+ ;; Test that simple cases of `letrec' get optimized back to `let*'.
+ (should (equal (macroexpand '(letrec ((subr-tests-var1 1)
+ (subr-tests-var2 subr-tests-var1))
+ (+ subr-tests-var1 subr-tests-var2)))
+ '(let* ((subr-tests-var1 1)
+ (subr-tests-var2 subr-tests-var1))
+ (+ subr-tests-var1 subr-tests-var2)))))
+
(defvar subr-tests--hook nil)
(ert-deftest subr-tests-add-hook-depth ()
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- master 3b9dad8: * lisp/subr.el (letrec): Optimize some non-recursive bindings,
Stefan Monnier <=