master 1b1ffe0789: (Ffunction): Make interpreted closures safe for space

[Stefan Monnier]

branch: master
commit 1b1ffe07897ebe06cf96ab423fad3cde9fd6c981
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    (Ffunction): Make interpreted closures safe for space
    
    Interpreted closures currently just grab a reference to the complete
    lexical environment, so (lambda (x) (+ x y)) can end up looking like
    
        (closure ((foo ...) (y 7) (bar ...) ...)
                 (x) (+ x y))
    
    where the foo/bar/... bindings are not only useless but can prevent
    the GC from collecting that memory (i.e. it's a representation that is
    not "safe for space") and it can also make that closure "unwritable"
    (or more specifically, it can cause the closure's print
    representation to be u`read`able).
    
    Compiled closures don't suffer from this problem because `cconv.el`
    actually looks at the code and only stores in the compiled closure
    those variables which are actually used.
    
    So, we fix this discrepancy by letting the existing code in `cconv.el` tell
    `Ffunction` which variables are actually used by the body of the
    function such that it can filter out the irrelevant elements and
    return a closure of the form:
    
        (closure ((y 7)) (x) (+ x y))
    
    * lisp/loadup.el: Preload `cconv` and set
    `internal-filter-closure-env-function` once we have a usable `cconv-fv`.
    
    * lisp/emacs-lisp/bytecomp.el (byte-compile-preprocess): Adjust to new
    calling convention of `cconv-closure-convert`.
    (byte-compile-not-lexical-var-p): Delete function, moved to `cconv.el`.
    (byte-compile-bind): Use `cconv--not-lexical-var-p`.
    
    * lisp/emacs-lisp/cconv.el (cconv--dynbound-variables): New var.
    (cconv-closure-convert): New arg `dynbound-vars`
    (cconv--warn-unused-msg): Remove special case for `ignored`,
    so we don't get confused when a function uses an argument called
    `ignored`, e.g. holding a list of things that it should ignore.
    (cconv--not-lexical-var-p): New function, moved from `bytecomp.el`.
    Don't special case keywords and `nil` and `t` since they are already
    `special-variable-p`.
    (cconv--analyze-function): Use `cconv--not-lexical-var-p`.
    (cconv--dynbindings): New dynbound var.
    (cconv-analyze-form): Use `cconv--not-lexical-var-p`.
    Remember in `cconv--dynbindings` the vars for which we used
    dynamic scoping.
    (cconv-analyze-form): Use `cconv--dynbound-variables` rather than
    `byte-compile-bound-variables`.
    (cconv-fv): New function.
    
    * src/eval.c (Fsetq, eval_sub): Remove optimization designed when
    `lexical-binding == nil` was the common case.
    (Ffunction): Use `internal-filter-closure-env-function` when available.
    (eval_sub, Ffuncall): Improve error info for `excessive_lisp_nesting`.
    (internal-filter-closure-env-function): New defvar.
---
 doc/lispref/variables.texi  |   2 +-
 etc/NEWS                    |   9 ++++
 lisp/emacs-lisp/bytecomp.el |  11 +---
 lisp/emacs-lisp/cconv.el    | 119 +++++++++++++++++++++++++++-----------------
 lisp/loadup.el              |   4 ++
 src/eval.c                  |  27 ++++++----
 6 files changed, 107 insertions(+), 65 deletions(-)

diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi
index cbe276b2dc..7206f2acd2 100644
--- a/doc/lispref/variables.texi
+++ b/doc/lispref/variables.texi
@@ -1183,7 +1183,7 @@ Here is an example:
 (let ((x 0))             ; @r{@code{x} is lexically bound.}
   (setq my-ticker (lambda ()
                     (setq x (1+ x)))))
