>From 01919211ed84c0459d87b52c0488e07457194b2b Mon Sep 17 00:00:00 2001 From: Stefan Monnier 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