From 768a35279388106f83842b7e029aa4a61b142df2 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 8 Jan 2021 17:57:26 -0500 Subject: * lisp/emacs-lisp/macroexp.el (macroexp--fgrep): Rename from `pcase--fgrep` * lisp/emacs-lisp/cl-generic.el (cl--generic-fgrep): Delete. (cl--generic-lambda): Use `macroexp--pacse` instead. * lisp/emacs-lisp/pcase.el (pcase--fgrep): Rename to `macroexp--fgrep`. --- lisp/emacs-lisp/macroexp.el | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 82a8cd2d777..d5fda528b4f 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -480,6 +480,35 @@ itself or not." v (list 'quote v))) +(defun macroexp--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP. +It is used as a poor-man's \"free variables\" test. It differs from a true +test of free variables in the following ways: +- It does not distinguish variables from functions, so it can be used + both to detect whether a given variable is used by SEXP and to + detect whether a given function is used by SEXP. +- It does not actually know ELisp syntax, so it only looks for the presence + of symbols in SEXP and can't distinguish if those symbols are truly + references to the given variable (or function). That can make the result + include bindings which actually aren't used. +- For the same reason it may cause the result to fail to include bindings + which will be used if SEXP is not yet fully macro-expanded and the + use of the binding will only be revealed by macro expansion." + (let ((res '())) + (while (and (consp sexp) bindings) + (dolist (binding (macroexp--fgrep bindings (pop sexp))) + (push binding res) + (setq bindings (remove binding bindings)))) + (if (vectorp sexp) + ;; With backquote, code can appear within vectors as well. + ;; This wouldn't be needed if we `macroexpand-all' before + ;; calling macroexp--fgrep, OTOH. + (macroexp--fgrep bindings (mapcar #'identity sexp)) + (let ((tmp (assq sexp bindings))) + (if tmp + (cons tmp res) + res))))) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion -- cgit v1.2.3 From 3b9dad88e02f05773c599808266febf3e4128222 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 8 Jan 2021 18:44:13 -0500 Subject: * 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(-) (limited to 'lisp/emacs-lisp/macroexp.el') diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index d5fda528b4f..37844977f8f 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 b92744cdcbe..bc0c4179904 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 446983c2e3e..7774ed3145b 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 21185303360..e0826208b60 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 () -- cgit v1.2.3