-    @result{} (closure ((x . 0) t) ()
+    @result{} (closure ((x . 0)) ()
           (setq x (1+ x)))
 
 (funcall my-ticker)
diff --git a/etc/NEWS b/etc/NEWS
index 6622f2d4ad..cbbf90fde6 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -3171,6 +3171,15 @@ The following generalized variables have been made 
obsolete:
 
 * Lisp Changes in Emacs 29.1
 
++++
+** Interpreted closures are "safe for space".
+As was already the case for byte-compiled closures, instead of capturing
+the whole current lexical environment, interpreted closures now only
+capture the part of the environment that they need.
+The previous behavior could occasionally lead to memory leaks or
+to problems where a printed closure would not be 'read'able because
+of an un'read'able value in an unrelated lexical variable.
+
 +++
 ** New accessor function 'file-attribute-file-identifier'.
 It returns the list of the inode number and device identifier
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index f026568217..9f29ffbb8e 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2565,7 +2565,7 @@ list that represents a doc string reference.
   ;; macroexpand-all.
   ;; (if (memq byte-optimize '(t source))
   ;;     (setq form (byte-optimize-form form for-effect)))
-  (cconv-closure-convert form))
+  (cconv-closure-convert form byte-compile-bound-variables))
 
 ;; byte-hunk-handlers cannot call this!
 (defun byte-compile-toplevel-file-form (top-level-form)
@@ -4663,13 +4663,6 @@ Return the offset in the form (VAR . OFFSET)."
           (byte-compile-form (cadr clause))
         (byte-compile-push-constant nil)))))
 
