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

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

[Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors]

[-- Attachment #1: Type: text/plain, Size: 624 bytes --]

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'


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Ffunction-Make-interpreted-closures-safe-for-space.patch --]
[-- Type: text/patch, Size: 18422 bytes --]

From 01919211ed84c0459d87b52c0488e07457194b2b Mon Sep 17 00:00:00 2001
From: Stefan Monnier <monnier@iro.umontreal.ca>
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

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

[Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors]

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

Pushed to `master`,


        Stefan