From 787444c7690d97d8702db059cb51ac506cb8a5e4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Nov 2019 18:01:00 +0100 Subject: fix max depth compilation --- src/eval.c | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index 4559a0e1f66..bf37ed9cefa 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,8 +219,14 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ +#ifndef HAVE_NATIVE_COMP max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ max_lisp_eval_depth = 800; +#else + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; +#endif Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } -- cgit v1.2.3 From ef59b67e4657fa80d1528b9d476c67f01abecc35 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 24 Dec 2019 17:41:44 +0100 Subject: mitigate ifdef proliferation --- src/alloc.c | 17 +++++------------ src/comp.c | 2 +- src/comp.h | 10 ++++++++++ src/data.c | 5 ++--- src/doc.c | 2 -- src/eval.c | 19 +++++++++++-------- src/lisp.h | 15 ++++++++++----- src/lread.c | 32 +++++++++++++++----------------- src/pdumper.c | 21 ++++++--------------- 9 files changed, 60 insertions(+), 63 deletions(-) (limited to 'src/eval.c') diff --git a/src/alloc.c b/src/alloc.c index 5e0b04b1cc7..6d6f6934bab 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3023,15 +3023,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } -#ifdef HAVE_NATIVE_COMP - else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); eassert (cu->handle); dynlib_close (cu->handle); } -#endif } /* Reclaim space used by unmarked vectors. */ @@ -6565,14 +6564,12 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); - mark_object (subr->native_comp_u); + mark_object (subr->native_comp_u[0]); } -#endif break; case PVEC_FREE: @@ -6717,13 +6714,9 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: -#ifdef HAVE_NATIVE_COMP survives_p = (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); -#else - survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); -#endif break; case Lisp_Cons: @@ -7473,14 +7466,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", {0}, {0}, 0}}; + 4, 4, "watch_gc_cons_threshold", {0}, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", {0}, {0}, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, {0}}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c index 87986abee68..6f5658191c0 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3285,7 +3285,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); x->s.native_intspec = intspec; x->s.native_doc = doc; - x->s.native_comp_u = comp_u; + x->s.native_comp_u[0] = comp_u; Lisp_Object tem; XSETSUBR (tem, &x->s); set_symbol_function (name, tem); diff --git a/src/comp.h b/src/comp.h index 90b4f40426b..f756e38d292 100644 --- a/src/comp.h +++ b/src/comp.h @@ -19,6 +19,16 @@ along with GNU Emacs. If not, see . */ #ifndef COMP_H #define COMP_H +/* To keep ifdefs under control. */ +enum { + NATIVE_COMP_FLAG = +#ifdef HAVE_NATIVE_COMP + 1 +#else + 0 +#endif +}; + #ifdef HAVE_NATIVE_COMP #include diff --git a/src/data.c b/src/data.c index 3fb0fc0a190..d20db4dc3a3 100644 --- a/src/data.c +++ b/src/data.c @@ -881,7 +881,7 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, (Lisp_Object subr) { CHECK_SUBR (subr); - return XSUBR (subr)->native_comp_u; + return XSUBR (subr)->native_comp_u[0]; } DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, @@ -919,10 +919,9 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { -#ifdef HAVE_NATIVE_COMP if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; -#endif + const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, diff --git a/src/doc.c b/src/doc.c index 9e1d8392787..2c96fc15a7c 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,12 +510,10 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } -#ifdef HAVE_NATIVE_COMP else if (SUBRP_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } -#endif /* Lisp_Subrs have a slot for it. */ else if (SUBRP (fun)) { diff --git a/src/eval.c b/src/eval.c index bf37ed9cefa..253de05a658 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,14 +219,17 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ -#ifndef HAVE_NATIVE_COMP - max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ - max_lisp_eval_depth = 800; -#else - /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; -#endif + if (!NATIVE_COMP_FLAG) + { + max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ + max_lisp_eval_depth = 800; + } + else + { + /* Original values increased for comp.el. */ + max_specpdl_size = 2100; + max_lisp_eval_depth = 1400; + } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } diff --git a/src/lisp.h b/src/lisp.h index c7e55057ad3..a4cabc34855 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2098,9 +2098,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_doc; }; -#ifdef HAVE_NATIVE_COMP - Lisp_Object native_comp_u; -#endif + Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3113,7 +3111,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, {intspec}, {0}, 0}}; \ + minargs, maxargs, lname, {intspec}, {0}}}; \ Lisp_Object fnname /* defsubr (Sname); @@ -4763,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBRP_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u; + return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } INLINE struct Lisp_Native_Comp_Unit * @@ -4772,6 +4770,13 @@ allocate_native_comp_unit (void) return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, data_vec, PVEC_NATIVE_COMP_UNIT); } +#else +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/lread.c b/src/lread.c index 4e8a3adeb94..1c5268d0dad 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1281,11 +1281,9 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif -#ifdef HAVE_NATIVE_COMP - bool is_native_elisp = suffix_p (found, NATIVE_ELISP_SUFFIX); -#else - bool is_native_elisp = false; -#endif + bool is_native_elisp = + NATIVE_COMP_FLAG && suffix_p (found, NATIVE_ELISP_SUFFIX) ? true : false; + /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1486,15 +1484,16 @@ Return t if the file exists and loads successfully. */) } else if (is_native_elisp) { -#ifdef HAVE_NATIVE_COMP - specbind (Qcurrent_load_list, Qnil); - LOADHIST_ATTACH (found); - Fnative_elisp_load (found); - build_load_history (found, true); -#else - /* This cannot happen. */ - emacs_abort (); -#endif + if (NATIVE_COMP_FLAG) + { + specbind (Qcurrent_load_list, Qnil); + LOADHIST_ATTACH (found); + Fnative_elisp_load (found); + build_load_history (found, true); + } + else + /* This cannot happen. */ + emacs_abort (); } else { @@ -4465,9 +4464,8 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); -#ifdef HAVE_NATIVE_COMP - Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); -#endif /* HAVE_NATIVE_COMP */ + if (NATIVE_COMP_FLAG) + Vcomp_subr_list = Fcons (tem, Vcomp_subr_list); } #ifdef NOTDEF /* Use fset in subr.el now! */ diff --git a/src/pdumper.c b/src/pdumper.c index 610b94b0a32..d66c4e99642 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,18 +2948,13 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) out.function.a0 = NULL; else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#else - dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); -#endif DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); -#ifdef HAVE_NATIVE_COMP - if (subr->native_comp_u) + if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) { dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); dump_remember_cold_op (ctx, @@ -2974,15 +2969,11 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); DUMP_FIELD_COPY (&out, subr, doc); } - dump_field_lv (ctx, &out, subr, &subr->native_comp_u, WEIGHT_NORMAL); -#else - dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); - dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); - DUMP_FIELD_COPY (&out, subr, doc); -#endif + if (NATIVE_COMP_FLAG) + dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); - if (ctx->flags.dump_object_contents && subr->native_comp_u) + if (ctx->flags.dump_object_contents && subr->native_comp_u[0]) /* We'll do the final addr relocation during VERY_LATE_RELOCS time after the compilation units has been loaded. */ dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], @@ -5320,7 +5311,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); Lisp_Object name = intern (subr->symbol_name); struct Lisp_Native_Comp_Unit *comp_u = - XNATIVE_COMP_UNIT (subr->native_comp_u); + XNATIVE_COMP_UNIT (subr->native_comp_u[0]); if (!comp_u->handle) error ("can't relocate native subr with not loaded compilation unit"); Lisp_Object c_name = Fgethash (name, Vcomp_sym_subr_c_name_h, Qnil); -- cgit v1.2.3 From 9514dbf7ed70b6c08a11fd58c7889ff49e30ac13 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 20:24:01 +0100 Subject: adjust max_specpdl_size to sustain bootstrap --- src/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index 253de05a658..e5c850a579e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -227,8 +227,8 @@ init_eval_once (void) else { /* Original values increased for comp.el. */ - max_specpdl_size = 2100; - max_lisp_eval_depth = 1400; + max_specpdl_size = 2500; + max_lisp_eval_depth = 1600; } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); -- cgit v1.2.3 From 1b809f378f6263bc099da45c5e4a42c89fef8d71 Mon Sep 17 00:00:00 2001 From: Nicolás Bértolo Date: Tue, 19 May 2020 15:57:31 -0300 Subject: Improve handling of native compilation units still in use in Windows When closing emacs will inspect all directories from which it loaded native compilation units. If it finds a ".eln.old" file it will try to delete it, if it fails that means that another Emacs instance is using it. When compiling a file we rename the file that was in the output path in case it has been loaded into another Emacs instance. When deleting a package we move any ".eln" or ".eln.old" files in the package folder that we can't delete to `package-user-dir`. Emacs will check that directory when closing and delete them. * lisp/emacs-lisp/comp.el (comp--replace-output-file): Function called from C code to finish the compilation process. It performs renaming of the old file if necessary. * lisp/emacs-lisp/package.el (package--delete-directory): Function to delete a package directory. It moves native compilation units that it can't delete to `package-user-dir'. * src/alloc.c (cleanup_vector): Call dispose_comp_unit(). (garbage_collect): Call finish_delayed_disposal_of_comp_units(). * src/comp.c: Restore the signal mask using unwind-protect. Store loaded native compilation units in a hash table for disposal on close. Store filenames of native compilation units GC'd in a linked list to finish their disposal when the GC is over. (clean_comp_unit_directory): Delete all *.eln.old files in a directory. (clean_package_user_dir_of_old_comp_units): Delete all *.eln.old files in `package-user-dir'. (dispose_all_remaining_comp_units): Dispose of native compilation units that are still loaded. (dispose_comp_unit): Close handle and cleanup directory or arrange for later cleanup if DELAY is true. (finish_delayed_disposal_of_comp_units): Dispose of native compilation units that were GC'd. (register_native_comp_unit): Register native compilation unit for disposal when Emacs closes. * src/comp.h: Introduce cfile member in Lisp_Native_Comp_Unit. Add declarations of functions that: clean directories of unused native compilation units, handle disposal of native compilation units. * src/emacs.c (kill-emacs): Dispose all remaining compilation units right right before calling exit(). * src/eval.c (internal_condition_case_3, internal_condition_case_4): Add functions. * src/lisp.h (internal_condition_case_3, internal_condition_case_4): Add functions. * src/pdumper.c (dump_do_dump_relocation): Set cfile to a copy of the Lisp string specifying the file path. --- lisp/emacs-lisp/comp.el | 25 +++++ lisp/emacs-lisp/package.el | 31 +++++- src/alloc.c | 3 +- src/comp.c | 260 +++++++++++++++++++++++++++++++++++++++++++-- src/comp.h | 34 ++++++ src/emacs.c | 4 + src/eval.c | 55 ++++++++++ src/lisp.h | 2 + src/pdumper.c | 3 + 9 files changed, 404 insertions(+), 13 deletions(-) (limited to 'src/eval.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 6c152136fb5..3845827f661 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2277,6 +2277,31 @@ Prepare every function for final compilation and drive the C back-end." ;; Some entry point support code. +(defun comp--replace-output-file (outfile tmpfile) + "Replace OUTFILE with TMPFILE taking the necessary steps when +dealing with shared libraries that may be loaded into Emacs" + (cond ((eq 'windows-nt system-type) + (ignore-errors (delete-file outfile)) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case _ + (progn + ;; outfile maybe recreated by another Emacs in + ;; between the following two rename-file calls + (if (file-exists-p outfile) + (rename-file outfile (make-temp-file-internal + (file-name-sans-extension outfile) + nil ".eln.old" nil) + t)) + (rename-file tmpfile outfile nil)) + (file-already-exists (setf retry t)))))) + ;; Remove the old eln instead of copying the new one into it + ;; to get a new inode and prevent crashes in case the old one + ;; is currently loaded. + (t (delete-file outfile) + (rename-file tmpfile outfile)))) + (defvar comp-files-queue () "List of Elisp files to be compiled.") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 808e4f34fc5..4288d906ef5 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2204,6 +2204,35 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(defun package--delete-directory (dir) + "Delete DIR recursively. +In Windows move .eln and .eln.old files that can not be deleted +to `package-user-dir'." + (cond ((eq 'windows-nt system-type) + (let ((retry t)) + (while retry + (setf retry nil) + (condition-case err + (delete-directory dir t) + (file-error + (cl-destructuring-bind (reason1 reason2 filename) err + (if (and (string= "Removing old name" reason1) + (string= "Permission denied" reason2) + (string-prefix-p (expand-file-name package-user-dir) + filename) + (or (string-suffix-p ".eln" filename) + (string-suffix-p ".eln.old" filename))) + (progn + (rename-file filename + (make-temp-file-internal + (concat package-user-dir + (file-name-base filename)) + nil ".eln.old" nil) + t) + (setf retry t)) + (signal (car err) (cdr err))))))))) + (t (delete-directory dir t)))) + (defun package-delete (pkg-desc &optional force nosave) "Delete package PKG-DESC. @@ -2256,7 +2285,7 @@ If NOSAVE is non-nil, the package is not removed from (package-desc-name pkg-used-elsewhere-by))) (t (add-hook 'post-command-hook #'package-menu--post-refresh) - (delete-directory dir t) + (package--delete-directory dir) ;; Remove NAME-VERSION.signed and NAME-readme.txt files. ;; ;; NAME-readme.txt files are no longer created, but they diff --git a/src/alloc.c b/src/alloc.c index 76d49d2efd6..b892022125e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3119,8 +3119,7 @@ cleanup_vector (struct Lisp_Vector *vector) { struct Lisp_Native_Comp_Unit *cu = PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); - eassert (cu->handle); - dynlib_close (cu->handle); + dispose_comp_unit (cu, true); } } diff --git a/src/comp.c b/src/comp.c index 68ad6d3eb8d..16ad77c74bc 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,6 +411,10 @@ load_gccjit_if_necessary (bool mandatory) #define CALL1I(fun, arg) \ CALLN (Ffuncall, intern_c_string (STR (fun)), arg) +/* Like call2 but stringify and intern. */ +#define CALL2I(fun, arg1, arg2) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2) + #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ gcc_jit_function_new_block ((func), STR (name)) @@ -435,6 +439,8 @@ typedef struct { ptrdiff_t size; } f_reloc_t; +sigset_t saved_sigset; + static f_reloc_t freloc; /* C side of the compiler context. */ @@ -3795,6 +3801,13 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, return Qt; } +static void +restore_sigmask (void) +{ + pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); + unblock_input (); +} + DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, Scomp__compile_ctxt_to_file, 1, 1, 0, @@ -3816,6 +3829,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); sigset_t oldset; + ptrdiff_t count = 0; + if (!noninteractive) { sigset_t blocked; @@ -3828,6 +3843,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, sigaddset (&blocked, SIGIO); #endif pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + count = SPECPDL_INDEX (); + record_unwind_protect_void (restore_sigmask); } emit_ctxt_code (); @@ -3866,18 +3883,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, SSDATA (tmp_file)); - /* Remove the old eln instead of copying the new one into it to get - a new inode and prevent crashes in case the old one is currently - loaded. */ - if (!NILP (Ffile_exists_p (out_file))) - Fdelete_file (out_file, Qnil); - Frename_file (tmp_file, out_file, Qnil); + CALL2I(comp--replace-output-file, out_file, tmp_file); if (!noninteractive) - { - pthread_sigmask (SIG_SETMASK, &oldset, 0); - unblock_input (); - } + unbind_to (count, Qnil); return out_file; } @@ -3938,6 +3947,223 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/*********************************/ +/* Disposal of compilation units */ +/*********************************/ + +/* +The problem: Windows does not let us delete an .eln file that has been +loaded by a process. This has two implications in Emacs: + +1) It is not possible to recompile a lisp file if the corresponding +.eln file has been loaded. This is because we'd like to use the same +filename, but we can't delete the old .eln file. + +2) It is not possible to delete a package using `package-delete' +if an .eln file has been loaded. + +* General idea + +The solution to these two problems is to move the foo.eln file +somewhere else and have the last Emacs instance using it delete it. +To make it easy to find what files need to be removed we use two approaches. + +In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same +folder. When Emacs is unloading "foo" (either GC'd the native +compilation unit or Emacs is closing (see below)) we delete all the +.eln.old files in the folder where the original foo.eln was stored. + +Ideally we'd figure out the new name of foo.eln and delete it if +it ends in .eln.old. There is no simple API to do this in +Windows. GetModuleFileName() returns the original filename, not the +current one. This forces us to put .eln.old files in an agreed upon +path. We cannot use %TEMP% because it may be in another drive and then +the rename operation would fail. + +In the 2) case we can't use the same folder where the .eln file +resided, as we are trying to completely remove the package. Since we +are removing packages we can safely move the .eln.old file to +`package-user-dir' as we are sure that that would not mean changing +drives. + +* Implementation details + +The concept of disposal of a native compilation unit refers to +unloading the shared library and deleting all the .eln.old files in +the directory. These are two separate steps. We'll call them +early-disposal and late-disposal. + +There are two data structures used: + +- The `all_loaded_comp_units_h` hashtable. + +This hashtable is used like an array of weak references to native +compilation units. This hash table is filled by load_comp_unit() and +dispose_all_remaining_comp_units() iterates over all values that were +not disposed by the GC and performs all disposal steps when Emacs is +closing. + +- The `delayed_comp_unit_disposal_list` list. + +This is were the dispose_comp_unit() function, when called by the GC +sweep stage, stores the original filenames of the disposed native +compilation units. This is an ad-hoc C structure instead of a Lisp +cons because we need to allocate instances of this structure during +the GC. + +The finish_delayed_disposal_of_comp_units() function will iterate over +this list and perform the late-disposal step when Emacs is closing. + +*/ + +#ifdef WINDOWSNT +#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") + +static Lisp_Object all_loaded_comp_units_h; + +/* We need to allocate instances of this struct during a GC + * sweep. This is why it can't be transformed into a simple cons. + */ +struct delayed_comp_unit_disposal +{ + struct delayed_comp_unit_disposal *next; + char *filename; +}; + +struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; + +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} + +/* Tries to remove all *.eln.old files in DIRNAME. + + * Any error is ignored because it may be due to the file being loaded + * in another Emacs instance. + */ +static void +clean_comp_unit_directory (Lisp_Object dirpath) +{ + if (NILP (dirpath)) + return; + Lisp_Object files_in_dir; + files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, + OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, + return_nil); + FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } +} + +/* Tries to remove all *.eln.old files in `package-user-dir'. + + * This is called when Emacs is closing to clean any *.eln left from a + * deleted package. + */ +void +clean_package_user_dir_of_old_comp_units (void) +{ + Lisp_Object package_user_dir + = find_symbol_value (intern ("package-user-dir")); + if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) + return; + + clean_comp_unit_directory (package_user_dir); +} + +/* This function disposes all compilation units that are still loaded. + * It is important that this function is called only right before + * Emacs is closed, otherwise we risk running a subr that is + * implemented in an unloaded dynamic library. + */ +void +dispose_all_remaining_comp_units (void) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + Lisp_Object k = HASH_KEY (h, i); + if (!EQ (k, Qunbound)) + { + Lisp_Object val = HASH_VALUE (h, i); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); + dispose_comp_unit (cu, false); + } + } +} + +/* This function finishes the disposal of compilation units that were + * passed to `dispose_comp_unit` with DELAY == true. + * + * This function is called when Emacs is idle and when it is about to + * close. + */ +void +finish_delayed_disposal_of_comp_units (void) +{ + for (struct delayed_comp_unit_disposal *item + = delayed_comp_unit_disposal_list; + delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) + { + delayed_comp_unit_disposal_list = item->next; + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (item->filename), Qt, return_nil); + clean_comp_unit_directory (dirname); + xfree (item->filename); + xfree (item); + } +} +#endif + +/* This function puts the compilation unit in the + * `all_loaded_comp_units_h` hashmap. + */ +static void +register_native_comp_unit (Lisp_Object comp_u) +{ +#ifdef WINDOWSNT + Fputhash (CALL1I (gensym, Qnil), comp_u, all_loaded_comp_units_h); +#endif +} + +/* This function disposes compilation units. It is called during the GC sweep + * stage and when Emacs is closing. + + * On Windows the the DELAY parameter specifies whether the native + * compilation file will be deleted right away (if necessary) or put + * on a list. That list will be dealt with by + * `finish_delayed_disposal_of_comp_units`. + */ +void +dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) +{ + eassert (comp_handle->handle); + dynlib_close (comp_handle->handle); +#ifdef WINDOWSNT + if (!delay) + { + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (comp_handle->cfile), Qt, + return_nil); + if (!NILP (dirname)) + clean_comp_unit_directory (dirname); + xfree (comp_handle->cfile); + comp_handle->cfile = NULL; + } + else + { + struct delayed_comp_unit_disposal *head; + head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); + head->next = delayed_comp_unit_disposal_list; + head->filename = comp_handle->cfile; + comp_handle->cfile = NULL; + delayed_comp_unit_disposal_list = head; + } +#endif +} + /***********************************/ /* Deferred compilation mechanism. */ @@ -4159,6 +4385,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); for (EMACS_INT i = 0; i < d_vec_len; i++) data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + + /* If we register them while dumping we will get some entries in + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ + if (!will_dump_p ()) + register_native_comp_unit (comp_u_lisp_obj); } if (!loading_dump) @@ -4316,6 +4548,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, if (!comp_u->handle) xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); comp_u->file = file; +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup (file); +#endif comp_u->data_vec = Qnil; comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq); comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); @@ -4464,6 +4699,11 @@ syms_of_comp (void) staticpro (&delayed_sources); delayed_sources = Qnil; +#ifdef WINDOWSNT + staticpro (&all_loaded_comp_units_h); + all_loaded_comp_units_h = CALLN(Fmake_hash_table, QCweakness, Qvalue); +#endif + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, doc: /* The compiler context. */); Vcomp_ctxt = Qnil; diff --git a/src/comp.h b/src/comp.h index 36e7cdf4413..b8e40ceb900 100644 --- a/src/comp.h +++ b/src/comp.h @@ -52,7 +52,15 @@ struct Lisp_Native_Comp_Unit /* STUFFS WE DO NOT DUMP!! */ Lisp_Object *data_imp_relocs; bool loaded_once; + dynlib_handle_ptr handle; +#ifdef WINDOWSNT + /* We need to store a copy of the original file name in memory that + is not subject to GC because the function to dispose native + compilation units is called by the GC. By that time the `file' + string may have been sweeped. */ + char * cfile; +#endif }; #ifdef HAVE_NATIVE_COMP @@ -83,6 +91,14 @@ extern void syms_of_comp (void); extern void maybe_defer_native_compilation (Lisp_Object function_name, Lisp_Object definition); + +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay); + +extern void finish_delayed_disposal_of_comp_units (void); + +extern void dispose_all_remaining_comp_units (void); + +extern void clean_package_user_dir_of_old_comp_units (void); #else static inline void @@ -92,6 +108,24 @@ maybe_defer_native_compilation (Lisp_Object function_name, extern void syms_of_comp (void); +static inline void +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle) +{ + eassert (false); +} + +static inline void +dispose_all_remaining_comp_units (void) +{} + +static inline void +clean_package_user_dir_of_old_comp_units (void) +{} + +static inline void +finish_delayed_disposal_of_comp_units (void) +{} + #endif #endif diff --git a/src/emacs.c b/src/emacs.c index 93a837a44ef..2a7a5257f15 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -2398,6 +2398,10 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } + finish_delayed_disposal_of_comp_units (); + dispose_all_remaining_comp_units (); + clean_package_user_dir_of_old_comp_units (); + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN diff --git a/src/eval.c b/src/eval.c index 37d466f69ed..9e86a185908 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1419,6 +1419,61 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as + its arguments. */ + +Lisp_Object +internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as + its arguments. */ + +Lisp_Object +internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ diff --git a/src/lisp.h b/src/lisp.h index 4c0057b2552..52242791aa5 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4165,6 +4165,8 @@ extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); diff --git a/src/pdumper.c b/src/pdumper.c index a6d12b6ea0c..26480388d59 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5312,6 +5312,9 @@ dump_do_dump_relocation (const uintptr_t dump_base, concat2 (Vinvocation_directory, installation_state == LOCAL_BUILD ? XCDR (comp_u->file) : XCAR (comp_u->file)); +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup(comp_u->file); +#endif comp_u->handle = dynlib_open (SSDATA (comp_u->file)); if (!comp_u->handle) error ("%s", dynlib_error ()); -- cgit v1.2.3 From c37b5446d1f8e567f97f5708008b14a80b6c6d65 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 1 Jun 2020 12:47:29 +0100 Subject: Add native compiler dynamic scope support Add an initial implementation to support dynamic scope. Arg parsing/binding it's done using the existing code in use for bytecode (no ad-hoc code is synthetized for that). * src/lisp.h (struct Lisp_Subr): Add lambda_list field. (SUBR_NATIVE_COMPILED_DYNP): New inliner. * src/alloc.c (mark_object): Update for Add lambda_list field. * src/eval.c (eval_sub, Ffuncall, funcall_lambda): Handle native compiled dynamic scope * src/comp.c (declare_lex_function): Rename from declare_function and rework. (declare_function): New function. (make_subr): Handle daynamic scope * src/pdumper.c (dump_subr): Update for lambda_list field. * lisp/emacs-lisp/comp.el (comp-func): Remove args slot. (comp-func-l, comp-func-d): New classes deriving from `comp-func'. (comp-spill-lap-function): Rework. (comp-prepare-args-for-top-level): New function. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Make use of `comp-prepare-args-for-top-level'. (comp-limplify-top-level): Use `comp-func-l'. (comp-limplify-function): Emit arg prologue only for dynamic scoped functions. (comp-call-optim-form-call): Use `comp-func-l'. (comp-call-optim, comp-tco): Do not optimize dynamic scoped code. --- lisp/emacs-lisp/comp.el | 146 +++++++++++++++++++++++++++--------------------- src/alloc.c | 1 + src/comp.c | 63 ++++++++++++++------- src/eval.c | 24 ++++++-- src/lisp.h | 13 +++++ src/pdumper.c | 5 +- 6 files changed, 162 insertions(+), 90 deletions(-) (limited to 'src/eval.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5027d1da088..e7bd0690727 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -354,7 +354,6 @@ into it.") :documentation "SSA status either: 'nil', 'dirty' or 't'. Once in SSA form this *must* be set to 'dirty' every time the topology of the CFG is mutated by a pass.") - (args nil :type comp-args-base) (frame-size nil :type number) (blocks (make-hash-table) :type hash-table :documentation "Key is the basic block symbol value is a comp-block @@ -372,6 +371,16 @@ structure.") (array-h (make-hash-table) :type hash-table :documentation "array idx -> array length.")) +(cl-defstruct (comp-func-l (:include comp-func)) + "Lexical scoped function." + (args nil :type comp-args-base + :documentation "Argument specification of the function")) + +(cl-defstruct (comp-func-d (:include comp-func)) + "Dynamic scoped function." + (lambda-list nil :type list + :documentation "Original lambda-list.")) + (cl-defstruct (comp-mvar (:constructor make--comp-mvar)) "A meta-variable being a slot in the meta-stack." (id nil :type (or null number) @@ -600,10 +609,10 @@ Put PREFIX in front of it." "Byte compile FUNCTION-NAME spilling data from the byte compiler." (let* ((f (symbol-function function-name)) (c-name (comp-c-func-name function-name "F")) - (func (make-comp-func :name function-name - :c-name c-name - :doc (documentation f) - :int-spec (interactive-form f)))) + (func (make-comp-func-l :name function-name + :c-name c-name + :doc (documentation f) + :int-spec (interactive-form f)))) (when (byte-code-function-p f) (signal 'native-compiler-error "can't native compile an already bytecompiled function")) @@ -615,7 +624,7 @@ Put PREFIX in front of it." (cl-assert lap) (comp-log lap 2) (let ((arg-list (aref (comp-func-byte-func func) 0))) - (setf (comp-func-args func) + (setf (comp-func-l-args func) (comp-decrypt-arg-list arg-list function-name) (comp-func-lap func) lap @@ -631,8 +640,7 @@ Put PREFIX in front of it." (defun comp-intern-func-in-ctxt (_ obj) "Given OBJ of type `byte-to-native-lambda' create a function in `comp-ctxt'." (when-let ((byte-func (byte-to-native-lambda-byte-func obj))) - (let* ((byte-func (byte-to-native-lambda-byte-func obj)) - (lap (byte-to-native-lambda-lap obj)) + (let* ((lap (byte-to-native-lambda-lap obj)) (top-l-form (cl-loop for form in (comp-ctxt-top-level-forms comp-ctxt) when (and (byte-to-native-func-def-p form) @@ -640,31 +648,32 @@ Put PREFIX in front of it." byte-func)) return form)) (name (when top-l-form - (byte-to-native-func-def-name top-l-form)))) - ;; Do not refuse to compile if a dynamic byte-compiled lambda - ;; leaks here (advice). - (when (or name (comp-lex-byte-func-p byte-func)) - (let* ((c-name (comp-c-func-name (or name "anonymous-lambda") "F")) - (func (make-comp-func :name name - :byte-func byte-func - :doc (documentation byte-func) - :int-spec (interactive-form byte-func) - :c-name c-name - :args (comp-decrypt-arg-list (aref byte-func 0) - name) - :lap lap - :frame-size (comp-byte-frame-size byte-func)))) - ;; Store the c-name to have it retrivable from - ;; `comp-ctxt-top-level-forms'. - (when top-l-form - (setf (byte-to-native-func-def-c-name top-l-form) c-name)) - (unless name - (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) - ;; Create the default array. - (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) - (comp-add-func-to-ctxt func) - (comp-log (format "Function %s:\n" name) 1) - (comp-log lap 1)))))) + (byte-to-native-func-def-name top-l-form))) + (c-name (comp-c-func-name (or name "anonymous-lambda") "F")) + (func (if (comp-lex-byte-func-p byte-func) + (make-comp-func-l + :args (comp-decrypt-arg-list (aref byte-func 0) + name)) + (make-comp-func-d :lambda-list (aref byte-func 0))))) + (setf (comp-func-name func) name + (comp-func-byte-func func) byte-func + (comp-func-doc func) (documentation byte-func) + (comp-func-int-spec func) (interactive-form byte-func) + (comp-func-c-name func) c-name + (comp-func-lap func) lap + (comp-func-frame-size func) (comp-byte-frame-size byte-func)) + + ;; Store the c-name to have it retrivable from + ;; `comp-ctxt-top-level-forms'. + (when top-l-form + (setf (byte-to-native-func-def-c-name top-l-form) c-name)) + (unless name + (puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt))) + ;; Create the default array. + (puthash 0 (comp-func-frame-size func) (comp-func-array-h func)) + (comp-add-func-to-ctxt func) + (comp-log (format "Function %s:\n" name) 1) + (comp-log lap 1)))) (cl-defgeneric comp-spill-lap-function ((filename string)) "Byte compile FILENAME spilling data from the byte compiler." @@ -1321,6 +1330,17 @@ the annotation emission." (comp-log-func func 2) func) +(defun comp-prepare-args-for-top-level (function) + "Given FUNCTION return the two args arguments for comp--register-..." + (if (comp-func-l-p function) + (let ((args (comp-func-l-args function))) + (cons (comp-args-base-min args) + (if (comp-args-p args) + (comp-args-max args) + 'many))) + (cons (func-arity (comp-func-byte-func function)) + (comp-func-d-lambda-list function)))) + (cl-defgeneric comp-emit-for-top-level (form for-late-load) "Emit the limple code for top level FORM.") @@ -1329,16 +1349,14 @@ the annotation emission." (let* ((name (byte-to-native-func-def-name form)) (c-name (byte-to-native-func-def-c-name form)) (f (gethash c-name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f))) + (args (comp-prepare-args-for-top-level f))) (cl-assert (and name f)) (comp-emit (comp-call (if for-late-load 'comp--late-register-subr 'comp--register-subr) (make-comp-mvar :constant name) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant c-name) (make-comp-mvar :constant @@ -1364,7 +1382,7 @@ the annotation emission." (defun comp-emit-lambda-for-top-level (func) "Emit the creation of subrs for lambda FUNC. These are stored in the reloc data array." - (let ((args (comp-func-args func))) + (let ((args (comp-prepare-args-for-top-level func))) (let ((comp-curr-allocation-class 'd-impure)) (comp-add-const-to-relocs (comp-func-byte-func func))) (comp-emit @@ -1376,10 +1394,8 @@ These are stored in the reloc data array." (puthash (comp-func-byte-func func) (make-comp-mvar :constant nil) (comp-ctxt-lambda-fixups-h comp-ctxt))) - (make-comp-mvar :constant (comp-args-base-min args)) - (make-comp-mvar :constant (if (comp-args-p args) - (comp-args-max args) - 'many)) + (make-comp-mvar :constant (car args)) + (make-comp-mvar :constant (cdr args)) (make-comp-mvar :constant (comp-func-c-name func)) (make-comp-mvar :constant (let* ((h (comp-ctxt-function-docs comp-ctxt)) @@ -1404,14 +1420,14 @@ into the C code forwarding the compilation unit." ;; reasons to be execute ever again. Therefore all objects can be ;; just ephemeral. (let* ((comp-curr-allocation-class 'd-ephemeral) - (func (make-comp-func :name (if for-late-load - 'late-top-level-run - 'top-level-run) - :c-name (if for-late-load - "late_top_level_run" - "top_level_run") - :args (make-comp-args :min 1 :max 1) - :frame-size 1)) + (func (make-comp-func-l :name (if for-late-load + 'late-top-level-run + 'top-level-run) + :c-name (if for-late-load + "late_top_level_run" + "top_level_run") + :args (make-comp-args :min 1 :max 1) + :frame-size 1)) (comp-func func) (comp-pass (make-comp-limplify :curr-block (make--comp-block-lap -1 0 'top-level) @@ -1475,20 +1491,22 @@ into the C code forwarding the compilation unit." (let* ((frame-size (comp-func-frame-size func)) (comp-func func) (comp-pass (make-comp-limplify - :frame (comp-new-frame frame-size))) - (args (comp-func-args func))) + :frame (comp-new-frame frame-size)))) (comp-fill-label-h) ;; Prologue (comp-make-curr-block 'entry (comp-sp)) (comp-emit-annotation (concat "Lisp function: " (symbol-name (comp-func-name func)))) - (if (comp-args-p args) - (cl-loop for i below (comp-args-max args) - do (cl-incf (comp-sp)) - (comp-emit `(set-par-to-local ,(comp-slot) ,i))) - (comp-emit-narg-prologue (comp-args-base-min args) - (comp-nargs-nonrest args) - (comp-nargs-rest args))) + ;; Dynamic functions have parameters bound by the trampoline. + (when (comp-func-l-p func) + (let ((args (comp-func-l-args func))) + (if (comp-args-p args) + (cl-loop for i below (comp-args-max args) + do (cl-incf (comp-sp)) + (comp-emit `(set-par-to-local ,(comp-slot) ,i))) + (comp-emit-narg-prologue (comp-args-base-min args) + (comp-nargs-nonrest args) + (comp-nargs-rest args))))) (comp-emit '(jump bb_0)) ;; Body (comp-bb-maybe-add 0 (comp-sp)) @@ -2096,7 +2114,7 @@ FUNCTION can be a function-name or byte compiled function." ;; Anonymous lambdas can't be redefined so are ;; always safe to optimize. (byte-code-function-p callee)))) - (let* ((func-args (comp-func-args comp-func-callee)) + (let* ((func-args (comp-func-l-args comp-func-callee)) (nargs (comp-nargs-p func-args)) (call-type (if nargs 'direct-callref 'direct-call)) (args (if (eq call-type 'direct-callref) @@ -2128,7 +2146,8 @@ FUNCTION can be a function-name or byte compiled function." (when (>= comp-speed 2) (maphash (lambda (_ f) (let ((comp-func f)) - (comp-call-optim-func))) + (when (comp-func-l-p f) + (comp-call-optim-func)))) (comp-ctxt-funcs-h comp-ctxt)))) @@ -2234,7 +2253,8 @@ Return the list of m-var ids nuked." (when (>= comp-speed 3) (maphash (lambda (_ f) (let ((comp-func f)) - (unless (comp-func-has-non-local comp-func) + (when (and (comp-func-l-p f) + (not (comp-func-has-non-local comp-func))) (comp-tco-func) (comp-log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt)))) diff --git a/src/alloc.c b/src/alloc.c index 42a53276bc8..a31b4a045e2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6723,6 +6723,7 @@ mark_object (Lisp_Object arg) struct Lisp_Subr *subr = XSUBR (obj); mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); } break; diff --git a/src/comp.c b/src/comp.c index 24d69b2b1ef..781ad3e08e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3655,14 +3655,12 @@ define_bool_to_lisp_obj (void) emit_lisp_obj_rval (Qnil)); } -/* Declare a function being compiled and add it to comp.exported_funcs_h. */ - -static void -declare_function (Lisp_Object func) +static gcc_jit_function * +declare_lex_function (Lisp_Object func) { - gcc_jit_function *gcc_func; + gcc_jit_function *res; char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); - Lisp_Object args = CALL1I (comp-func-args, func); + Lisp_Object args = CALL1I (comp-func-l-args, func); bool nargs = !NILP (CALL1I (comp-nargs-p, args)); USE_SAFE_ALLOCA; @@ -3673,23 +3671,23 @@ declare_function (Lisp_Object func) for (ptrdiff_t i = 0; i < max_args; i++) type[i] = comp.lisp_obj_type; - gcc_jit_param **param = SAFE_ALLOCA (max_args * sizeof (*param)); + gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params)); for (int i = 0; i < max_args; ++i) - param[i] = gcc_jit_context_new_param (comp.ctxt, + params[i] = gcc_jit_context_new_param (comp.ctxt, NULL, type[i], format_string ("par_%d", i)); - gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, - GCC_JIT_FUNCTION_EXPORTED, - comp.lisp_obj_type, - c_name, - max_args, - param, - 0); + res = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + params, + 0); } else { - gcc_jit_param *param[] = + gcc_jit_param *params[] = { gcc_jit_context_new_param (comp.ctxt, NULL, comp.ptrdiff_type, @@ -3698,19 +3696,34 @@ declare_function (Lisp_Object func) NULL, comp.lisp_obj_ptr_type, "args") }; - gcc_func = + res = gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_EXPORTED, comp.lisp_obj_type, - c_name, 2, param, 0); + c_name, ARRAYELTS (params), params, 0); } + SAFE_FREE (); + return res; +} + +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func = + !NILP (CALL1I (comp-func-l-p, func)) + ? declare_lex_function (func) + : gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (CALL1I (comp-func-c-name, func)), + 0, NULL, 0); Fputhash (CALL1I (comp-func-c-name, func), make_mint_ptr (gcc_func), comp.exported_funcs_h); - - SAFE_FREE (); } static void @@ -4685,12 +4698,20 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, void *func = dynlib_sym (handle, SSDATA (c_name)); eassert (func); - union Aligned_Lisp_Subr *x = (union Aligned_Lisp_Subr *) allocate_pseudovector ( VECSIZE (union Aligned_Lisp_Subr), 0, VECSIZE (union Aligned_Lisp_Subr), PVEC_SUBR); + if (CONSP (minarg)) + { + /* Dynamic code. */ + x->s.lambda_list[0] = maxarg; + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + x->s.lambda_list[0] = Qnil; x->s.function.a0 = func; x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; diff --git a/src/eval.c b/src/eval.c index 9e86a185908..f2a85691b42 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2275,7 +2275,7 @@ eval_sub (Lisp_Object form) else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) { Lisp_Object args_left = original_args; ptrdiff_t numargs = list_length (args_left); @@ -2378,7 +2378,9 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); else { @@ -2854,9 +2856,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) val = funcall_subr (XSUBR (fun), numargs, args + 1); - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3066,6 +3070,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else if (MODULE_FUNCTIONP (fun)) return funcall_module (fun, nargs, arg_vector); #endif + else if (SUBR_NATIVE_COMPILED_DYNP (fun)) + { + syms_left = XSUBR (fun)->lambda_list[0]; + lexenv = Qnil; + } else emacs_abort (); @@ -3126,6 +3135,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); + else if (SUBR_NATIVE_COMPILEDP (fun)) + { + eassert (SUBR_NATIVE_COMPILED_DYNP (fun)); + /* No need to use funcall_subr as we have zero arguments by + construction. */ + val = XSUBR (fun)->function.a0 (); + } else val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); diff --git a/src/lisp.h b/src/lisp.h index bef2e8079e1..70ef7db8ee4 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2096,6 +2096,7 @@ struct Lisp_Subr EMACS_INT doc; Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; char *native_c_name[NATIVE_COMP_FLAG]; + Lisp_Object lambda_list[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); +} + INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { @@ -4772,6 +4779,12 @@ SUBR_NATIVE_COMPILEDP (Lisp_Object a) return false; } +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return false; +} + #endif /* Defined in lastfile.c. */ diff --git a/src/pdumper.c b/src/pdumper.c index e6c877cbbe2..2bda3a85cd1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2937,7 +2937,7 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_92BED44D81) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2968,8 +2968,9 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); if (!NILP (subr->native_comp_u[0])) dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); - } + dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL); + } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG && ctx->flags.dump_object_contents -- cgit v1.2.3 From ab985f41db5fdaeada513d28a065332fd8838cf4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Dec 2020 21:02:49 +0100 Subject: Add 'internal_condition_case_5' (bug#45303). * src/lisp.h (internal_condition_case_4) (internal_condition_case_5): Declare. * src/eval.c (internal_condition_case_5): New function. * src/comp.c (eln_load_path_final_clean_up): Use 'internal_condition_case_5'. --- src/comp.c | 4 ++-- src/eval.c | 29 +++++++++++++++++++++++++++++ src/lisp.h | 2 ++ 3 files changed, 33 insertions(+), 2 deletions(-) (limited to 'src/eval.c') diff --git a/src/comp.c b/src/comp.c index f77faaa483e..12c5f1c7e49 100644 --- a/src/comp.c +++ b/src/comp.c @@ -4618,11 +4618,11 @@ eln_load_path_final_clean_up (void) FOR_EACH_TAIL (dir_tail) { Lisp_Object files_in_dir = - internal_condition_case_4 (Fdirectory_files, + internal_condition_case_5 (Fdirectory_files, concat2 (XCAR (dir_tail), Vcomp_native_version_dir), Qt, build_string ("\\.eln\\.old\\'"), Qnil, - Qt, return_nil); + Qt, return_nil, Qnil); FOR_EACH_TAIL (files_in_dir) Fdelete_file (XCAR (files_in_dir), Qnil); } diff --git a/src/eval.c b/src/eval.c index 2b31b91175b..368fa0944a1 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1534,6 +1534,35 @@ internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, + ARG4, ARG5 as its arguments. */ + +Lisp_Object +internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object arg5, Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ diff --git a/src/lisp.h b/src/lisp.h index 588316e01b8..923e742eec6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4157,6 +4157,8 @@ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_5 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); -- cgit v1.2.3 From 203e61ff837128b397eb313a5bb1b703f0eae0ec Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Thu, 11 Feb 2021 21:37:45 +0000 Subject: Make recursive minibuffers and recursive edits work together * lisp/minibuffer.el (exit-minibuffer): When in a minibuffer, throw an error should the command loop nesting level be wrong. * src/lisp.h (minibuffer_quit_level): declare as an extern. (command_loop_level): Move definition from src/window.h * src/window.h (command_loop_level): move definition to src/lisp.h. * src/eval.c (minibuffer_quit_level): Move this variable to file level from being a static inside internal_catch. (internal_catch): Simplify the logic. * src/minibuf.c (Vcommand_loop_level_list): New variable. (move_minibuffer_onto_frame): Set the major mode of *Minibuf-0*. (Fminibuffer_innermost_command_loop_p): New primitive. (Fabort_minibuffers): Check the command loop level before throwing t to 'exit, and set minibuffer_quit_level too. (read_minibuf): New variable calling_window. Before stacking up minibuffers on the current mini-window, check that the mini-window is not the current one. Do not call choose_minibuf_frame from read_minibuf's unwinding process. Bind calling_frame and calling_window over the recursive edit. Set the new minibuffer's major mode directly. Remove the switching away from the minibuffer after the recursive edit. (get_minibuffer): Record the command loop level in new variable Vcommand_loop_level_list. No longer set the major mode of a returned minibuffer. (minibuf_c_loop_level): New function. (read_minibuf_unwind): New variables calling_frame, calling_window are unbound from the binding stack. Remove old variable `window', which could not be set reliably to the expired mini-window. The expired minibuffer is determined as the nth in the list, rather than the contents of the current or previous mini-window. Switch the current window away from the mini-window here (moved from read_minibuf). --- lisp/minibuffer.el | 13 +++--- src/eval.c | 32 +++++++-------- src/lisp.h | 2 + src/minibuf.c | 115 ++++++++++++++++++++++++++++++++++++++--------------- src/window.h | 4 -- 5 files changed, 107 insertions(+), 59 deletions(-) (limited to 'src/eval.c') diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index a899a943d4c..aacb8ab00bb 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2116,18 +2116,19 @@ variables.") (defun exit-minibuffer () "Terminate this minibuffer argument." (interactive) - (when (or - (innermost-minibuffer-p) - (not (minibufferp))) + (when (minibufferp) + (when (not (minibuffer-innermost-command-loop-p)) + (error "%s" "Not in most nested command loop")) + (when (not (innermost-minibuffer-p)) + (error "%s" "Not in most nested minibuffer"))) ;; If the command that uses this has made modifications in the minibuffer, ;; we don't want them to cause deactivation of the mark in the original ;; buffer. ;; A better solution would be to make deactivate-mark buffer-local ;; (or to turn it into a list of buffers, ...), but in the mean time, ;; this should do the trick in most cases. - (setq deactivate-mark nil) - (throw 'exit nil)) - (error "%s" "Not in most nested minibuffer")) + (setq deactivate-mark nil) + (throw 'exit nil)) (defun self-insert-and-exit () "Terminate minibuffer input." diff --git a/src/eval.c b/src/eval.c index 3aff3b56d52..91fc4e68377 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1165,21 +1165,23 @@ usage: (catch TAG BODY...) */) FUNC should return a Lisp_Object. This is how catches are done from within C code. */ +/* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by + throwing t to tag `exit'. + 0 means there is no (throw 'exit t) in progress, or it wasn't from + a minibuffer which isn't the most nested; + N > 0 means the `throw' was done from the minibuffer at level N which + wasn't the most nested. */ +EMACS_INT minibuffer_quit_level = 0; + Lisp_Object internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) { - /* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by - throwing t to tag `exit'. - Value -1 means there is no (throw 'exit t) in progress; - 0 means the `throw' wasn't done from an active minibuffer; - N > 0 means the `throw' was done from the minibuffer at level N. */ - static EMACS_INT minibuffer_quit_level = -1; /* This structure is made part of the chain `catchlist'. */ struct handler *c = push_handler (tag, CATCHER); if (EQ (tag, Qexit)) - minibuffer_quit_level = -1; + minibuffer_quit_level = 0; /* Call FUNC. */ if (! sys_setjmp (c->jmp)) @@ -1194,22 +1196,16 @@ internal_catch (Lisp_Object tag, Lisp_Object val = handlerlist->val; clobbered_eassert (handlerlist == c); handlerlist = handlerlist->next; - if (EQ (tag, Qexit) && EQ (val, Qt)) + if (EQ (tag, Qexit) && EQ (val, Qt) && minibuffer_quit_level > 0) /* If we've thrown t to tag `exit' from within a minibuffer, we exit all minibuffers more deeply nested than the current one. */ { - EMACS_INT mini_depth = this_minibuffer_depth (Qnil); - if (mini_depth && mini_depth != minibuffer_quit_level) - { - if (minibuffer_quit_level == -1) - minibuffer_quit_level = mini_depth; - if (minibuffer_quit_level - && (minibuf_level > minibuffer_quit_level)) - Fthrow (Qexit, Qt); - } + if (minibuf_level > minibuffer_quit_level + && !NILP (Fminibuffer_innermost_command_loop_p (Qnil))) + Fthrow (Qexit, Qt); else - minibuffer_quit_level = -1; + minibuffer_quit_level = 0; } return val; } diff --git a/src/lisp.h b/src/lisp.h index 409a1e70608..0847324d1ff 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4091,6 +4091,7 @@ intern_c_string (const char *str) } /* Defined in eval.c. */ +extern EMACS_INT minibuffer_quit_level; extern Lisp_Object Vautoload_queue; extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; @@ -4369,6 +4370,7 @@ extern void syms_of_casetab (void); /* Defined in keyboard.c. */ +extern EMACS_INT command_loop_level; extern Lisp_Object echo_message_buffer; extern struct kboard *echo_kboard; extern void cancel_echoing (void); diff --git a/src/minibuf.c b/src/minibuf.c index 949c3d989d5..4b1f4b1ff72 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -41,6 +41,7 @@ along with GNU Emacs. If not, see . */ minibuffer recursions are encountered. */ Lisp_Object Vminibuffer_list; +Lisp_Object Vcommand_loop_level_list; /* Data to remember during recursive minibuffer invocations. */ @@ -64,6 +65,8 @@ static Lisp_Object minibuf_prompt; static ptrdiff_t minibuf_prompt_width; static Lisp_Object nth_minibuffer (EMACS_INT depth); +static EMACS_INT minibuf_c_loop_level (EMACS_INT depth); +static void set_minibuffer_mode (Lisp_Object buf, EMACS_INT depth); /* Return TRUE when a frame switch causes a minibuffer on the old @@ -181,7 +184,12 @@ void move_minibuffer_onto_frame (void) set_window_buffer (sf->minibuffer_window, nth_minibuffer (i), 0, 0); minibuf_window = sf->minibuffer_window; if (of != sf) - set_window_buffer (of->minibuffer_window, get_minibuffer (0), 0, 0); + { + Lisp_Object temp = get_minibuffer (0); + + set_window_buffer (of->minibuffer_window, temp, 0, 0); + set_minibuffer_mode (temp, 0); + } } } @@ -389,6 +397,21 @@ No argument or nil as argument means use the current buffer as BUFFER. */) : Qnil; } +DEFUN ("minibuffer-innermost-command-loop-p", Fminibuffer_innermost_command_loop_p, + Sminibuffer_innermost_command_loop_p, 0, 1, 0, + doc: /* Return t if BUFFER is a minibuffer at the current command loop level. +No argument or nil as argument means use the current buffer as BUFFER. */) + (Lisp_Object buffer) +{ + EMACS_INT depth; + if (NILP (buffer)) + buffer = Fcurrent_buffer (); + depth = this_minibuffer_depth (buffer); + return depth && minibuf_c_loop_level (depth) == command_loop_level + ? Qt + : Qnil; +} + /* Return the nesting depth of the active minibuffer BUFFER, or 0 if BUFFER isn't such a thing. If BUFFER is nil, this means use the current buffer. */ @@ -420,12 +443,17 @@ confirm the aborting of the current minibuffer and all contained ones. */) if (!minibuf_depth) error ("Not in a minibuffer"); + if (NILP (Fminibuffer_innermost_command_loop_p (Qnil))) + error ("Not in most nested command loop"); if (minibuf_depth < minibuf_level) { array[0] = fmt; array[1] = make_fixnum (minibuf_level - minibuf_depth + 1); if (!NILP (Fyes_or_no_p (Fformat (2, array)))) - Fthrow (Qexit, Qt); + { + minibuffer_quit_level = minibuf_depth; + Fthrow (Qexit, Qt); + } } else Fthrow (Qexit, Qt); @@ -508,6 +536,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object mini_frame, ambient_dir, minibuffer, input_method; Lisp_Object calling_frame = selected_frame; + Lisp_Object calling_window = selected_window; Lisp_Object enable_multibyte; EMACS_INT pos = 0; /* String to add to the history. */ @@ -598,7 +627,8 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (minibuf_level > 1 && minibuf_moves_frame_when_opened () - && !minibuf_follows_frame ()) + && (!minibuf_follows_frame () + || (!EQ (mini_frame, selected_frame)))) { EMACS_INT i; @@ -607,8 +637,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, set_window_buffer (minibuf_window, nth_minibuffer (i), 0, 0); } - record_unwind_protect_void (choose_minibuf_frame); - record_unwind_protect (restore_window_configuration, Fcons (Qt, Fcurrent_window_configuration (Qnil))); @@ -640,7 +668,9 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, minibuf_save_list = Fcons (Voverriding_local_map, Fcons (minibuf_window, - minibuf_save_list)); + Fcons (calling_frame, + Fcons (calling_window, + minibuf_save_list)))); minibuf_save_list = Fcons (minibuf_prompt, Fcons (make_fixnum (minibuf_prompt_width), @@ -694,6 +724,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, /* Switch to the minibuffer. */ minibuffer = get_minibuffer (minibuf_level); + set_minibuffer_mode (minibuffer, minibuf_level); Fset_buffer (minibuffer); /* Defeat (setq-default truncate-lines t), since truncated lines do @@ -738,6 +769,7 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, where there is an active minibuffer. Set them to point to ` *Minibuf-0*', which is always empty. */ empty_minibuf = get_minibuffer (0); + set_minibuffer_mode (empty_minibuf, 0); FOR_EACH_FRAME (dummy, frame) { @@ -837,20 +869,6 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, recursive_edit_1 (); - /* We've exited the recursive edit without an error, so switch the - current window away from the expired minibuffer window. */ - { - Lisp_Object prev = Fprevious_window (minibuf_window, Qnil, Qnil); - /* PREV can be on a different frame when we have a minibuffer only - frame, the other frame's minibuffer window is MINIBUF_WINDOW, - and its "focus window" is also MINIBUF_WINDOW. */ - while (!EQ (prev, minibuf_window) - && !EQ (selected_frame, WINDOW_FRAME (XWINDOW (prev)))) - prev = Fprevious_window (prev, Qnil, Qnil); - if (!EQ (prev, minibuf_window)) - Fset_frame_selected_window (selected_frame, prev, Qnil); - } - /* If cursor is on the minibuffer line, show the user we have exited by putting it in column 0. */ if (XWINDOW (minibuf_window)->cursor.vpos >= 0 @@ -959,11 +977,16 @@ Lisp_Object get_minibuffer (EMACS_INT depth) { Lisp_Object tail = Fnthcdr (make_fixnum (depth), Vminibuffer_list); + Lisp_Object cll_tail = Fnthcdr (make_fixnum (depth), + Vcommand_loop_level_list); if (NILP (tail)) { tail = list1 (Qnil); Vminibuffer_list = nconc2 (Vminibuffer_list, tail); + cll_tail = list1 (Qnil); + Vcommand_loop_level_list = nconc2 (Vcommand_loop_level_list, cll_tail); } + XSETCAR (cll_tail, make_fixnum (depth ? command_loop_level : 0)); Lisp_Object buf = Fcar (tail); if (NILP (buf) || !BUFFER_LIVE_P (XBUFFER (buf))) { @@ -973,7 +996,6 @@ get_minibuffer (EMACS_INT depth) buf = Fget_buffer_create (lname, Qnil); /* Do this before set_minibuffer_mode. */ XSETCAR (tail, buf); - set_minibuffer_mode (buf, depth); /* Although the buffer's name starts with a space, undo should be enabled in it. */ Fbuffer_enable_undo (buf); @@ -985,12 +1007,19 @@ get_minibuffer (EMACS_INT depth) while the buffer doesn't know about them any more. */ delete_all_overlays (XBUFFER (buf)); reset_buffer (XBUFFER (buf)); - set_minibuffer_mode (buf, depth); } return buf; } +static EMACS_INT minibuf_c_loop_level (EMACS_INT depth) +{ + Lisp_Object cll = Fnth (make_fixnum (depth), Vcommand_loop_level_list); + if (FIXNUMP (cll)) + return XFIXNUM (cll); + return 0; +} + static void run_exit_minibuf_hook (void) { @@ -1004,17 +1033,16 @@ static void read_minibuf_unwind (void) { Lisp_Object old_deactivate_mark; - Lisp_Object window; + Lisp_Object calling_frame; + Lisp_Object calling_window; Lisp_Object future_mini_window; - /* If this was a recursive minibuffer, - tie the minibuffer window back to the outer level minibuffer buffer. */ - minibuf_level--; - - window = minibuf_window; /* To keep things predictable, in case it matters, let's be in the - minibuffer when we reset the relevant variables. */ - Fset_buffer (XWINDOW (window)->contents); + minibuffer when we reset the relevant variables. Don't depend on + `minibuf_window' here. This could by now be the mini-window of any + frame. */ + Fset_buffer (nth_minibuffer (minibuf_level)); + minibuf_level--; /* Restore prompt, etc, from outer minibuffer level. */ Lisp_Object key_vec = Fcar (minibuf_save_list); @@ -1042,6 +1070,10 @@ read_minibuf_unwind (void) #endif future_mini_window = Fcar (minibuf_save_list); minibuf_save_list = Fcdr (minibuf_save_list); + calling_frame = Fcar (minibuf_save_list); + minibuf_save_list = Fcdr (minibuf_save_list); + calling_window = Fcar (minibuf_save_list); + minibuf_save_list = Fcdr (minibuf_save_list); /* Erase the minibuffer we were using at this level. */ { @@ -1059,7 +1091,7 @@ read_minibuf_unwind (void) mini-window back to its normal size. */ if (minibuf_level == 0 || !EQ (selected_frame, WINDOW_FRAME (XWINDOW (future_mini_window)))) - resize_mini_window (XWINDOW (window), 0); + resize_mini_window (XWINDOW (minibuf_window), 0); /* Deal with frames that should be removed when exiting the minibuffer. */ @@ -1090,6 +1122,24 @@ read_minibuf_unwind (void) to make sure we don't leave around bindings and stuff which only made sense during the read_minibuf invocation. */ call0 (intern ("minibuffer-inactive-mode")); + + /* We've exited the recursive edit, so switch the current windows + away from the expired minibuffer window, both in the current + minibuffer's frame and the original calling frame. */ + choose_minibuf_frame (); + if (!EQ (WINDOW_FRAME (XWINDOW (minibuf_window)), calling_frame)) + { + Lisp_Object prev = Fprevious_window (minibuf_window, Qnil, Qnil); + /* PREV can be on a different frame when we have a minibuffer only + frame, the other frame's minibuffer window is MINIBUF_WINDOW, + and its "focus window" is also MINIBUF_WINDOW. */ + if (!EQ (prev, minibuf_window) + && EQ (WINDOW_FRAME (XWINDOW (prev)), + WINDOW_FRAME (XWINDOW (minibuf_window)))) + Fset_frame_selected_window (selected_frame, prev, Qnil); + } + else + Fset_frame_selected_window (calling_frame, calling_window, Qnil); } @@ -2137,6 +2187,7 @@ void init_minibuf_once (void) { staticpro (&Vminibuffer_list); + staticpro (&Vcommand_loop_level_list); pdumper_do_now_and_after_load (init_minibuf_once_for_pdumper); } @@ -2150,6 +2201,7 @@ init_minibuf_once_for_pdumper (void) restore from a dump file. pdumper doesn't try to preserve frames, windows, and so on, so reset everything related here. */ Vminibuffer_list = Qnil; + Vcommand_loop_level_list = Qnil; minibuf_level = 0; minibuf_prompt = Qnil; minibuf_save_list = Qnil; @@ -2380,6 +2432,7 @@ instead. */); defsubr (&Sminibufferp); defsubr (&Sinnermost_minibuffer_p); + defsubr (&Sminibuffer_innermost_command_loop_p); defsubr (&Sabort_minibuffers); defsubr (&Sminibuffer_prompt_end); defsubr (&Sminibuffer_contents); diff --git a/src/window.h b/src/window.h index 79eb44e7a38..b6f88e8f55f 100644 --- a/src/window.h +++ b/src/window.h @@ -1120,10 +1120,6 @@ void set_window_buffer (Lisp_Object window, Lisp_Object buffer, extern Lisp_Object echo_area_window; -/* Depth in recursive edits. */ - -extern EMACS_INT command_loop_level; - /* Non-zero if we should redraw the mode lines on the next redisplay. Usually set to a unique small integer so we can track the main causes of full redisplays in `redisplay--mode-lines-cause'. */ -- cgit v1.2.3 From 58e0c8ee86e2c36245f1c5a1483f1c73600b4914 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:21:24 +0100 Subject: Extend the syntax of `interactive' to list applicable modes * doc/lispref/commands.texi (Using Interactive): Document the extended `interactive' form. * doc/lispref/loading.texi (Autoload): Document list-of-modes form. * lisp/emacs-lisp/autoload.el (make-autoload): Pick the list of modes from `interactive' out of the functions. * lisp/emacs-lisp/bytecomp.el (byte-compile-lambda): Allow for the extended `interactive' form. * src/callint.c (Finteractive): Document the extended form. * src/data.c (Finteractive_form): Return the interactive form in the old format (even when there's an extended `interactive') to avoid having other parts of Emacs be aware of this. (Fcommand_modes): New defun. * src/emacs-module.c (GCALIGNED_STRUCT): Allow for modules to return command modes. * src/lisp.h: New function module_function_command_modes. --- doc/lispref/commands.texi | 19 +++++++++- doc/lispref/loading.texi | 3 ++ etc/NEWS | 8 ++++ lisp/emacs-lisp/autoload.el | 15 ++++++-- lisp/emacs-lisp/bytecomp.el | 40 ++++++++++++-------- src/callint.c | 9 ++++- src/data.c | 92 ++++++++++++++++++++++++++++++++++++++++++--- src/emacs-module.c | 8 +++- src/eval.c | 9 ++++- src/lisp.h | 3 ++ src/lread.c | 1 + 11 files changed, 179 insertions(+), 28 deletions(-) (limited to 'src/eval.c') diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index 3a2c7d019ef..d60745a825b 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -156,7 +156,7 @@ commands by adding the @code{interactive} form to them. makes a Lisp function an interactively-callable command, and how to examine a command's @code{interactive} form. -@defspec interactive arg-descriptor +@defspec interactive &optional arg-descriptor &rest modes This special form declares that a function is a command, and that it may therefore be called interactively (via @kbd{M-x} or by entering a key sequence bound to it). The argument @var{arg-descriptor} declares @@ -177,6 +177,23 @@ forms are executed; at this time, if the @code{interactive} form occurs within the body, the form simply returns @code{nil} without even evaluating its argument. +The @var{modes} list allows specifying which modes the command is +meant to be used in. This affects, for instance, completion in +@kbd{M-x} (commands won't be offered as completions if they don't +match (using @code{derived-mode-p}) the current major mode, or if the +mode is a minor mode, whether it's switched on in the current buffer). +This will also make @kbd{C-h m} list these commands (if they aren't +bound to any keys). + +For instance: + +@lisp +(interactive "p" dired-mode) +@end lisp + +This will mark the command as applicable for modes derived from +@code{dired-mode} only. + By convention, you should put the @code{interactive} form in the function body, as the first top-level form. If there is an @code{interactive} form in both the @code{interactive-form} symbol diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 33f37331947..8c6aeb04721 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -510,6 +510,9 @@ specification is not given here; it's not needed unless the user actually calls @var{function}, and when that happens, it's time to load the real definition. +If @var{interactive} is a list, it is interpreted as a list of modes +this command is applicable for. + You can autoload macros and keymaps as well as ordinary functions. Specify @var{type} as @code{macro} if @var{function} is really a macro. Specify @var{type} as @code{keymap} if @var{function} is really a diff --git a/etc/NEWS b/etc/NEWS index 08e1e94d83d..d8f0bc60726 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2266,6 +2266,14 @@ back in Emacs 23.1. The affected functions are: 'make-obsolete', * Lisp Changes in Emacs 28.1 ++++ +** The 'interactive' syntax has been extended to allow listing applicable modes. +Forms like '(interactive "p" dired-mode)' can be used to annotate the +commands as being applicable for modes derived from 'dired-mode', +or if the mode is a minor mode, that the current buffer has that +minor mode activated. Note that using this form will create byte code +that is not compatible with byte code in previous Emacs versions. + +++ ** New buffer-local variable 'minor-modes'. This permanently buffer-local variable holds a list of currently diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index ec7492dd4b1..ae17039645a 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -141,9 +141,12 @@ expression, in which case we want to handle forms differently." ((stringp (car-safe rest)) (car rest)))) ;; Look for an interactive spec. (interactive (pcase body - ((or `((interactive . ,_) . ,_) - `(,_ (interactive . ,_) . ,_)) - t)))) + ((or `((interactive . ,iargs) . ,_) + `(,_ (interactive . ,iargs) . ,_)) + ;; List of modes or just t. + (if (nthcdr 1 iargs) + (list 'quote (nthcdr 1 iargs)) + t))))) ;; Add the usage form at the end where describe-function-1 ;; can recover it. (when (consp args) (setq doc (help-add-fundoc-usage doc args))) @@ -207,7 +210,11 @@ expression, in which case we want to handle forms differently." easy-mmode-define-minor-mode define-minor-mode)) t) - (eq (car-safe (car body)) 'interactive)) + (and (eq (car-safe (car body)) 'interactive) + ;; List of modes or just t. + (or (if (nthcdr 1 (car body)) + (list 'quote (nthcdr 1 (car body))) + t)))) ,(if macrop ''macro nil)))) ;; For defclass forms, use `eieio-defclass-autoload'. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 89068a14f02..5c6b9c2e39a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2939,7 +2939,8 @@ for symbols generated by the byte compiler itself." ;; unless it is the last element of the body. (if (cdr body) (setq body (cdr body)))))) - (int (assq 'interactive body))) + (int (assq 'interactive body)) + command-modes) (when lexical-binding (dolist (var arglistvars) (when (assq var byte-compile--known-dynamic-vars) @@ -2951,9 +2952,10 @@ for symbols generated by the byte compiler itself." (if (eq int (car body)) (setq body (cdr body))) (cond ((consp (cdr int)) - (if (cdr (cdr int)) - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))) + (unless (seq-every-p #'symbolp (cdr (cdr int))) + (byte-compile-warn "malformed interactive specc: %s" + (prin1-to-string int))) + (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the ;; args of `list'. Actually, compile it to get warnings, @@ -2964,14 +2966,15 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (if (and (eq (car-safe form) 'list) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - (not lexical-binding)) - nil - (setq int `(interactive ,newform))))) + (setq int + (if (and (eq (car-safe form) 'list) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + (not lexical-binding)) + `(interactive ,form) + `(interactive ,newform))))) ((cdr int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string int))))) @@ -3002,9 +3005,16 @@ for symbols generated by the byte compiler itself." (list (help-add-fundoc-usage doc arglist))) ((or doc int) (list doc))) - ;; optionally, the interactive spec. - (if int - (list (nth 1 int)))))))) + ;; optionally, the interactive spec (and the modes the + ;; command applies to). + (cond + ;; We have some command modes, so use the vector form. + (command-modes + (list (vector (nth 1 int) command-modes))) + ;; No command modes, use the simple form with just the + ;; interactive spec. + (int + (list (nth 1 int))))))))) (defvar byte-compile-reserved-constants 0) diff --git a/src/callint.c b/src/callint.c index d3f49bc35d1..18624637843 100644 --- a/src/callint.c +++ b/src/callint.c @@ -104,7 +104,14 @@ If the string begins with `^' and `shift-select-mode' is non-nil, Emacs first calls the function `handle-shift-selection'. You may use `@', `*', and `^' together. They are processed in the order that they appear, before reading any arguments. -usage: (interactive &optional ARG-DESCRIPTOR) */ + +If MODES is present, it should be a list of mode names (symbols) that +this command is applicable for. The main effect of this is that +`M-x TAB' (by default) won't list this command if the current buffer's +mode doesn't match the list. That is, if either the major mode isn't +derived from them, or (when it's a minor mode) the mode isn't in effect. + +usage: (interactive &optional ARG-DESCRIPTOR &rest MODES) */ attributes: const) (Lisp_Object args) { diff --git a/src/data.c b/src/data.c index 38cde0ff8b2..7bddc039f6f 100644 --- a/src/data.c +++ b/src/data.c @@ -904,7 +904,17 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (COMPILEDP (fun)) { if (PVSIZE (fun) > COMPILED_INTERACTIVE) - return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE)); + { + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + if (VECTORP (form)) + /* The vector form is the new form, where the first + element is the interactive spec, and the second is the + command modes. */ + return list2 (Qinteractive, AREF (form, 0)); + else + /* Old form -- just the interactive spec. */ + return list2 (Qinteractive, form); + } } #ifdef HAVE_MODULES else if (MODULE_FUNCTIONP (fun)) @@ -920,10 +930,80 @@ Value, if non-nil, is a list (interactive SPEC). */) else if (CONSP (fun)) { Lisp_Object funcar = XCAR (fun); - if (EQ (funcar, Qclosure)) - return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))); - else if (EQ (funcar, Qlambda)) - return Fassq (Qinteractive, Fcdr (XCDR (fun))); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + Lisp_Object spec = Fassq (Qinteractive, form); + if (NILP (Fcdr (Fcdr (spec)))) + return spec; + else + return list2 (Qinteractive, Fcar (Fcdr (spec))); + } + } + return Qnil; +} + +DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0, + doc: /* Return the modes COMMAND is defined for. +If COMMAND is not a command, the return value is nil. +The value, if non-nil, is a list of mode name symbols. */) + (Lisp_Object command) +{ + Lisp_Object fun = indirect_function (command); /* Check cycles. */ + + if (NILP (fun)) + return Qnil; + + fun = command; + while (SYMBOLP (fun)) + fun = Fsymbol_function (fun); + + if (SUBRP (fun)) + { + if (!NILP (XSUBR (fun)->command_modes)) + return XSUBR (fun)->command_modes; + } + else if (COMPILEDP (fun)) + { + Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); + if (VECTORP (form)) + /* New form -- the second element is the command modes. */ + return AREF (form, 1); + else + /* Old .elc file -- no command modes. */ + return Qnil; + } +#ifdef HAVE_MODULES + else if (MODULE_FUNCTIONP (fun)) + { + Lisp_Object form + = module_function_command_modes (XMODULE_FUNCTION (fun)); + if (! NILP (form)) + return form; + } +#endif + else if (AUTOLOADP (fun)) + { + Lisp_Object modes = Fnth (make_int (3), fun); + if (CONSP (modes)) + return modes; + else + return Qnil; + } + else if (CONSP (fun)) + { + Lisp_Object funcar = XCAR (fun); + if (EQ (funcar, Qclosure) + || EQ (funcar, Qlambda)) + { + Lisp_Object form = Fcdr (XCDR (fun)); + if (EQ (funcar, Qclosure)) + form = Fcdr (form); + return Fcdr (Fcdr (Fassq (Qinteractive, form))); + } } return Qnil; } @@ -3908,6 +3988,7 @@ syms_of_data (void) defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); + defsubr (&Scommand_modes); defsubr (&Seq); defsubr (&Snull); defsubr (&Stype_of); @@ -4030,6 +4111,7 @@ This variable cannot be set; trying to do so will signal an error. */); DEFSYM (Qunlet, "unlet"); DEFSYM (Qset, "set"); DEFSYM (Qset_default, "set-default"); + DEFSYM (Qcommand_modes, "command-modes"); defsubr (&Sadd_variable_watcher); defsubr (&Sremove_variable_watcher); defsubr (&Sget_variable_watchers); diff --git a/src/emacs-module.c b/src/emacs-module.c index 894dffcf21e..f8fb54c0728 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -549,7 +549,7 @@ struct Lisp_Module_Function union vectorlike_header header; /* Fields traced by GC; these must come first. */ - Lisp_Object documentation, interactive_form; + Lisp_Object documentation, interactive_form, command_modes; /* Fields ignored by GC. */ ptrdiff_t min_arity, max_arity; @@ -646,6 +646,12 @@ module_function_interactive_form (const struct Lisp_Module_Function *fun) return fun->interactive_form; } +Lisp_Object +module_function_command_modes (const struct Lisp_Module_Function *fun) +{ + return fun->command_modes; +} + static emacs_value module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs, emacs_value *args) diff --git a/src/eval.c b/src/eval.c index 91fc4e68377..542d7f686e6 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2080,14 +2080,21 @@ then strings and vectors are not accepted. */) DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0, doc: /* Define FUNCTION to autoload from FILE. FUNCTION is a symbol; FILE is a file name string to pass to `load'. + Third arg DOCSTRING is documentation for the function. -Fourth arg INTERACTIVE if non-nil says function can be called interactively. + +Fourth arg INTERACTIVE if non-nil says function can be called +interactively. If INTERACTIVE is a list, it is interpreted as a list +of modes the function is applicable for. + Fifth arg TYPE indicates the type of the object: nil or omitted says FUNCTION is a function, `keymap' says FUNCTION is really a keymap, and `macro' or t says FUNCTION is really a macro. + Third through fifth args give info about the real definition. They default to nil. + If FUNCTION is already defined other than as an autoload, this does nothing and returns nil. */) (Lisp_Object function, Lisp_Object file, Lisp_Object docstring, Lisp_Object interactive, Lisp_Object type) diff --git a/src/lisp.h b/src/lisp.h index 0847324d1ff..697dd89363c 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2060,6 +2060,7 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; + Lisp_Object command_modes; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4221,6 +4222,8 @@ extern Lisp_Object module_function_documentation (struct Lisp_Module_Function const *); extern Lisp_Object module_function_interactive_form (const struct Lisp_Module_Function *); +extern Lisp_Object module_function_command_modes + (const struct Lisp_Module_Function *); extern module_funcptr module_function_address (struct Lisp_Module_Function const *); extern void *module_function_data (const struct Lisp_Module_Function *); diff --git a/src/lread.c b/src/lread.c index dea1b232fff..8b8ba93c607 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4467,6 +4467,7 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); + sname->command_modes = Qnil; } #ifdef NOTDEF /* Use fset in subr.el now! */ -- cgit v1.2.3 From 6ad9b8d677fe136b9a0489eef0c2dd6a1f63917d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 11:42:04 -0500 Subject: * src/eval.c (init_eval_once): Bump max_specpdl_size (bug46818) Further testing seems to confirm my suspicion that the increase in the specpdl comes from the recent change to `pcase--if`. * lisp/international/mule-cmds.el (update-leim-list-file): Revert workaround. --- lisp/international/mule-cmds.el | 9 ++------- src/eval.c | 2 +- 2 files changed, 3 insertions(+), 8 deletions(-) (limited to 'src/eval.c') diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index e1dbf82ed49..e4bdf50f526 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -1312,13 +1312,8 @@ Each function is called with one arg, LEIM directory name.") (defun update-leim-list-file (&rest dirs) "Update LEIM list file in directories DIRS." - ;; bug#46818: This `let'-binding is not necessary, but - ;; it reduces the recursion depth during bootstrap (at which - ;; point some of the core ELisp files haven't been byte-compiled - ;; yet, which causes deeper-than-normal recursion). - (let ((vc-handled-backends nil)) - (dolist (function update-leim-list-functions) - (apply function dirs)))) + (dolist (function update-leim-list-functions) + (apply function dirs))) (defvar-local current-input-method nil "The current input method for multilingual text. diff --git a/src/eval.c b/src/eval.c index 542d7f686e6..ddaa8edd817 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,7 +219,7 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ - max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ + max_specpdl_size = 1800; /* See bug#46818. */ max_lisp_eval_depth = 800; Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); -- cgit v1.2.3 From 7893945cc8f9421d0be5b07b9ed404bdf25ce140 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Wed, 7 Apr 2021 11:31:07 +0200 Subject: Add condition-case success handler (bug#47677) Allow a condition-case handler on the form (:success BODY) to be specified as the success continuation of the protected form, with the specified variable bound to its result. * src/eval.c (Fcondition_case): Update the doc string. (internal_lisp_condition_case): Implement in interpreter. (syms_of_eval): Defsym :success. * lisp/emacs-lisp/bytecomp.el (byte-compile-condition-case): Implement in byte-compiler. * lisp/emacs-lisp/cl-macs.el (cl--self-tco): Allow self-TCO from success handler. * doc/lispref/control.texi (Handling Errors): Update manual. * etc/NEWS: Announce. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases) (bytecomp-condition-case-success): * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels): Add test cases. --- doc/lispref/control.texi | 9 ++- etc/NEWS | 6 ++ lisp/emacs-lisp/bytecomp.el | 63 +++++++++------- lisp/emacs-lisp/cl-macs.el | 4 +- src/eval.c | 34 ++++++++- test/lisp/emacs-lisp/bytecomp-tests.el | 127 +++++++++++++++++++++++++++++++++ test/lisp/emacs-lisp/cl-macs-tests.el | 9 +-- 7 files changed, 219 insertions(+), 33 deletions(-) (limited to 'src/eval.c') diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 3388102f694..22b665bc931 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -2012,7 +2012,8 @@ that can be handled). This special form establishes the error handlers @var{handlers} around the execution of @var{protected-form}. If @var{protected-form} executes without error, the value it returns becomes the value of the -@code{condition-case} form; in this case, the @code{condition-case} has +@code{condition-case} form (in the absence of a success handler; see below). +In this case, the @code{condition-case} has no effect. The @code{condition-case} form makes a difference when an error occurs during @var{protected-form}. @@ -2062,6 +2063,12 @@ error description. If @var{var} is @code{nil}, that means no variable is bound. Then the error symbol and associated data are not available to the handler. +@cindex success handler +As a special case, one of the @var{handlers} can be a list of the +form @code{(:success @var{body}@dots{})}, where @var{body} is executed +with @var{var} (if non-@code{nil}) bound to the return value of +@var{protected-form} when that expression terminates without error. + @cindex rethrow a signal Sometimes it is necessary to re-throw a signal caught by @code{condition-case}, for some outer-level handler to catch. Here's diff --git a/etc/NEWS b/etc/NEWS index d4f942bafe3..6113aa6fb22 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2935,6 +2935,12 @@ arrays nor objects. The special events 'dbus-event' and 'file-notify' are now ignored in 'while-no-input' when added to this variable. ++++ +** 'condition-case' now allows for a success handler. +It is written as (:success BODY...) where BODY is executed whenever +the protected form terminates without error, with the specified +variable bound to the the value of the protected form. + * Changes in Emacs 28.1 on Non-Free Operating Systems diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 0babbbb978d..4f91f0d5dea 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4621,10 +4621,15 @@ binding slots have been popped." (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) (body (nth 2 form)) + (handlers (nthcdr 3 form)) (depth byte-compile-depth) + (success-handler (assq :success handlers)) + (failure-handlers (if success-handler + (remq success-handler handlers) + handlers)) (clauses (mapcar (lambda (clause) (cons (byte-compile-make-tag) clause)) - (nthcdr 3 form))) + failure-handlers)) (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) @@ -4650,30 +4655,40 @@ binding slots have been popped." (byte-compile-form body) ;; byte-compile--for-effect (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (byte-compile-goto 'byte-goto endtag) - (while clauses - (let ((clause (pop clauses)) - (byte-compile-bound-variables byte-compile-bound-variables) - (byte-compile--lexical-environment - byte-compile--lexical-environment)) - (setq byte-compile-depth (1+ depth)) - (byte-compile-out-tag (pop clause)) - (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) - (cond - ((null var) (byte-compile-discard)) - (lexical-binding - (push (cons var (1- byte-compile-depth)) - byte-compile--lexical-environment)) - (t (byte-compile-dynamic-variable-bind var))) - (byte-compile-body (cdr clause)) ;; byte-compile--for-effect - (cond - ((null var) nil) - (lexical-binding (byte-compile-discard 1 'preserve-tos)) - (t (byte-compile-out 'byte-unbind 1))) - (byte-compile-goto 'byte-goto endtag))) - - (byte-compile-out-tag endtag))) + (let ((compile-handler-body + (lambda (body) + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) + + (byte-compile-body body) ;; byte-compile--for-effect + + (cond + ((null var)) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))))))) + + (when success-handler + (funcall compile-handler-body (cdr success-handler))) + + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses))) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (funcall compile-handler-body (cdr clause)) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag)))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 68211ec4106..b7e5be95bc3 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2144,7 +2144,9 @@ Like `cl-flet' but the definitions can refer to previous ones. ((and `(condition-case ,err-var ,bodyform . ,handlers) (guard (not (eq err-var var)))) `(condition-case ,err-var - (progn (setq ,retvar ,bodyform) nil) + ,(if (assq :success handlers) + bodyform + `(progn (setq ,retvar ,bodyform) nil)) . ,(mapcar (lambda (h) (cons (car h) (funcall opt-exps (cdr h)))) handlers))) diff --git a/src/eval.c b/src/eval.c index ddaa8edd817..fd93f5b9e1f 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1301,7 +1301,7 @@ DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0, doc: /* Regain control when an error is signaled. Executes BODYFORM and returns its value if no error happens. Each element of HANDLERS looks like (CONDITION-NAME BODY...) -where the BODY is made of Lisp expressions. +or (:success BODY...), where the BODY is made of Lisp expressions. A handler is applicable to an error if CONDITION-NAME is one of the error's condition names. Handlers may also apply when non-error @@ -1323,6 +1323,10 @@ with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error. Then the value of the last BODY form is returned from the `condition-case' expression. +The special handler (:success BODY...) is invoked if BODYFORM terminated +without signalling an error. BODY is then evaluated with VAR bound to +the value returned by BODYFORM. + See also the function `signal' for more info. usage: (condition-case VAR BODYFORM &rest HANDLERS) */) (Lisp_Object args) @@ -1346,16 +1350,21 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, CHECK_SYMBOL (var); + Lisp_Object success_handler = Qnil; + for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail)) { Lisp_Object tem = XCAR (tail); - clausenb++; if (! (NILP (tem) || (CONSP (tem) && (SYMBOLP (XCAR (tem)) || CONSP (XCAR (tem)))))) error ("Invalid condition handler: %s", SDATA (Fprin1_to_string (tem, Qt))); + if (EQ (XCAR (tem), QCsuccess)) + success_handler = XCDR (tem); + else + clausenb++; } /* The first clause is the one that should be checked first, so it @@ -1369,7 +1378,8 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses); clauses += clausenb; for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail)) - *--clauses = XCAR (tail); + if (!EQ (XCAR (XCAR (tail)), QCsuccess)) + *--clauses = XCAR (tail); for (ptrdiff_t i = 0; i < clausenb; i++) { Lisp_Object clause = clauses[i]; @@ -1409,6 +1419,23 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, Lisp_Object result = eval_sub (bodyform); handlerlist = oldhandlerlist; + if (!NILP (success_handler)) + { + if (NILP (var)) + return Fprogn (success_handler); + + Lisp_Object handler_var = var; + if (!NILP (Vinternal_interpreter_environment)) + { + result = Fcons (Fcons (var, result), + Vinternal_interpreter_environment); + handler_var = Qinternal_interpreter_environment; + } + + ptrdiff_t count = SPECPDL_INDEX (); + specbind (handler_var, result); + return unbind_to (count, Fprogn (success_handler)); + } return result; } @@ -4381,6 +4408,7 @@ alist of active lexical bindings. */); defsubr (&Sthrow); defsubr (&Sunwind_protect); defsubr (&Scondition_case); + DEFSYM (QCsuccess, ":success"); defsubr (&Ssignal); defsubr (&Scommandp); defsubr (&Sautoload); diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a11832d805e..c9ab3ec1f1b 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -444,6 +444,65 @@ (arith-error (prog1 (lambda (y) (+ y x)) (setq x 10)))) 4) + + ;; No error, no success handler. + (condition-case x + (list 42) + (error (cons 'bad x))) + ;; Error, no success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x))) + ;; No error, success handler. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Error, success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Verify that the success code is not subject to the error handlers. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + ;; Check variable scoping on success. + (let ((x 2)) + (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check variable scoping on failure. + (let ((x 2)) + (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check capture of mutated result variable. + (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + ;; Check for-effect context, on error. + (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + ;; Check for-effect context, on success. + (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -1185,6 +1244,74 @@ compiled correctly." (let ((lexical-binding t)) (should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy) "foo")))) +(ert-deftest bytecomp-condition-case-success () + ;; No error, no success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x))) + '(42))) + ;; Error, no success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x))) + '(bad arith-error))) + ;; No error, success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(good 42))) + ;; Error, success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(bad arith-error))) + ;; Verify that the success code is not subject to the error handlers. + (should-error (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + :type 'arith-error) + ;; Check variable scoping. + (let ((x 2)) + (should (equal (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x))) + '(good (2)))) + (should (equal (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x))) + '(bad (arith-error))))) + ;; Check capture of mutated result variable. + (should (equal (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + 14)) + ;; Check for-effect context, on error. + (should (equal (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4)) + ;; Check for-effect context, on success. + (should (equal (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 5c3e603b92e..f4e2e46a019 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -630,12 +630,13 @@ collection clause." (and xs (progn (setq n1 (1+ n)) (len2 (cdr xs) n1)))))) - ;; Tail call in error handler. + ;; Tail calls in error and success handlers. (len3 (xs n) (if xs - (condition-case nil - (/ 1 0) - (arith-error (len3 (cdr xs) (1+ n)))) + (condition-case k + (/ 1 (logand n 1)) + (arith-error (len3 (cdr xs) (1+ n))) + (:success (len3 (cdr xs) (+ n k)))) n))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) -- cgit v1.2.3 From eb7582620704a33f23d2c9952790b998e4396995 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 17 May 2021 18:10:49 +0300 Subject: Avoid crashes in condition-case * src/eval.c (internal_lisp_condition_case): Don't take XCAR without making sure the value is a cons cell. (Bug#48479) --- src/eval.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index aeedcc50cc0..18faa0b9b15 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1370,7 +1370,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, || CONSP (XCAR (tem)))))) error ("Invalid condition handler: %s", SDATA (Fprin1_to_string (tem, Qt))); - if (EQ (XCAR (tem), QCsuccess)) + if (CONSP (tem) && EQ (XCAR (tem), QCsuccess)) success_handler = XCDR (tem); else clausenb++; @@ -1387,8 +1387,11 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses); clauses += clausenb; for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail)) - if (!EQ (XCAR (XCAR (tail)), QCsuccess)) - *--clauses = XCAR (tail); + { + Lisp_Object tem = XCAR (tail); + if (!(CONSP (tem) && EQ (XCAR (tem), QCsuccess))) + *--clauses = tem; + } for (ptrdiff_t i = 0; i < clausenb; i++) { Lisp_Object clause = clauses[i]; -- cgit v1.2.3 From c22cf4d02ff7ebd85839aac5336f6e279f32db54 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Mon, 12 Jul 2021 00:07:38 -0700 Subject: Pacify gcc 11.1.1 -Wclobbered * src/eval.c (Fprogn, internal_lisp_condition_case): Add CACHEABLE to work around more instances of -Wclobbered bug. --- src/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index 18faa0b9b15..b76ced79d61 100644 --- a/src/eval.c +++ b/src/eval.c @@ -462,7 +462,7 @@ DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0, usage: (progn BODY...) */) (Lisp_Object body) { - Lisp_Object val = Qnil; + Lisp_Object CACHEABLE val = Qnil; while (CONSP (body)) { @@ -1429,7 +1429,7 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, } } - Lisp_Object result = eval_sub (bodyform); + Lisp_Object CACHEABLE result = eval_sub (bodyform); handlerlist = oldhandlerlist; if (!NILP (success_handler)) { -- cgit v1.2.3 From da4b3973deb5eb271d79568092ad25560b65dbf8 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Wed, 21 Jul 2021 16:53:54 +0200 Subject: Make `C-g' after `M-x' not give a backtrace unless required * src/eval.c (signal_quit_p): New function. (maybe_call_debugger): React to all `quit' signals (bug#49675). * src/keyboard.c (cmd_error_internal, menu_item_eval_property_1): Ditto. --- src/eval.c | 14 +++++++++++++- src/keyboard.c | 4 ++-- src/lisp.h | 1 + 3 files changed, 16 insertions(+), 3 deletions(-) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index b76ced79d61..ddf7e703fc2 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2026,6 +2026,18 @@ skip_debugger (Lisp_Object conditions, Lisp_Object data) return 0; } +/* Say whether SIGNAL is a `quit' symbol (or inherits from it). */ +bool +signal_quit_p (Lisp_Object signal) +{ + Lisp_Object list; + + return EQ (signal, Qquit) + || (Fsymbolp (signal) + && CONSP (list = Fget (signal, Qerror_conditions)) + && Fmemq (Qquit, list)); +} + /* Call the debugger if calling it is currently enabled for CONDITIONS. SIG and DATA describe the signal. There are two ways to pass them: = SIG is the error symbol, and DATA is the rest of the data. @@ -2044,7 +2056,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data) ! input_blocked_p () && NILP (Vinhibit_debugger) /* Does user want to enter debugger for this kind of error? */ - && (EQ (sig, Qquit) + && (signal_quit_p (sig) ? debug_on_quit : wants_debugger (Vdebug_on_error, conditions)) && ! skip_debugger (conditions, combined_data) diff --git a/src/keyboard.c b/src/keyboard.c index db934686594..38118071a80 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -985,7 +985,7 @@ cmd_error_internal (Lisp_Object data, const char *context) { /* The immediate context is not interesting for Quits, since they are asynchronous. */ - if (EQ (XCAR (data), Qquit)) + if (signal_quit_p (XCAR (data))) Vsignaling_function = Qnil; Vquit_flag = Qnil; @@ -7634,7 +7634,7 @@ menu_item_eval_property_1 (Lisp_Object arg) { /* If we got a quit from within the menu computation, quit all the way out of it. This takes care of C-] in the debugger. */ - if (CONSP (arg) && EQ (XCAR (arg), Qquit)) + if (CONSP (arg) && signal_quit_p (XCAR (arg))) quit (); return Qnil; diff --git a/src/lisp.h b/src/lisp.h index b3f1dc16b13..80efd771139 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4116,6 +4116,7 @@ extern Lisp_Object Vautoload_queue; extern Lisp_Object Vrun_hooks; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; +extern bool signal_quit_p (Lisp_Object); /* To run a normal hook, use the appropriate function from the list below. The calling convention: -- cgit v1.2.3 From 0576b81ca79c9cb0c156de66c924b1610e26dcff Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 21 Jul 2021 11:12:25 -0400 Subject: * src/eval.c (signal_quit_p): Fix the usual int/Lisp_Object mixup --- src/eval.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/eval.c') diff --git a/src/eval.c b/src/eval.c index ddf7e703fc2..48104bd0f45 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2033,9 +2033,9 @@ signal_quit_p (Lisp_Object signal) Lisp_Object list; return EQ (signal, Qquit) - || (Fsymbolp (signal) + || (!NILP (Fsymbolp (signal)) && CONSP (list = Fget (signal, Qerror_conditions)) - && Fmemq (Qquit, list)); + && !NILP (Fmemq (Qquit, list))); } /* Call the debugger if calling it is currently enabled for CONDITIONS. -- cgit v1.2.3