From: Stefan Monnier Date: Fri, 28 Oct 2022 15:33:24 +0000 (-0400) Subject: cconv.el: Fix regression in cconv-tests-interactive-closure-bug51695 X-Git-Tag: emacs-29.0.90~1616^2~418 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=d79cdcd4ff6687c2f0dcfde83ba36732408e52e8;p=emacs.git cconv.el: Fix regression in cconv-tests-interactive-closure-bug51695 The new code to make interpreted closures safe-for-space introduced a regression in `cconv-tests-interactive-closure-bug51695`, only seen when using TEST_LOAD_EL. A few other issues were found and fixed along the way. * lisp/emacs-lisp/cconv.el (cconv-fv): Change calling convention and focus on finding the free variables. (cconv-make-interpreted-closure): New function. * lisp/loadup.el: Use `compiled-function-p` rather than `byte-code-function-p` so we also use safe-for-space interpreted closures when we build with native compilation. (internal-make-interpreted-closure-function): Use `cconv-make-interpreted-closure`. * src/eval.c (syms_of_eval): Rename `internal-filter-closure-env-function` to `internal-make-interpreted-closure-function`. (Ffunction): Let that new var build the actual closure. * test/lisp/emacs-lisp/cconv-tests.el (cconv-tests-interactive-closure-bug51695): Test specifically the interpreted case. --- diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 289e2b0eee4..f3431db4156 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -828,49 +828,78 @@ 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) +(defun cconv-fv (form lexvars dynvars) "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))) +LEXVARS is the list of statically scoped vars in the context +and DYNVARS is the list of dynamically scoped vars in the context. +Returns a pair (LEXV . DYNV) of those vars actually used by FORM." + (let* ((fun + ;; Wrap FORM into a function because the analysis code we + ;; have only computes freevars for functions. + ;; In practice FORM is always already of the form + ;; #'(lambda ...), so optimize for this case. + (if (and (eq 'function (car-safe form)) + (eq 'lambda (car-safe (cadr form))) + ;; To get correct results, FUN needs to be a "simple lambda" + ;; without nested forms that aren't part of the body. :-( + (not (assq 'interactive (cadr form))) + (not (assq ':documentation (cadr form)))) + form + `#'(lambda () ,form))) + (analysis-env (mapcar (lambda (v) (list v nil nil nil nil)) lexvars)) + (cconv--dynbound-variables dynvars) (byte-compile-lexical-variables nil) (cconv--dynbindings nil) (cconv-freevars-alist '()) (cconv-var-classification '())) - (if (null analysis-env) + (let* ((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)) + (unless (equal (if (eq :documentation (car-safe (car body))) + (cdr body) body) + (caar cconv-freevars-alist)) + (message "BOOH!\n%S\n%S" + body (caar 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 (delq nil (mapcar (lambda (var) (car (memq var dynvars))) + (delete-dups cconv--dynbindings))))) + (cons fvs dyns))))) + +(defun cconv-make-interpreted-closure (fun env) + (cl-assert (eq (car-safe fun) 'lambda)) + (let ((lexvars (delq nil (mapcar #'car-safe env)))) + (if (null lexvars) ;; 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))))))) + `(closure ,env . ,(cdr fun)) + ;; We could try and cache the result of the macroexpansion and + ;; `cconv-fv' analysis. Not sure it's worth the trouble. + (let* ((form `#',fun) + (expanded-form + (let ((lexical-binding t) ;; Tell macros which dialect is in use. + ;; Make the macro aware of any defvar declarations in scope. + (macroexp--dynvars + (if macroexp--dynvars + (append env macroexp--dynvars) env))) + (macroexpand-all form macroexpand-all-environment))) + ;; Since we macroexpanded the body, we may as well use that. + (expanded-fun-cdr + (pcase expanded-form + (`#'(lambda . ,cdr) cdr) + (_ (cdr fun)))) + + (dynvars (delq nil (mapcar (lambda (b) (if (symbolp b) b)) env))) + (fvs (cconv-fv expanded-form lexvars dynvars)) + (newenv (nconc (mapcar (lambda (fv) (assq fv env)) (car fvs)) + (cdr fvs)))) + ;; Never return a nil env, since nil means to use the dynbind + ;; dialect of ELisp. + `(closure ,(or newenv '(t)) . ,expanded-fun-cdr))))) + (provide 'cconv) ;;; cconv.el ends here diff --git a/lisp/loadup.el b/lisp/loadup.el index 63806ae4565..2a9aff4c1fe 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -367,9 +367,10 @@ (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)) +(when (and (compiled-function-p (symbol-function 'cconv-fv)) + (compiled-function-p (symbol-function 'macroexpand-all))) + (setq internal-make-interpreted-closure-function + #'cconv-make-interpreted-closure)) (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 d2cab006d11..2928a45ac1e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -550,15 +550,12 @@ usage: (function ARG) */) CHECK_STRING (docstring); cdr = Fcons (XCAR (cdr), Fcons (docstring, XCDR (XCDR (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)); + if (NILP (Vinternal_make_interpreted_closure_function)) + return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, cdr)); + else + return call2 (Vinternal_make_interpreted_closure_function, + Fcons (Qlambda, cdr), + Vinternal_interpreter_environment); } else /* Simply quote the argument. */ @@ -4361,10 +4358,10 @@ 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, + DEFVAR_LISP ("internal-make-interpreted-closure-function", + Vinternal_make_interpreted_closure_function, doc: /* Function to filter the env when constructing a closure. */); - Vinternal_filter_closure_env_function = Qnil; + Vinternal_make_interpreted_closure_function = Qnil; Vrun_hooks = intern_c_string ("run-hooks"); staticpro (&Vrun_hooks); diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 37470f863f3..e666fe0a4c2 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -351,11 +351,18 @@ (let ((f (let ((d 51695)) (lambda (data) (interactive (progn (setq d (1+ d)) (list d))) - (list (called-interactively-p 'any) data))))) - (should (equal (list (call-interactively f) - (funcall f 51695) - (call-interactively f)) - '((t 51696) (nil 51695) (t 51697)))))) + (list (called-interactively-p 'any) data)))) + (f-interp + (eval '(let ((d 51695)) + (lambda (data) + (interactive (progn (setq d (1+ d)) (list d))) + (list (called-interactively-p 'any) data))) + t))) + (dolist (f (list f f-interp)) + (should (equal (list (call-interactively f) + (funcall f 51695) + (call-interactively f)) + '((t 51696) (nil 51695) (t 51697))))))) (provide 'cconv-tests) ;;; cconv-tests.el ends here