-(defun byte-compile-not-lexical-var-p (var)
-  (or (not (symbolp var))
-      (special-variable-p var)
-      (memq var byte-compile-bound-variables)
-      (memq var '(nil t))
-      (keywordp var)))
-
 (defun byte-compile-bind (var init-lexenv)
   "Emit byte-codes to bind VAR and update `byte-compile--lexical-environment'.
 INIT-LEXENV should be a lexical-environment alist describing the
@@ -4678,7 +4671,7 @@ Return non-nil if the TOS value was popped."
   ;; The mix of lexical and dynamic bindings mean that we may have to
   ;; juggle things on the stack, to move them to TOS for
   ;; dynamic binding.
-  (if (and lexical-binding (not (byte-compile-not-lexical-var-p var)))
+  (if (not (cconv--not-lexical-var-p var byte-compile-bound-variables))
       ;; VAR is a simple stack-allocated lexical variable.
       (progn (push (assq var init-lexenv)
                    byte-compile--lexical-environment)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 23d0f12194..3f27faab11 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -64,20 +64,12 @@
 ;;
 ;;; Code:
 
-;; PROBLEM cases found during conversion to lexical binding.
-;; We should try and detect and warn about those cases, even
-;; for lexical-binding==nil to help prepare the migration.
-;; - Uses of run-hooks, and friends.
-;; - Cases where we want to apply the same code to different vars depending on
-;;   some test.  These sometimes use a (let ((foo (if bar 'a 'b)))
-;;   ... (symbol-value foo) ... (set foo ...)).
-
 ;; TODO: (not just for cconv but also for the lexbind changes in general)
 ;; - let (e)debug find the value of lexical variables from the stack.
 ;; - make eval-region do the eval-sexp-add-defvars dance.
 ;; - byte-optimize-form should be applied before cconv.
 ;;   OTOH, the warnings emitted by cconv-analyze need to come before optimize
-;;   since afterwards they can because obnoxious (warnings about an "unused
+;;   since afterwards they can become obnoxious (warnings about an "unused
 ;;   variable" should not be emitted when the variable use has simply been
 ;;   optimized away).
 ;; - let macros specify that some let-bindings come from the same source,
@@ -87,33 +79,9 @@
 ;; - canonize code in macro-expand so we don't have to handle (let (var) body)
 ;;   and other oddities.
 ;; - new byte codes for unwind-protect so that closures aren't needed at all.
-;; - a reference to a var that is known statically to always hold a constant
-;;   should be turned into a byte-constant rather than a byte-stack-ref.
-;;   Hmm... right, that's called constant propagation and could be done here,
-;;   but when that constant is a function, we have to be careful to make sure
-;;   the bytecomp only compiles it once.
 ;; - Since we know here when a variable is not mutated, we could pass that
 ;;   info to the byte-compiler, e.g. by using a new `immutable-let'.
 ;; - call known non-escaping functions with `goto' rather than `call'.
-;; - optimize mapc to a dolist loop.
-
-;; (defmacro dlet (binders &rest body)
-;;   ;; Works in both lexical and non-lexical mode.
-;;   (declare (indent 1) (debug let))
-;;   `(progn
-;;      ,@(mapcar (lambda (binder)
-;;                  `(defvar ,(if (consp binder) (car binder) binder)))
-;;                binders)
-;;      (let ,binders ,@body)))
-
-;; (defmacro llet (binders &rest body)
-;;   ;; Only works in lexical-binding mode.
-;;   `(funcall
-;;     (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) 
binder))
-;;                 binders)
-;;       ,@body)
-;;     ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
-;;               binders)))
 
 (eval-when-compile (require 'cl-lib))
 
@@ -142,13 +110,19 @@ is less than this number.")
   ;; interactive forms.
   (make-hash-table :test #'eq :weakness 'key))
 
+(defvar cconv--dynbound-variables nil
+  "List of variables known to be dynamically bound.")
+
 ;;;###autoload
-(defun cconv-closure-convert (form)
+(defun cconv-closure-convert (form &optional dynbound-vars)
   "Main entry point for closure conversion.
 FORM is a piece of Elisp code after macroexpansion.
+DYNBOUND-VARS is a list of symbols that should be considered as
+using dynamic scoping.
 
 Returns a form where all lambdas don't have any free variables."
-  (let ((cconv-freevars-alist '())
+  (let ((cconv--dynbound-variables dynbound-vars)
+       (cconv-freevars-alist '())
        (cconv-var-classification '()))
     ;; Analyze form - fill these variables with new information.
     (cconv-analyze-form form '())
@@ -262,9 +236,7 @@ Returns a form where all lambdas don't have any free 
variables."
               ;; it is often non-trivial for the programmer to avoid such
               ;; unused vars.
               (not (intern-soft var))
-              (eq ?_ (aref (symbol-name var) 0))
-             ;; As a special exception, ignore "ignored".
-             (eq var 'ignored))
+              (eq ?_ (aref (symbol-name var) 0)))
        (let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
          (format "Unused lexical %s `%S'%s"
                  varkind (bare-symbol var)
@@ -342,7 +314,7 @@ EXTEND is a list of variables which might need to be 
accessed even from places
 where they are shadowed, because some part of ENV causes them to be used at
 places where they originally did not directly appear."
   (cl-assert (not (delq nil (mapcar (lambda (mapping)
-                                      (if (eq (cadr mapping) 'apply-partially)
+                                      (if (eq (cadr mapping) #'apply-partially)
                                           (cconv--set-diff (cdr (cddr mapping))
                                                            extend)))
                                     env))))
@@ -634,6 +606,12 @@ places where they originally did not directly appear."
 
 (defvar byte-compile-lexical-variables)
 
+(defun cconv--not-lexical-var-p (var dynbounds)
+  (or (not lexical-binding)
+      (not (symbolp var))
+      (special-variable-p var)
+      (memq var dynbounds)))
+
 (defun cconv--analyze-use (vardata form varkind)
   "Analyze the use of a variable.
 VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
@@ -677,7 +655,7 @@ FORM is the parent form that binds this var."
          ;; outside of it.
          (envcopy
           (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
-         (byte-compile-bound-variables byte-compile-bound-variables)
+         (cconv--dynbound-variables cconv--dynbound-variables)
          (newenv envcopy))
     ;; Push it before recursing, so cconv-freevars-alist contains entries in
     ;; the order they'll be used by closure-convert-rec.
@@ -685,7 +663,7 @@ FORM is the parent form that binds this var."
     (when lexical-binding
       (dolist (arg args)
         (cond
-         ((byte-compile-not-lexical-var-p arg)
+         ((cconv--not-lexical-var-p arg cconv--dynbound-variables)
           (byte-compile-warn-x
            arg
            "Lexical argument shadows the dynamic variable %S"
@@ -715,6 +693,8 @@ FORM is the parent form that binds this var."
           (setf (nth 3 (car env)) t))
         (setq env (cdr env) envcopy (cdr envcopy))))))
 
+(defvar cconv--dynbindings)
+
 (defun cconv-analyze-form (form env)
   "Find mutated variables and variables captured by closure.
 Analyze lambdas if they are suitable for lambda lifting.
@@ -730,7 +710,7 @@ This function does not return anything but instead fills the
      (let ((orig-env env)
            (newvars nil)
            (var nil)
-           (byte-compile-bound-variables byte-compile-bound-variables)
+           (cconv--dynbound-variables cconv--dynbound-variables)
            (value nil))
        (dolist (binder binders)
          (if (not (consp binder))
@@ -743,7 +723,9 @@ This function does not return anything but instead fills the
 
            (cconv-analyze-form value (if (eq letsym 'let*) env orig-env)))
 
-         (unless (or (byte-compile-not-lexical-var-p var) (not 
lexical-binding))
+         (if (cconv--not-lexical-var-p var cconv--dynbound-variables)
+             (when (boundp 'cconv--dynbindings)
+               (push var cconv--dynbindings))
            (cl-pushnew var byte-compile-lexical-variables)
            (let ((varstruct (list var nil nil nil nil)))
              (push (cons binder (cdr varstruct)) newvars)
@@ -797,7 +779,8 @@ This function does not return anything but instead fills the
      (cconv-analyze-form protected-form env)
      (unless lexical-binding
        (setq var nil))
-     (when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
+     (when (and var (symbolp var)
+                (cconv--not-lexical-var-p var cconv--dynbound-variables))
        (byte-compile-warn-x
         var "Lexical variable shadows the dynamic variable %S" var))
      (let* ((varstruct (list var nil nil nil nil)))
@@ -813,9 +796,9 @@ This function does not return anything but instead fills the
      (cconv-analyze-form form env)
      (cconv--analyze-function () body env form))
 
-    (`(defvar ,var) (push var byte-compile-bound-variables))
+    (`(defvar ,var) (push var cconv--dynbound-variables))
     (`(,(or 'defconst 'defvar) ,var ,value . ,_)
-     (push var byte-compile-bound-variables)
+     (push var cconv--dynbound-variables)
      (cconv-analyze-form value env))
 
     (`(,(or 'funcall 'apply) ,fun . ,args)
@@ -847,5 +830,49 @@ This function does not return anything but instead fills 
the
          (setf (nth 1 dv) t))))))
 (define-obsolete-function-alias 'cconv-analyse-form #'cconv-analyze-form 
"25.1")
 
+(defun cconv-fv (form env &optional no-macroexpand)
+  "Return the list of free variables in FORM.
+ENV is the lexical environment from which the variables can be taken.
+It should be a list of pairs of the form (VAR . VAL).
+The return value is a list of those (VAR . VAL) bindings,
+in the same order as they appear in ENV.
+If NO-MACROEXPAND is non-nil, we do not macro-expand FORM,
+which means that the result may be incorrect if there are non-expanded
+macro calls in FORM."
+  (let* ((fun `#'(lambda () ,form))
+         ;; Make dummy bindings to avoid warnings about the var being
+         ;; left uninitialized.
+         (analysis-env
+          (delq nil (mapcar (lambda (b) (if (consp b)
+                                       (list (car b) nil nil nil nil)))
+                            env)))
+         (cconv--dynbound-variables
+          (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env)))
+         (byte-compile-lexical-variables nil)
+         (cconv--dynbindings nil)
+         (cconv-freevars-alist '())
+        (cconv-var-classification '()))
+    (if (null analysis-env)
+        ;; The lexical environment is empty, so there's no need to
+        ;; look for free variables.
+        env
+      (let* ((fun (if no-macroexpand fun
+                    (macroexpand-all fun macroexpand-all-environment)))
+             (body (cddr (cadr fun))))
+        ;; Analyze form - fill these variables with new information.
+        (cconv-analyze-form fun analysis-env)
+        (setq cconv-freevars-alist (nreverse cconv-freevars-alist))
+        (cl-assert (equal (if (eq :documentation (car-safe (car body)))
+                              (cdr body) body)
+                          (caar cconv-freevars-alist)))
+        (let ((fvs (nreverse (cdar cconv-freevars-alist)))
+              (dyns (mapcar (lambda (var) (car (memq var env)))
+                            (delete-dups cconv--dynbindings))))
+          (or (nconc (mapcar (lambda (fv) (assq fv env)) fvs)
+                     (delq nil dyns))
+              ;; Never return nil, since nil means to use the dynbind
+              ;; dialect of ELisp.
+              '(t)))))))
+
 (provide 'cconv)
 ;;; cconv.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index e940a32100..63806ae456 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -366,6 +366,10 @@
 (load "emacs-lisp/shorthands")
 
 (load "emacs-lisp/eldoc")
+(load "emacs-lisp/cconv")
+(when (and (byte-code-function-p (symbol-function 'cconv-fv))
+           (byte-code-function-p (symbol-function 'macroexpand-all)))
+  (setq internal-filter-closure-env-function #'cconv-fv))
 (load "cus-start") ;Late to reduce customize-rogue (needs loaddefs.el anyway)
 (if (not (eq system-type 'ms-dos))
     (load "tooltip"))
diff --git a/src/eval.c b/src/eval.c
index 8810136c04..d2cab006d1 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -484,8 +484,7 @@ usage: (setq [SYM VAL]...)  */)
       /* Like for eval_sub, we do not check declared_special here since
         it's been done when let-binding.  */
       Lisp_Object lex_binding
-       = ((!NILP (Vinternal_interpreter_environment) /* Mere optimization!  */
-           && SYMBOLP (sym))
+       = (SYMBOLP (sym)
           ? Fassq (sym, Vinternal_interpreter_environment)
           : Qnil);
       if (!NILP (lex_binding))
@@ -551,8 +550,15 @@ usage: (function ARG)  */)
          CHECK_STRING (docstring);
          cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (cdr))));
        }
-      return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
-                                    cdr));
+      Lisp_Object env
+        = NILP (Vinternal_filter_closure_env_function)
+          ? Vinternal_interpreter_environment
+          /* FIXME: This macroexpands the body, so we should use the resulting
+             macroexpanded code!  */
+          : call2 (Vinternal_filter_closure_env_function,
+                   Fcons (Qprogn, CONSP (cdr) ? XCDR (cdr) : cdr),
+                   Vinternal_interpreter_environment);
+      return Fcons (Qclosure, Fcons (env, cdr));
     }
   else
     /* Simply quote the argument.  */
@@ -2374,9 +2380,7 @@ eval_sub (Lisp_Object form)
         We do not pay attention to the declared_special flag here, since we
         already did that when let-binding the variable.  */
       Lisp_Object lex_binding
-       = (!NILP (Vinternal_interpreter_environment) /* Mere optimization!  */
-          ? Fassq (form, Vinternal_interpreter_environment)
-          : Qnil);
+       = Fassq (form, Vinternal_interpreter_environment);
       return !NILP (lex_binding) ? XCDR (lex_binding) : Fsymbol_value (form);
     }
 
@@ -2392,7 +2396,7 @@ eval_sub (Lisp_Object form)
       if (max_lisp_eval_depth < 100)
        max_lisp_eval_depth = 100;
       if (lisp_eval_depth > max_lisp_eval_depth)
-       xsignal0 (Qexcessive_lisp_nesting);
+       xsignal1 (Qexcessive_lisp_nesting, make_fixnum (lisp_eval_depth));
     }
 
   Lisp_Object original_fun = XCAR (form);
@@ -2966,7 +2970,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS)  */)
       if (max_lisp_eval_depth < 100)
        max_lisp_eval_depth = 100;
       if (lisp_eval_depth > max_lisp_eval_depth)
-       xsignal0 (Qexcessive_lisp_nesting);
+       xsignal1 (Qexcessive_lisp_nesting, make_fixnum (lisp_eval_depth));
     }
 
   count = record_in_backtrace (args[0], &args[1], nargs - 1);
@@ -4357,6 +4361,11 @@ alist of active lexical bindings.  */);
      (Just imagine if someone makes it buffer-local).  */
   Funintern (Qinternal_interpreter_environment, Qnil);
 
+  DEFVAR_LISP ("internal-filter-closure-env-function",
+              Vinternal_filter_closure_env_function,
+              doc: /* Function to filter the env when constructing a closure.  
*/);
+  Vinternal_filter_closure_env_function = Qnil;
+
   Vrun_hooks = intern_c_string ("run-hooks");
   staticpro (&Vrun_hooks);