Subject: bug#58592: closed (Re: bug#58592: [PATCH] (Ffunction): Make interpreted closures safe for space)

From: [email-masked] (GNU bug Tracking System)
Date: Tue, 25 Oct 2022 18:28:01 +0000

Your bug report

#58592: [PATCH] (Ffunction): Make interpreted closures safe for space

which was filed against the emacs package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
58592: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=58592
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#58592: [PATCH] (Ffunction): Make interpreted closures safe for space
From: Stefan Monnier <[email-masked]>
To: [email-masked]
Date: Tue, 25 Oct 2022 14:27:11 -0400
List-Id: <debbugs-submit.debbugs.gnu.org>

Stefan Monnier [2022-10-17 17:12:42] wrote:
> See the commit message for explanations.

Pushed to `master`,

        Stefan

Subject: [PATCH] (Ffunction): Make interpreted closures safe for space
From: Stefan Monnier <[email-masked]>
To: [email-masked]
Date: Mon, 17 Oct 2022 17:12:42 -0400
List-Id: <debbugs-submit.debbugs.gnu.org>

Tags: patch

See the commit message for explanations.

 In GNU Emacs 29.0.50 (build 1, x86_64-pc-linux-gnux32, GTK+ Version
 3.24.34, cairo version 1.16.0) of 2022-09-30 built on alfajor
Repository revision: 4e10f8f784909da61311b4dcdb3b673a7b886c41
Repository branch: work
Windowing system distributor 'The X.Org Foundation', version 11.0.12101003
System Description: Debian GNU/Linux bookworm/sid

Configured using:
 'configure -C --enable-checking --enable-check-lisp-object-type --with-modules --with-cairo --with-tiff=ifavailable
 'CFLAGS=-Wall -g3 -Og -Wno-pointer-sign'
 PKG_CONFIG_PATH=/home/monnier/lib/pkgconfig'

>From 01919211ed84c0459d87b52c0488e07457194b2b Mon Sep 17 00:00:00 2001
From: Stefan Monnier <[email-masked]>
Date: Mon, 17 Oct 2022 17:11:40 -0400
Subject: [PATCH] (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.
---
 lisp/emacs-lisp/bytecomp.el |  11 +---
 lisp/emacs-lisp/cconv.el    | 116 ++++++++++++++++++++++--------------
 lisp/loadup.el              |   4 ++
 src/eval.c                  |  27 ++++++---
 4 files changed, 94 insertions(+), 64 deletions(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 692a87f6d57..fa201f1345c 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2569,7 +2569,7 @@ byte-compile-preprocess
   ;; 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)
@@ -4667,13 +4667,6 @@ byte-compile-push-binding-init
           (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
@@ -4682,7 +4675,7 @@ byte-compile-bind
   ;; 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 23d0f121948..e598e395281 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 @@ cconv--interactive-form-funs
   ;; 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 @@ cconv--warn-unused-msg
               ;; 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 @@ cconv-convert
 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 @@ cconv-convert
 
 (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 @@ cconv--analyze-function
          ;; 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 @@ cconv--analyze-function
     (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 @@ cconv--analyze-function
           (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 @@ cconv-analyze-form
      (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 @@ cconv-analyze-form
 
            (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 @@ cconv-analyze-form
      (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 @@ cconv-analyze-form
      (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,46 @@ cconv-analyze-form
          (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))))
+          (nconc (mapcar (lambda (fv) (assq fv env)) fvs)
+                 (delq nil dyns)))))))
+
 (provide 'cconv)
 ;;; cconv.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index e940a32100c..63806ae4565 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 8810136c041..d2cab006d11 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -484,8 +484,7 @@ DEFUN ("setq", Fsetq, Ssetq, 0, UNEVALLED, 0,
       /* 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 @@ DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0,
 	  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 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
       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 @@ syms_of_eval (void)
      (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);
 
-- 
2.35.1