From 9709ff1436d547664e6b3ca252cd37665467b4de Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 18 Sep 2019 12:46:45 +0200 Subject: add native_elisp field into Lisp_Subr --- src/data.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 56e363f16b6..70068c30a71 100644 --- a/src/data.c +++ b/src/data.c @@ -864,6 +864,17 @@ SUBR must be a built-in function. */) return build_string (name); } +#ifdef HAVE_NATIVE_COMP +DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, + doc: /* Return t if the subr is native compiled elisp, +nil otherwise. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_elisp ? Qt : Qnil; +} +#endif + DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, doc: /* Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. @@ -3983,6 +3994,9 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_elispp); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif -- cgit v1.2.3 From 7d3da0a37edd57f6a31dff4864bcf1753de48698 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 26 Sep 2019 12:11:13 +0200 Subject: fix subr-native-elisp-p predicate name --- lisp/emacs-lisp/comp.el | 2 +- src/data.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 13bc3de5ac9..209c4e68b6a 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1387,7 +1387,7 @@ This can run just once." (callee-in-unit (gethash callee (comp-ctxt-funcs-h comp-ctxt)))) (cond - ((and subrp (not (subr-native-elispp f))) + ((and subrp (not (subr-native-elisp-p f))) ;; Trampoline removal. (let* ((maxarg (cdr (subr-arity f))) (call-type (if (if subrp diff --git a/src/data.c b/src/data.c index 70068c30a71..2a32d47c49b 100644 --- a/src/data.c +++ b/src/data.c @@ -865,7 +865,7 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-elispp", Fsubr_native_elispp, Ssubr_native_elispp, 1, 1, 0, +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, doc: /* Return t if the subr is native compiled elisp, nil otherwise. */) (Lisp_Object subr) @@ -3995,7 +3995,7 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_elispp); + defsubr (&Ssubr_native_elisp_p); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); -- cgit v1.2.3 From a1fd3d6eacaf425eadd121dcacee95a26f96505f Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 14 Nov 2019 21:36:30 +0100 Subject: improve subr-native-elisp-p --- src/data.c | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 2a32d47c49b..50dce9e4644 100644 --- a/src/data.c +++ b/src/data.c @@ -866,12 +866,11 @@ SUBR must be a built-in function. */) #ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled elisp, + doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) - (Lisp_Object subr) + (Lisp_Object object) { - CHECK_SUBR (subr); - return XSUBR (subr)->native_elisp ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; } #endif -- cgit v1.2.3 From a248dfe2c3341ed73de38c2feea64ec12f053aaa Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Dec 2019 18:19:00 +0100 Subject: native compile interactive functions support --- lisp/emacs-lisp/comp.el | 10 +++++----- src/alloc.c | 4 ++-- src/comp.c | 6 +++--- src/data.c | 4 ++++ src/lisp.h | 9 +++++++-- 5 files changed, 21 insertions(+), 12 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e46453e8516..ffd4985301e 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1076,9 +1076,7 @@ the annotation emission." (cl-defmethod comp-emit-for-top-level ((form byte-to-native-function)) (let* ((name (byte-to-native-function-name form)) (f (gethash name (comp-ctxt-funcs-h comp-ctxt))) - (args (comp-func-args f)) - (c-name (comp-func-c-name f)) - (doc (comp-func-doc f))) + (args (comp-func-args f))) (cl-assert (and name f)) (comp-emit (comp-call 'comp--register-subr (make-comp-mvar :constant name) @@ -1086,8 +1084,10 @@ the annotation emission." (make-comp-mvar :constant (if (comp-args-p args) (comp-args-max args) 'many)) - (make-comp-mvar :constant c-name) - (make-comp-mvar :constant doc))))) + (make-comp-mvar :constant (comp-func-c-name f)) + (make-comp-mvar :constant (comp-func-doc f)) + (make-comp-mvar :constant + (comp-func-int-spec f)))))) (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)) (let ((form (byte-to-native-top-level-form form))) diff --git a/src/alloc.c b/src/alloc.c index 00da90464be..5ff0d907915 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -7450,14 +7450,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}}}; + 4, 4, "watch_gc_cons_threshold", {0}, {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}}}; + 4, 4, "watch_gc_cons_percentage", {0}, {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 5a00200ee87..a15bedf41aa 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3304,11 +3304,11 @@ load_comp_unit (dynlib_handle_ptr handle, Lisp_Object file) DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 5, 5, 0, + 6, 6, 0, doc: /* This gets called by top_level_run during load phase to register each exported subr. */) (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc) + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec) { dynlib_handle_ptr handle = xmint_pointer (XCAR (load_handle_stack)); if (!handle) @@ -3325,7 +3325,7 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, x->s.min_args = XFIXNUM (minarg); x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; x->s.symbol_name = xstrdup (SSDATA (Fsymbol_name (name))); - x->s.intspec = NULL; + x->s.native_intspec = intspec; x->s.native_doc = doc; x->s.native_elisp = true; defsubr (x); diff --git a/src/data.c b/src/data.c index 50dce9e4644..67613881d67 100644 --- a/src/data.c +++ b/src/data.c @@ -899,6 +899,10 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { +#ifdef HAVE_NATIVE_COMP + if (XSUBR (fun)->native_elisp && 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/lisp.h b/src/lisp.h index 1c692933cdb..56aa7b151e6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2086,7 +2086,12 @@ struct Lisp_Subr } function; short min_args, max_args; const char *symbol_name; - const char *intspec; + union { + const char *intspec; +#ifdef HAVE_NATIVE_COMP + Lisp_Object native_intspec; +#endif + }; union { EMACS_INT doc; #ifdef HAVE_NATIVE_COMP @@ -3106,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}}}; \ + minargs, maxargs, lname, {intspec}, {0}, 0}}; \ Lisp_Object fnname /* defsubr (Sname); -- cgit v1.2.3 From b3cbdfc86474932e4ef8d1237ed100a6f4f4c854 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 19 Dec 2019 11:06:38 +0100 Subject: add basic compilation unit into structure --- src/comp.c | 1 - src/data.c | 4 ++-- src/lisp.h | 11 ++++++++++- src/pdumper.c | 2 +- 4 files changed, 13 insertions(+), 5 deletions(-) (limited to 'src/data.c') diff --git a/src/comp.c b/src/comp.c index ce2a542e7cf..79ece461a54 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3280,7 +3280,6 @@ 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_elisp = true; XSETPVECTYPE (&x->s, PVEC_SUBR); Lisp_Object tem; XSETSUBR (tem, &x->s); diff --git a/src/data.c b/src/data.c index 67613881d67..0a13569bc6d 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_elisp) ? Qt : Qnil; + return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_elisp && XSUBR (fun)->native_intspec) + if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index d0f7a9720c0..04f729f182a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -34,6 +34,10 @@ along with GNU Emacs. If not, see . */ #include #include +#ifdef HAVE_NATIVE_COMP +#include +#endif + INLINE_HEADER_BEGIN /* Define a TYPE constant ID as an externally visible name. Use like this: @@ -2064,6 +2068,11 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } +struct Native_Compilation_Unit +{ + dynlib_handle_ptr handle; +}; + /* This structure describes a built-in function. It is generated by the DEFUN macro only. defsubr makes it into a Lisp object. */ @@ -2095,7 +2104,7 @@ struct Lisp_Subr Lisp_Object native_doc; }; #ifdef HAVE_NATIVE_COMP - bool native_elisp; + struct Native_Compilation_Unit *native_comp_u;; #endif } GCALIGNED_STRUCT; union Aligned_Lisp_Subr diff --git a/src/pdumper.c b/src/pdumper.c index 38b70146b4f..24698d48b57 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2938,7 +2938,7 @@ 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); #ifdef HAVE_NATIVE_COMP - DUMP_FIELD_COPY (&out, subr, native_elisp); + dump_field_emacs_ptr (ctx, &out, subr, &subr->native_comp_u); #endif return dump_object_finish (ctx, &out, sizeof (out)); } -- cgit v1.2.3 From 9a8f33f285295daff8ed02d35ece5e8fe11ac887 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 20 Dec 2019 05:53:28 +0100 Subject: introduce SUBRP_NATIVE_COMPILEDP --- src/alloc.c | 4 ++-- src/data.c | 4 ++-- src/lisp.h | 8 ++++++++ 3 files changed, 12 insertions(+), 4 deletions(-) (limited to 'src/data.c') diff --git a/src/alloc.c b/src/alloc.c index d990f53f7a0..dba2c2df881 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6566,7 +6566,7 @@ mark_object (Lisp_Object arg) case PVEC_SUBR: #ifdef HAVE_NATIVE_COMP - if (XSUBR (obj)->native_comp_u) + if (SUBRP_NATIVE_COMPILEDP (obj)) set_vector_marked (ptr); #endif break; @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: #ifdef HAVE_NATIVE_COMP survives_p = - (SUBRP (obj) && !XSUBR (obj)->native_comp_u) || + (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); #else survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); diff --git a/src/data.c b/src/data.c index 0a13569bc6d..fd20ecce696 100644 --- a/src/data.c +++ b/src/data.c @@ -870,7 +870,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return (SUBRP (object) && XSUBR (object)->native_comp_u) ? Qt : Qnil; + return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #endif @@ -900,7 +900,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { #ifdef HAVE_NATIVE_COMP - if (XSUBR (fun)->native_comp_u && XSUBR (fun)->native_intspec) + if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; #endif const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index bb441b181a1..05d6ef0d22a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2136,6 +2136,14 @@ enum char_table_specials = PSEUDOVECSIZE (struct Lisp_Sub_Char_Table, contents) - 1 }; +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && XSUBR (a)->native_comp_u; +} +#endif + /* Sanity-check pseudovector layout. */ verify (offsetof (struct Lisp_Char_Table, defalt) == header_size); verify (offsetof (struct Lisp_Char_Table, extras) -- cgit v1.2.3 From 5dae0a9a55101aeb668f90e1fece1ffbab5e7ee2 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 22 Dec 2019 09:52:46 +0100 Subject: add support for native comp unit to type-of --- src/data.c | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index fd20ecce696..73ddb021e23 100644 --- a/src/data.c +++ b/src/data.c @@ -265,6 +265,8 @@ for example, (type-of 1) returns `integer'. */) } case PVEC_MODULE_FUNCTION: return Qmodule_function; + case PVEC_NATIVE_COMP_UNIT: + return Qnative_comp_unit; case PVEC_XWIDGET: return Qxwidget; case PVEC_XWIDGET_VIEW: @@ -3876,6 +3878,7 @@ syms_of_data (void) DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); + DEFSYM (Qnative_comp_unit, "native-comp-unit"); DEFSYM (Quser_ptr, "user-ptr"); DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); -- cgit v1.2.3 From fd3c00ff92826b466a3292a05072eb5b4f23a701 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 09:04:24 +0100 Subject: add subr-native-compilation-unit primitive --- src/data.c | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 73ddb021e23..70f8a8f2c1a 100644 --- a/src/data.c +++ b/src/data.c @@ -867,13 +867,22 @@ SUBR must be a built-in function. */) } #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, - doc: /* Return t if the object is native compiled lisp function, +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, + 0, doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) (Lisp_Object object) { return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; } + +DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, + Ssubr_native_comp_unit, 1, 1, 0, + doc: /* Return the native compilation unit. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_comp_u; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4002,6 +4011,7 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); + defsubr (&Ssubr_native_compilation_unit); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); -- cgit v1.2.3 From df0a7547cbaf19152a74b5dda760e5d1f6c92ecc Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 23 Dec 2019 09:40:41 +0100 Subject: add native-comp-unit-file primitive --- src/data.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 70f8a8f2c1a..3fb0fc0a190 100644 --- a/src/data.c +++ b/src/data.c @@ -883,6 +883,15 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, CHECK_SUBR (subr); return XSUBR (subr)->native_comp_u; } + +DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, + Snative_comp_unit_file, 1, 1, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object object) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); + return XNATIVE_COMP_UNIT (object)->file; +} #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, @@ -4011,7 +4020,8 @@ syms_of_data (void) defsubr (&Ssubr_name); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); - defsubr (&Ssubr_native_compilation_unit); + defsubr (&Ssubr_native_comp_unit); + defsubr (&Snative_comp_unit_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); -- 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/data.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 fdb31d6a2709bff751c2ad240c41b30db1848b44 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Wed, 25 Dec 2019 23:04:13 +0100 Subject: fix naming for predicate SUBR_NATIVE_COMPILEDP --- src/alloc.c | 4 ++-- src/data.c | 4 ++-- src/doc.c | 2 +- src/lisp.h | 4 ++-- src/pdumper.c | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) (limited to 'src/data.c') diff --git a/src/alloc.c b/src/alloc.c index 6d6f6934bab..faa8e703937 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6564,7 +6564,7 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: - if (SUBRP_NATIVE_COMPILEDP (obj)) + if (SUBR_NATIVE_COMPILEDP (obj)) { set_vector_marked (ptr); struct Lisp_Subr *subr = XSUBR (obj); @@ -6715,7 +6715,7 @@ survives_gc_p (Lisp_Object obj) case Lisp_Vectorlike: survives_p = - (SUBRP (obj) && !SUBRP_NATIVE_COMPILEDP (obj)) || + (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) || vector_marked_p (XVECTOR (obj)); break; diff --git a/src/data.c b/src/data.c index d20db4dc3a3..191fb313687 100644 --- a/src/data.c +++ b/src/data.c @@ -872,7 +872,7 @@ DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, nil otherwise. */) (Lisp_Object object) { - return SUBRP_NATIVE_COMPILEDP (object) ? Qt : Qnil; + return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBRP_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/doc.c b/src/doc.c index 2c96fc15a7c..192e2011093 100644 --- a/src/doc.c +++ b/src/doc.c @@ -510,7 +510,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - else if (SUBRP_NATIVE_COMPILEDP (fun)) + else if (SUBR_NATIVE_COMPILEDP (fun)) { XSUBR (fun)->native_doc = Qnil; } diff --git a/src/lisp.h b/src/lisp.h index a4cabc34855..69db8cdef10 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4759,7 +4759,7 @@ extern char *emacs_root_dir (void); #ifdef HAVE_NATIVE_COMP INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return SUBRP (a) && XSUBR (a)->native_comp_u[0]; } @@ -4772,7 +4772,7 @@ allocate_native_comp_unit (void) } #else INLINE bool -SUBRP_NATIVE_COMPILEDP (Lisp_Object a) +SUBR_NATIVE_COMPILEDP (Lisp_Object a) { return false; } diff --git a/src/pdumper.c b/src/pdumper.c index 422bec47a66..81d48496be2 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -956,7 +956,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object) static void * dump_object_emacs_ptr (Lisp_Object lv) { - if (SUBRP (lv) && !SUBRP_NATIVE_COMPILEDP (lv)) + if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -3962,7 +3962,7 @@ dump_do_fixup (struct dump_context *ctx, /* Dump wants a pointer to a Lisp object. If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in the dump; otherwise, a Lisp_Object. */ - if (SUBRP (arg) && !SUBRP_NATIVE_COMPILEDP(arg)) + if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) -- cgit v1.2.3 From 1c08dc82121d50e80bd2dcb0d1f39654cc6762dd Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 27 Dec 2019 17:02:23 +0100 Subject: some rework to please --enable-check-lisp-object-type --- src/comp.c | 2 +- src/data.c | 2 +- src/lisp.h | 2 +- src/pdumper.c | 6 +++--- 4 files changed, 6 insertions(+), 6 deletions(-) (limited to 'src/data.c') diff --git a/src/comp.c b/src/comp.c index 85b0983a6df..eacda5de550 100644 --- a/src/comp.c +++ b/src/comp.c @@ -866,7 +866,7 @@ emit_const_lisp_obj (Lisp_Object obj) emit_comment (format_string ("const lisp obj: %s", SSDATA (Fprin1_to_string (obj, Qnil)))); - if (Qnil == NULL && EQ (obj, Qnil)) + if (NIL_IS_ZERO && EQ (obj, Qnil)) return emit_cast (comp.lisp_obj_type, gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, comp.void_ptr_type, diff --git a/src/data.c b/src/data.c index 191fb313687..8901ffbb2c3 100644 --- a/src/data.c +++ b/src/data.c @@ -919,7 +919,7 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { - if (SUBR_NATIVE_COMPILEDP (fun) && XSUBR (fun)->native_intspec) + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec)) return XSUBR (fun)->native_intspec; const char *spec = XSUBR (fun)->intspec; diff --git a/src/lisp.h b/src/lisp.h index 69db8cdef10..2d083dc4582 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4761,7 +4761,7 @@ extern char *emacs_root_dir (void); INLINE bool SUBR_NATIVE_COMPILEDP (Lisp_Object a) { - return SUBRP (a) && XSUBR (a)->native_comp_u[0]; + return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); } INLINE struct Lisp_Native_Comp_Unit * diff --git a/src/pdumper.c b/src/pdumper.c index 81d48496be2..a35cc7ffcd6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2948,13 +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); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) out.function.a0 = NULL; else dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); - if (NATIVE_COMP_FLAG && subr->native_comp_u[0]) + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) { dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); dump_remember_cold_op (ctx, @@ -2973,7 +2973,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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[0]) + if (ctx->flags.dump_object_contents && !NILP (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], -- cgit v1.2.3 From ffa59bb1611609879151b6dfa94772f9e2144849 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 2 Feb 2020 22:24:03 +0100 Subject: Always define subr-native-elisp-p also without native compiler --- src/data.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 8901ffbb2c3..b7337b19bc6 100644 --- a/src/data.c +++ b/src/data.c @@ -866,7 +866,6 @@ SUBR must be a built-in function. */) return build_string (name); } -#ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, 0, doc: /* Return t if the object is native compiled lisp function, nil otherwise. */) @@ -875,6 +874,7 @@ nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } +#ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) -- cgit v1.2.3 From 159f61baa9e374cfd17acf1a45c0d553b57b7ac9 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 15 Mar 2020 21:44:05 +0000 Subject: Trigger native compilation when loading bytecode Introduce a first mechanism to trigger compilation when lex elc files are loaded. This is off by default and has to be better tested. --- lisp/emacs-lisp/comp.el | 5 +++++ src/comp.c | 38 +++++++++++++++++++++++++++++++++++++- src/comp.h | 10 ++++++++++ src/data.c | 2 ++ src/lisp.h | 1 + src/lread.c | 2 +- 6 files changed, 56 insertions(+), 2 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index c00a68307b0..0728c4f0a81 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -40,6 +40,11 @@ "Emacs Lisp native compiler." :group 'lisp) +(defcustom comp-deferred-compilation nil + "If t compile asyncronously all lexically bound .elc files being loaded." + :type 'boolean + :group 'comp) + (defcustom comp-speed 2 "Compiler optimization level. From 0 to 3. - 0 no optimizations are performed, compile time is favored. diff --git a/src/comp.c b/src/comp.c index b9ecef07f32..74b74a83b77 100644 --- a/src/comp.c +++ b/src/comp.c @@ -492,7 +492,7 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, /* String containing the function ptr name. */ Lisp_Object f_ptr_name = - CALLN (Ffuncall, intern_c_string (STR (comp-c-func-name)), + CALLN (Ffuncall, intern_c_string ("comp-c-func-name"), subr_sym, make_string ("R", 1)); gcc_jit_type *f_ptr_type = @@ -3359,6 +3359,40 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } + +/***********************************/ +/* Deferred compilation mechanism. */ +/***********************************/ + +void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{ + Lisp_Object src = Qnil; + Lisp_Object load_list = Vcurrent_load_list; + + FOR_EACH_TAIL (load_list) + { + src = XCAR (load_list); + if (!CONSP (src)) + break; + } + + if (!comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) + || !STRINGP (src) + || !suffix_p (src, ".elc")) + return; + + src = concat2 (CALL1I (file-name-sans-extension, src), + build_pure_c_string (".el")); + if (!NILP (Ffile_exists_p (src))) + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil); +} + /**************************************/ /* Functions used to load eln files. */ @@ -3552,6 +3586,8 @@ void syms_of_comp (void) { /* Compiler control customizes. */ + DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, + doc: /* If t compile asyncronously every .elc file loaded. */); DEFSYM (Qcomp_speed, "comp-speed"); DEFSYM (Qcomp_debug, "comp-debug"); diff --git a/src/comp.h b/src/comp.h index 070ec4d5ca9..f3bcd4c09bc 100644 --- a/src/comp.h +++ b/src/comp.h @@ -68,5 +68,15 @@ extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump); extern void syms_of_comp (void); +extern void maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition); +#else + +static inline void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{} + #endif + #endif diff --git a/src/data.c b/src/data.c index 8a0546ce09b..173b92c5bf4 100644 --- a/src/data.c +++ b/src/data.c @@ -814,6 +814,8 @@ The return value is undefined. */) Ffset (symbol, definition); } + maybe_defer_native_compilation (symbol, definition); + if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); /* We used to return `definition', but now that `defun' and `defmacro' expand diff --git a/src/lisp.h b/src/lisp.h index cd543f5047d..96959764879 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4102,6 +4102,7 @@ LOADHIST_ATTACH (Lisp_Object x) if (initialized) Vcurrent_load_list = Fcons (x, Vcurrent_load_list); } +extern bool suffix_p (Lisp_Object, const char *); extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, diff --git a/src/lread.c b/src/lread.c index 32c83bfae8b..2d90bccdc07 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1077,7 +1077,7 @@ effective_load_path (void) } /* Return true if STRING ends with SUFFIX. */ -static bool +bool suffix_p (Lisp_Object string, const char *suffix) { ptrdiff_t suffix_len = strlen (suffix); -- cgit v1.2.3 From 62f956970f5fe4b180ca57b290594530386d8b02 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 6 Apr 2020 18:03:34 +0100 Subject: * src/comp.c (native-comp-unit-file): Better parameter name. --- src/data.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index b53b8409b59..2040e4eaecd 100644 --- a/src/data.c +++ b/src/data.c @@ -883,11 +883,12 @@ DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, Snative_comp_unit_file, 1, 1, 0, doc: /* Return the file of the native compilation unit. */) - (Lisp_Object object) + (Lisp_Object comp_unit) { - CHECK_TYPE (NATIVE_COMP_UNITP (object), Qnative_comp_unit, object); - return XNATIVE_COMP_UNIT (object)->file; + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + XNATIVE_COMP_UNIT (comp_unit)->file = new_file; } + #endif DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, -- cgit v1.2.3 From d85b803b78bc2a9b0424f0caac62a4e9de49b3e4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 10 Apr 2020 22:24:07 +0100 Subject: * src/comp.c (native-comp-unit-set-file): New function. --- src/data.c | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 2040e4eaecd..1809d58c2c7 100644 --- a/src/data.c +++ b/src/data.c @@ -884,9 +884,19 @@ DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, Snative_comp_unit_file, 1, 1, 0, doc: /* Return the file of the native compilation unit. */) (Lisp_Object comp_unit) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + return XNATIVE_COMP_UNIT (comp_unit)->file; +} + +DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file, + Snative_comp_unit_set_file, 2, 2, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit, Lisp_Object new_file) { CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); XNATIVE_COMP_UNIT (comp_unit)->file = new_file; + return comp_unit; } #endif @@ -4007,6 +4017,7 @@ syms_of_data (void) defsubr (&Ssubr_native_elisp_p); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); + defsubr (&Snative_comp_unit_set_file); #endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); -- cgit v1.2.3 From 64af8f941fb7ec50460f47997109e757cb7af94c Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 25 Apr 2020 22:08:11 +0100 Subject: * src/data.c (syms_of_data): Fix #ifdef HAVE_NATIVE_COMP position. --- src/data.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 1809d58c2c7..56ea7aabb04 100644 --- a/src/data.c +++ b/src/data.c @@ -4013,8 +4013,8 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_elisp_p); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); -- cgit v1.2.3 From c6f42387e32a4e99cd9ddd203ab51f3c5694054e Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 31 Aug 2020 22:06:49 +0200 Subject: Fix describe function arglist for native compiled lisp/d (bug#42572) * lisp/help.el (help-function-arglist): Handle the case of native compiled lisp/d. * src/data.c (syms_of_data): Register new subrs. (Fsubr_native_dyn_p, Fsubr_native_lambda_list): New primitives. * test/src/comp-tests.el (comp-tests-dynamic-help-arglist): New test. --- lisp/help.el | 1 + src/data.c | 29 +++++++++++++++++++++++++++-- test/src/comp-tests.el | 7 +++++++ 3 files changed, 35 insertions(+), 2 deletions(-) (limited to 'src/data.c') diff --git a/lisp/help.el b/lisp/help.el index 1b0149616f2..01817ab95db 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,6 +1337,7 @@ the same names as used in the original source code, when possible." ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((eq (car-safe def) 'closure) (nth 2 def)) + ((subr-native-dyn-p def) (subr-native-lambda-list def)) ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) (or (when preserve-names diff --git a/src/data.c b/src/data.c index 33711368f13..b7955932b85 100644 --- a/src/data.c +++ b/src/data.c @@ -875,14 +875,37 @@ SUBR must be a built-in function. */) } DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, - 0, doc: /* Return t if the object is native compiled lisp function, -nil otherwise. */) + 0, doc: /* Return t if the object is native compiled lisp +function, nil otherwise. */) (Lisp_Object object) { return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } #ifdef HAVE_NATIVE_COMP + +DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, + Ssubr_native_dyn_p, 1, 1, 0, + doc: /* Return t if the subr is native compiled lisp/d +function, nil otherwise. */) + (Lisp_Object subr) +{ + return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; +} + +DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, + Ssubr_native_lambda_list, 1, 1, 0, + doc: /* Return the lambda list of native compiled lisp/d +function. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + + return SUBR_NATIVE_COMPILED_DYNP (subr) + ? XSUBR (subr)->lambda_list[0] + : Qnil; +} + DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) @@ -4028,6 +4051,8 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_dyn_p); + defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 2a078be8cb0..b147bd6789c 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -582,6 +582,13 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (should (equal '(2 . many) (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) +(ert-deftest comp-tests-dynamic-help-arglist () + "Test `help-function-arglist' works on lisp/d (bug#42572)." + (should (equal (help-function-arglist + (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + t) + '(a b &optional c &rest d)))) + (ert-deftest comp-tests-cl-macro-exp () "Verify CL macro expansion (bug#42088)." (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) -- cgit v1.2.3 From 78e8f991542160239049a50386ced50e456dc5c4 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Tue, 1 Sep 2020 10:28:29 +0200 Subject: Rework native compiled lisp/d lambda list accessor * lisp/help.el (help-function-arglist): Logic update for new 'Fsubr_native_lambda_list'. * src/data.c (Fsubr_native_dyn_p): Remove. (Fsubr_native_lambda_list): Return t when the input is not a compiled lisp/d subr. (syms_of_data): Update for 'Fsubr_native_dyn_p' removal. --- lisp/help.el | 3 ++- src/data.c | 16 +++------------- 2 files changed, 5 insertions(+), 14 deletions(-) (limited to 'src/data.c') diff --git a/lisp/help.el b/lisp/help.el index 01817ab95db..897ab4a425d 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -1337,7 +1337,8 @@ the same names as used in the original source code, when possible." ((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0)) ((eq (car-safe def) 'lambda) (nth 1 def)) ((eq (car-safe def) 'closure) (nth 2 def)) - ((subr-native-dyn-p def) (subr-native-lambda-list def)) + ((and (subrp def) (listp (subr-native-lambda-list def))) + (subr-native-lambda-list def)) ((or (and (byte-code-function-p def) (integerp (aref def 0))) (subrp def) (module-function-p def)) (or (when preserve-names diff --git a/src/data.c b/src/data.c index b7955932b85..0acae67b2a8 100644 --- a/src/data.c +++ b/src/data.c @@ -884,26 +884,17 @@ function, nil otherwise. */) #ifdef HAVE_NATIVE_COMP -DEFUN ("subr-native-dyn-p", Fsubr_native_dyn_p, - Ssubr_native_dyn_p, 1, 1, 0, - doc: /* Return t if the subr is native compiled lisp/d -function, nil otherwise. */) - (Lisp_Object subr) -{ - return SUBR_NATIVE_COMPILED_DYNP (subr) ? Qt : Qnil; -} - DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, Ssubr_native_lambda_list, 1, 1, 0, - doc: /* Return the lambda list of native compiled lisp/d -function. */) + doc: /* Return the lambda list for a native compiled lisp/d +function or t otherwise. */) (Lisp_Object subr) { CHECK_SUBR (subr); return SUBR_NATIVE_COMPILED_DYNP (subr) ? XSUBR (subr)->lambda_list[0] - : Qnil; + : Qt; } DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -4051,7 +4042,6 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); #ifdef HAVE_NATIVE_COMP - defsubr (&Ssubr_native_dyn_p); defsubr (&Ssubr_native_lambda_list); defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); -- cgit v1.2.3 From d344e79be9fb82a38a89c892e24d5ca71fbff810 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 6 Sep 2020 18:21:00 +0200 Subject: * src/data.c (subr-native-lambda-list): Defined it unconditionally (bug#43255) --- src/data.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 0acae67b2a8..85c73b406c4 100644 --- a/src/data.c +++ b/src/data.c @@ -882,8 +882,6 @@ function, nil otherwise. */) return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; } -#ifdef HAVE_NATIVE_COMP - DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list, Ssubr_native_lambda_list, 1, 1, 0, doc: /* Return the lambda list for a native compiled lisp/d @@ -897,6 +895,8 @@ function or t otherwise. */) : Qt; } +#ifdef HAVE_NATIVE_COMP + DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, Ssubr_native_comp_unit, 1, 1, 0, doc: /* Return the native compilation unit. */) -- cgit v1.2.3 From 2ab0966b2fdf3a64d061727f005d32c5aad27594 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 19 Sep 2020 16:13:56 +0200 Subject: Make CHECK_SUBR public * src/data.c (CHECK_SUBR): Move from here to... * src/lisp.h (CHECK_SUBR): ...to here. --- src/data.c | 6 ------ src/lisp.h | 6 ++++++ 2 files changed, 6 insertions(+), 6 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 3f035269de1..8c39c319110 100644 --- a/src/data.c +++ b/src/data.c @@ -87,12 +87,6 @@ XOBJFWD (lispfwd a) return a.fwdptr; } -static void -CHECK_SUBR (Lisp_Object x) -{ - CHECK_TYPE (SUBRP (x), Qsubrp, x); -} - static void set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found) { diff --git a/src/lisp.h b/src/lisp.h index cbc6a666471..452f48f3468 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2982,6 +2982,12 @@ CHECK_INTEGER (Lisp_Object x) { CHECK_TYPE (INTEGERP (x), Qnumberp, x); } + +INLINE void +CHECK_SUBR (Lisp_Object x) +{ + CHECK_TYPE (SUBRP (x), Qsubrp, x); +} /* If we're not dumping using the legacy dumper and we might be using -- cgit v1.2.3 From 87c6aa13b30281398688ec8693a0205bb84bc648 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 2 Oct 2020 22:36:05 +0200 Subject: Make primitive redefinition effective through trampoline synthesis * lisp/loadup.el (dump-mode): Set `comp-enable-subr-trampolines' when finished bootstrap. * src/data.c (Ffset): Call `comp-enable-subr-trampolines' when redefining a subr. * src/comp.c (syms_of_comp): Define `comp-subr-trampoline-install' symbol. (syms_of_comp): Define `comp-enable-subr-trampolines' variable. --- lisp/loadup.el | 5 +++++ src/comp.c | 6 ++++++ src/data.c | 7 +++++++ 3 files changed, 18 insertions(+) (limited to 'src/data.c') diff --git a/lisp/loadup.el b/lisp/loadup.el index f218ec1ff98..91126703d18 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -510,6 +510,11 @@ lost after dumping"))) ((equal dump-mode "bootstrap") "emacs") ((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp") (t (error "unrecognized dump mode %s" dump-mode))))) + (when (and (boundp 'comp-ctxt) + (equal dump-mode "pdump")) + ;; Don't enable this before bootstrap is completed the as the + ;; compiler infrastructure may not be usable. + (setq comp-enable-subr-trampolines t)) (message "Dumping under the name %s" output) (condition-case () (delete-file output) diff --git a/src/comp.c b/src/comp.c index 5663c9e5624..076236ef80c 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5141,6 +5141,7 @@ native compiled one. */); DEFSYM (Qlate, "late"); DEFSYM (Qlambda_fixup, "lambda-fixup"); DEFSYM (Qgccjit, "gccjit"); + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install") /* To be signaled by the compiler. */ DEFSYM (Qnative_compiler_error, "native-compiler-error"); @@ -5246,6 +5247,11 @@ The last directory of this list is assumed to be the system one. */); dump reload. */ Vcomp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, + doc: /* When non-nil enable trampoline synthesis + triggerd by `fset' making primitives + redefinable effectivelly. */); + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, doc: /* Hash table subr-name -> bool. */); Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); diff --git a/src/data.c b/src/data.c index 8c39c319110..c6629dd5f29 100644 --- a/src/data.c +++ b/src/data.c @@ -775,6 +775,13 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0, eassert (valid_lisp_object_p (definition)); +#ifdef HAVE_NATIVE_COMP + if (comp_enable_subr_trampolines + && SUBRP (function) + && !SUBR_NATIVE_COMPILEDP (function)) + CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol); +#endif + set_symbol_function (symbol, definition); return definition; -- cgit v1.2.3 From 39bdb3f6f54cdba80f1efbecab4bbb08428e7cc8 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Fri, 4 Dec 2020 22:31:36 +0100 Subject: Vanilla build warning clean-up * lisp/emacs-lisp/disass.el (native-comp-unit-file) (subr-native-comp-unit): Declare function. * lisp/progmodes/elisp-mode.el (native-compile): Likewise. * lisp/emacs-lisp/package.el (comp-el-to-eln-filename): Likewise. * lisp/startup.el (normal-top-level): Silence warning. * src/data.c (syms_of_data): 'Ssubr_native_lambda_list' is always defined. * src/pdumper.c (dump_cold_native_subr): Move under ifdefs. (dump_drain_cold_data): Add ifdefs. --- lisp/emacs-lisp/disass.el | 3 ++- lisp/emacs-lisp/package.el | 1 + lisp/progmodes/elisp-mode.el | 1 + lisp/startup.el | 1 + src/data.c | 2 +- src/pdumper.c | 4 ++++ 6 files changed, 10 insertions(+), 2 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 7e7db7b441d..7fb370f5df5 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -75,7 +75,8 @@ redefine OBJECT if it is a symbol." (disassemble-internal object indent nil))) nil) - +(declare-function native-comp-unit-file "data.c") +(declare-function subr-native-comp-unit "data.c") (cl-defun disassemble-internal (obj indent interactive-p) (let ((macro 'nil) (name (when (symbolp obj) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 0ee2e58d528..e980f8841e0 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -2221,6 +2221,7 @@ If some packages are not installed propose to install them." (equal (cadr (assq (package-desc-name pkg) package-alist)) pkg)) +(declare-function comp-el-to-eln-filename "comp.c") (defun package--delete-directory (dir) "Delete DIR recursively. Clean-up the corresponding .eln files if Emacs is native diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index dac3aaf2a53..13bba7f77a8 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -203,6 +203,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.") (byte-recompile-file buffer-file-name nil 0) (load buffer-file-name)) +(declare-function native-compile "comp") (defun emacs-lisp-native-compile-and-load () "Native-compile synchronously the current file (if it has changed). Load the compiled code when finished. diff --git a/lisp/startup.el b/lisp/startup.el index 2beeaa195d0..f9de7fa94f6 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -535,6 +535,7 @@ It is the default value of the variable `top-level'." (startup--xdg-or-homedot startup--xdg-config-home-emacs nil)) (when (featurep 'nativecomp) + (defvar comp-eln-load-path) (let ((path-env (getenv "EMACSNATIVELOADPATH"))) (when path-env (dolist (path (split-string path-env ":")) diff --git a/src/data.c b/src/data.c index 1435cb03779..fea39867c99 100644 --- a/src/data.c +++ b/src/data.c @@ -4055,8 +4055,8 @@ syms_of_data (void) defsubr (&Ssubr_arity); defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); -#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_lambda_list); +#ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); defsubr (&Snative_comp_unit_set_file); diff --git a/src/pdumper.c b/src/pdumper.c index 1a7aee6343a..b3abbd66f0c 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -3405,6 +3405,7 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) } } +#ifdef HAVE_NATIVE_COMP static void dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) { @@ -3425,6 +3426,7 @@ dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) const char *c_name = XSUBR (subr)->native_c_name[0]; dump_write (ctx, c_name, 1 + strlen (c_name)); } +#endif static void dump_drain_cold_data (struct dump_context *ctx) @@ -3469,9 +3471,11 @@ dump_drain_cold_data (struct dump_context *ctx) case COLD_OP_BIGNUM: dump_cold_bignum (ctx, data); break; +#ifdef HAVE_NATIVE_COMP case COLD_OP_NATIVE_SUBR: dump_cold_native_subr (ctx, data); break; +#endif default: emacs_abort (); } -- cgit v1.2.3 From 2b3c7c751739f48545c3888549ae312ea334951b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 13:41:38 +0100 Subject: Store function type and expose it with `subr-type' * src/lisp.h (struct Lisp_Subr): Add 'type' field. (SUBR_TYPE): New inline accessor. * src/pdumper.c (dump_subr): Update for 'type' field. * src/data.c (Fsubr_type): New primitive. (syms_of_data): Update. * src/comp.c (ABI_VERSION): Bump new ABI version. (make_subr): Set type. (Fcomp__register_lambda, Fcomp__register_subr) (Fcomp__late_register_subr): Receive and pass subr type to 'make_subr'. * src/alloc.c (mark_object): Mark subr type. * lisp/emacs-lisp/comp.el (comp-func): Change slot type into mvar. (comp-emit-for-top-level, comp-emit-lambda-for-top-level): Pass type mvar to subr register functions. (comp-compute-function-type): Fix-up subr type mvars. * test/src/comp-tests.el (comp-tests-check-ret-type-spec): Use `subr-type'. --- lisp/emacs-lisp/comp.el | 21 ++++++++++++++------- src/alloc.c | 1 + src/comp.c | 28 ++++++++++++++++------------ src/data.c | 14 ++++++++++++++ src/lisp.h | 7 +++++++ src/pdumper.c | 3 ++- test/src/comp-tests.el | 16 ++++++---------- 7 files changed, 60 insertions(+), 30 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3b84569c458..35a9e05cfb7 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -497,8 +497,8 @@ CFG is mutated by a pass.") :documentation "Optimization level (see `comp-speed').") (pure nil :type boolean :documentation "t if pure nil otherwise.") - (type nil :type list - :documentation "Derived return type.")) + (type nil :type (or null comp-mvar) + :documentation "Mvar holding the derived return type.")) (cl-defstruct (comp-func-l (:include comp-func)) "Lexically-scoped function." @@ -1696,6 +1696,8 @@ the annotation emission." (make-comp-mvar :constant c-name) (car args) (cdr args) + (setf (comp-func-type f) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -1737,6 +1739,8 @@ These are stored in the reloc data array." (make-comp-mvar :constant (comp-func-c-name func)) (car args) (cdr args) + (setf (comp-func-type func) + (make-comp-mvar :constant nil)) (make-comp-mvar :constant (list @@ -3004,7 +3008,8 @@ These are substituted with a normal 'set' op." (defun comp-compute-function-type (_ func) "Compute type specifier for `comp-func' FUNC. Set it into the `type' slot." - (when (comp-func-l-p func) + (when (and (comp-func-l-p func) + (comp-mvar-p (comp-func-type func))) (let* ((comp-func (make-comp-func)) (res-mvar (apply #'comp-cstr-union (make-comp-cstr) @@ -3019,10 +3024,12 @@ Set it into the `type' slot." do (pcase insn (`(return ,mvar) (push mvar res)))) - finally return res)))) - (setf (comp-func-type func) - `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) - ,(comp-cstr-to-type-spec res-mvar)))))) + finally return res))) + (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func)) + ,(comp-cstr-to-type-spec res-mvar)))) + (comp-add-const-to-relocs type) + ;; Fix it up. + (setf (comp-mvar-value (comp-func-type func)) type)))) (defun comp-finalize-container (cont) "Finalize data container CONT." diff --git a/src/alloc.c b/src/alloc.c index 754b8f2aef8..bdf721e5270 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -6719,6 +6719,7 @@ mark_object (Lisp_Object arg) mark_object (subr->native_intspec); mark_object (subr->native_comp_u[0]); mark_object (subr->lambda_list[0]); + mark_object (subr->type[0]); } break; diff --git a/src/comp.c b/src/comp.c index ee8ae98e2ac..04bf9973d26 100644 --- a/src/comp.c +++ b/src/comp.c @@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "0" +#define ABI_VERSION "1" /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" @@ -4886,8 +4886,8 @@ native_function_doc (Lisp_Object function) static Lisp_Object make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, - Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, - Lisp_Object comp_u) + Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, + Lisp_Object intspec, Lisp_Object comp_u) { struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); dynlib_handle_ptr handle = cu->handle; @@ -4918,6 +4918,7 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, x->s.doc = XFIXNUM (doc_idx); x->s.native_comp_u[0] = comp_u; x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); + x->s.type[0] = type; Lisp_Object tem; XSETSUBR (tem, &x->s); @@ -4925,11 +4926,12 @@ make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, } DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, - 6, 6, 0, + 7, 7, 0, doc: /* Register anonymous lambda. This gets called by top_level_run during the load phase. */) (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); @@ -4938,7 +4940,7 @@ This gets called by top_level_run during the load phase. */) return Qnil; Lisp_Object tem = - make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u); + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u); /* We must protect it against GC because the function is not reachable through symbols. */ @@ -4954,17 +4956,18 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, - 6, 6, 0, + 7, 7, 0, doc: /* Register exported subr. This gets called by top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { Lisp_Object doc_idx = FIRST (rest); Lisp_Object intspec = SECOND (rest); Lisp_Object tem = - make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, - comp_u); + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, + intspec, comp_u); if (AUTOLOADP (XSYMBOL (name)->u.s.function)) /* Remember that the function was already an autoload. */ @@ -4984,11 +4987,12 @@ This gets called by top_level_run during the load phase. */) } DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, - Scomp__late_register_subr, 6, 6, 0, + Scomp__late_register_subr, 7, 7, 0, doc: /* Register exported subr. This gets called by late_top_level_run during the load phase. */) (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, - Lisp_Object maxarg, Lisp_Object rest, Lisp_Object comp_u) + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) { if (!NILP (Fequal (Fsymbol_function (name), Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) diff --git a/src/data.c b/src/data.c index 544b20d50cc..c5476495bd6 100644 --- a/src/data.c +++ b/src/data.c @@ -896,6 +896,19 @@ function or t otherwise. */) : Qt; } +DEFUN ("subr-type", Fsubr_type, + Ssubr_type, 1, 1, 0, + doc: /* Return the type of SUBR. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); +#ifdef HAVE_NATIVE_COMP + return SUBR_TYPE (subr); +#else + return Qnil; +#endif +} + #ifdef HAVE_NATIVE_COMP DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, @@ -4057,6 +4070,7 @@ syms_of_data (void) defsubr (&Ssubr_name); defsubr (&Ssubr_native_elisp_p); defsubr (&Ssubr_native_lambda_list); + defsubr (&Ssubr_type); #ifdef HAVE_NATIVE_COMP defsubr (&Ssubr_native_comp_unit); defsubr (&Snative_comp_unit_file); diff --git a/src/lisp.h b/src/lisp.h index efbb7a45242..6f00ae84517 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2071,6 +2071,7 @@ struct Lisp_Subr Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; char *native_c_name[NATIVE_COMP_FLAG]; Lisp_Object lambda_list[NATIVE_COMP_FLAG]; + Lisp_Object type[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -4759,6 +4760,12 @@ SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); } +INLINE Lisp_Object +SUBR_TYPE (Lisp_Object a) +{ + return XSUBR (a)->type[0]; +} + INLINE struct Lisp_Native_Comp_Unit * allocate_native_comp_unit (void) { diff --git a/src/pdumper.c b/src/pdumper.c index ae5bbef9b77..a9c43a463db 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2860,7 +2860,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_35CE99B716) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_AA236F7759) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; @@ -2893,6 +2893,7 @@ dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) 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_field_lv (ctx, &out, subr, &subr->type[0], WEIGHT_NORMAL); } dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); if (NATIVE_COMP_FLAG diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index d4eb39a736f..c79190e2967 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -792,18 +792,14 @@ Return a list of results." (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) -(defun comp-tests-check-ret-type-spec (func-form type-specifier) +(defun comp-tests-check-ret-type-spec (func-form ret-type) (let ((lexical-binding t) - (speed 2) - (comp-post-pass-hooks - `((comp-final - ,(lambda (_) - (let ((f (gethash (comp-c-func-name (cadr func-form) "F" t) - (comp-ctxt-funcs-h comp-ctxt)))) - (should (equal (cl-third (comp-func-type f)) - type-specifier)))))))) + (comp-speed 2) + (f-name (cl-second func-form))) (eval func-form t) - (native-compile (cadr func-form)))) + (native-compile f-name) + (should (equal (cl-third (subr-type (symbol-function f-name))) + ret-type)))) (cl-eval-when (compile eval load) (defconst comp-tests-type-spec-tests -- 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/data.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 8cdb61679e169a68829a3122d4eda7139199f7ee Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:57:59 +0100 Subject: Revert the bit about command_modes in previous patch set * src/data.c (Fcommand_modes): Remove the subr bit -- it's not necessary since it can just use a predicate. * src/lisp.h (GCALIGNED_STRUCT): Remove command_modes. * src/lread.c (defsubr): Remove command_modes. --- src/data.c | 7 +------ src/lisp.h | 1 - src/lread.c | 1 - 3 files changed, 1 insertion(+), 8 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 7bddc039f6f..ace859d2d0c 100644 --- a/src/data.c +++ b/src/data.c @@ -961,12 +961,7 @@ The value, if non-nil, is a list of mode name symbols. */) 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)) + if (COMPILEDP (fun)) { Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE); if (VECTORP (form)) diff --git a/src/lisp.h b/src/lisp.h index 697dd89363c..b95f389b890 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2060,7 +2060,6 @@ struct Lisp_Subr const char *symbol_name; const char *intspec; EMACS_INT doc; - Lisp_Object command_modes; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { diff --git a/src/lread.c b/src/lread.c index 8b8ba93c607..dea1b232fff 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4467,7 +4467,6 @@ 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 12578d6aca2cc7182afdd070aa31c7aff6a3add8 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sat, 20 Feb 2021 14:29:41 +0100 Subject: Change how (declare (modes store the data * lisp/emacs-lisp/byte-run.el (byte-run--set-modes): Change from being a predicate to storing the modes. This allows using the modes for positive command discovery, too. * src/data.c (Fcommand_modes): Look at the `command-modes' symbol property, too. --- lisp/emacs-lisp/byte-run.el | 4 +--- src/data.c | 10 +++++++++- 2 files changed, 10 insertions(+), 4 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 76e7f01ace6..afe94bb0352 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -154,9 +154,7 @@ The return value of this function is not used." (defalias 'byte-run--set-modes #'(lambda (f _args &rest val) (list 'function-put (list 'quote f) - ''completion-predicate - `(lambda (_ b) - (command-completion-with-modes-p ',val b))))) + ''command-modes (list 'quote val)))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist diff --git a/src/data.c b/src/data.c index ace859d2d0c..9af9131b123 100644 --- a/src/data.c +++ b/src/data.c @@ -957,9 +957,17 @@ The value, if non-nil, is a list of mode name symbols. */) if (NILP (fun)) return Qnil; + /* Use a `command-modes' property if present, analogous to the + function-documentation property. */ fun = command; while (SYMBOLP (fun)) - fun = Fsymbol_function (fun); + { + Lisp_Object modes = Fget (fun, Qcommand_modes); + if (!NILP (modes)) + return modes; + else + fun = Fsymbol_function (fun); + } if (COMPILEDP (fun)) { -- cgit v1.2.3 From d0c47652e527397cae96444c881bf60455c763c1 Mon Sep 17 00:00:00 2001 From: Mattias Engdegård Date: Sun, 21 Feb 2021 15:24:41 +0100 Subject: Faster, more compact, and readable closure creation Simplify closure creation by calling a single function at run time instead of putting it together from small pieces. This is faster (by about a factor 2), takes less space on disk and in memory, and makes internal functions somewhat readable in disassembly listings again. This is done by creating a prototype function at compile-time whose closure variables are placeholder values V0, V1... which can be seen in the disassembly. The prototype is then cloned at run time using the new make-closure function that replaces the placeholders with the actual closure variables. * lisp/emacs-lisp/bytecomp.el (byte-compile-make-closure): Generate call to make-closure from a prototype function. * src/alloc.c (Fmake_closure): New function. (syms_of_alloc): Defsubr it. * src/data.c (syms_of_data): Defsym byte-code-function-p. --- lisp/emacs-lisp/bytecomp.el | 24 +++++++++++++++--------- src/alloc.c | 33 +++++++++++++++++++++++++++++++++ src/data.c | 2 ++ 3 files changed, 50 insertions(+), 9 deletions(-) (limited to 'src/data.c') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 1b0906b50bb..69a63b169cc 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3817,15 +3817,21 @@ discarding." (cl-assert (or (> (length env) 0) docstring-exp)) ;Otherwise, we don't need a closure. (cl-assert (byte-code-function-p fun)) - (byte-compile-form `(make-byte-code - ',(aref fun 0) ',(aref fun 1) - (vconcat (vector . ,env) ',(aref fun 2)) - ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) fun)))) - (if docstring-exp - `(,(car rest) - ,docstring-exp - ,@(cddr rest)) - rest))))))) + (byte-compile-form + ;; Use symbols V0, V1 ... as placeholders for closure variables: + ;; they should be short (to save space in the .elc file), yet + ;; distinct when disassembled. + (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i))) + (number-sequence 0 (1- (length env))))) + (proto-fun + (apply #'make-byte-code + (aref fun 0) (aref fun 1) + ;; Prepend dummy cells to the constant vector, + ;; to get the indices right when disassembling. + (vconcat dummy-vars (aref fun 2)) + (mapcar (lambda (i) (aref fun i)) + (number-sequence 3 (1- (length fun))))))) + `(make-closure ,proto-fun ,@env)))))) (defun byte-compile-get-closed-var (form) "Byte-compile the special `internal-get-closed-var' form." diff --git a/src/alloc.c b/src/alloc.c index b86ed4ed262..e72fc4c4332 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3498,6 +3498,38 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT return val; } +DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0, + doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS. +Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS +replacing the elements in the beginning of the constant-vector. +usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + Lisp_Object protofun = args[0]; + CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun); + + /* Create a copy of the constant vector, filling it with the closure + variables in the beginning. (The overwritten part should just + contain placeholder values.) */ + Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS); + ptrdiff_t constsize = ASIZE (proto_constvec); + ptrdiff_t nvars = nargs - 1; + if (nvars > constsize) + error ("Closure vars do not fit in constvec"); + Lisp_Object constvec = make_uninit_vector (constsize); + memcpy (XVECTOR (constvec)->contents, args + 1, nvars * word_size); + memcpy (XVECTOR (constvec)->contents + nvars, + XVECTOR (proto_constvec)->contents + nvars, + (constsize - nvars) * word_size); + + /* Return a copy of the prototype function with the new constant vector. */ + ptrdiff_t protosize = PVSIZE (protofun); + struct Lisp_Vector *v = allocate_vectorlike (protosize, false); + v->header = XVECTOR (protofun)->header; + memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size); + v->contents[COMPILED_CONSTANTS] = constvec; + return make_lisp_ptr (v, Lisp_Vectorlike); +} /*********************************************************************** @@ -7573,6 +7605,7 @@ N should be nonnegative. */); defsubr (&Srecord); defsubr (&Sbool_vector); defsubr (&Smake_byte_code); + defsubr (&Smake_closure); defsubr (&Smake_list); defsubr (&Smake_vector); defsubr (&Smake_record); diff --git a/src/data.c b/src/data.c index 9af9131b123..0fa491b17a1 100644 --- a/src/data.c +++ b/src/data.c @@ -3989,6 +3989,8 @@ syms_of_data (void) DEFSYM (Qinteractive_form, "interactive-form"); DEFSYM (Qdefalias_fset_function, "defalias-fset-function"); + DEFSYM (Qbyte_code_function_p, "byte-code-function-p"); + defsubr (&Sindirect_variable); defsubr (&Sinteractive_form); defsubr (&Scommand_modes); -- cgit v1.2.3 From a1e454d6df011f2a02d3b4900dd33d1d3717c6ef Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 29 Mar 2021 13:39:43 +0300 Subject: Protect add-variable-watcher from incorrect usage * src/data.c (Fadd_variable_watcher): Avoid crashes if SYMBOL isn't. (Bug#47462) --- src/data.c | 1 + 1 file changed, 1 insertion(+) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 0fa491b17a1..3667b03c0e4 100644 --- a/src/data.c +++ b/src/data.c @@ -1589,6 +1589,7 @@ All writes to aliases of SYMBOL will call WATCH-FUNCTION too. */) (Lisp_Object symbol, Lisp_Object watch_function) { symbol = Findirect_variable (symbol); + CHECK_SYMBOL (symbol); set_symbol_trapped_write (symbol, SYMBOL_TRAPPED_WRITE); map_obarray (Vobarray, harmonize_variable_watchers, symbol); -- cgit v1.2.3 From 77f67d12f68a9fba210337b9ad38f049ec601fcb Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Mon, 31 May 2021 07:21:09 +0200 Subject: Add new convenience function `buffer-local-boundp' * doc/lispref/variables.texi (Creating Buffer-Local): Document it. * lisp/subr.el (buffer-local-boundp): New function. * src/data.c (Flocal_variable_p): Mention it. --- doc/lispref/variables.texi | 6 ++++++ etc/NEWS | 4 ++++ lisp/subr.el | 8 ++++++++ src/data.c | 4 +++- test/lisp/subr-tests.el | 10 ++++++++++ 5 files changed, 31 insertions(+), 1 deletion(-) (limited to 'src/data.c') diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index 36abc316cbb..62c76f09c0d 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -1582,6 +1582,12 @@ buffer-local binding in buffer @var{buffer}, it returns the default value (@pxref{Default Value}) of @var{variable} instead. @end defun +@defun buffer-local-boundp variable buffer +This returns non-@code{nil} if there's either a buffer-local binding +of @var{variable} (a symbol) in buffer @var{buffer}, or @var{variable} +has a global binding. +@end defun + @defun buffer-local-variables &optional buffer This function returns a list describing the buffer-local variables in buffer @var{buffer}. (If @var{buffer} is omitted, the current buffer diff --git a/etc/NEWS b/etc/NEWS index c6e7084118f..6622861aaf1 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2726,6 +2726,10 @@ customize them. * Lisp Changes in Emacs 28.1 ++++ +** New function 'buffer-local-boundp'. +This predicate says whether a symbol is bound in a specific buffer. + --- ** Emacs now attempts to test for high-rate subprocess output more fairly. When several subprocesses produce output simultaneously at high rate, diff --git a/lisp/subr.el b/lisp/subr.el index 88740159b93..e49c2773357 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -195,6 +195,14 @@ buffer-local wherever it is set." (list 'progn (list 'defvar var val docstring) (list 'make-variable-buffer-local (list 'quote var)))) +(defun buffer-local-boundp (symbol buffer) + "Return non-nil if SYMBOL is bound in BUFFER. +Also see `local-variable-p'." + (condition-case nil + (buffer-local-value symbol buffer) + (:success t) + (void-variable nil))) + (defmacro push (newelt place) "Add NEWELT to the list stored in the generalized variable PLACE. This is morally equivalent to (setf PLACE (cons NEWELT PLACE)), diff --git a/src/data.c b/src/data.c index d547f5da5e0..059f31e514b 100644 --- a/src/data.c +++ b/src/data.c @@ -2200,7 +2200,9 @@ From now on the default value will apply in this buffer. Return VARIABLE. */) DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p, 1, 2, 0, doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER. -BUFFER defaults to the current buffer. */) +BUFFER defaults to the current buffer. + +Also see `buffer-local-boundp'.*/) (Lisp_Object variable, Lisp_Object buffer) { struct buffer *buf = decode_buffer (buffer); diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 1e146732163..375251cffc5 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -684,5 +684,15 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should (>= (length (apropos-internal "^help" #'commandp)) 15)) (should-not (apropos-internal "^next-line$" #'keymapp))) + +(ert-deftest test-buffer-local-boundp () + (let ((buf (generate-new-buffer "boundp"))) + (with-current-buffer buf + (setq-local test-boundp t)) + (setq test-global-boundp t) + (should (buffer-local-boundp 'test-boundp buf)) + (should-not (buffer-local-boundp 'test-not-boundp buf)) + (should (buffer-local-boundp 'test-global-boundp buf)))) + (provide 'subr-tests) ;;; subr-tests.el ends here -- cgit v1.2.3 From 7ac411ae2ce91572a2bdb8eaa1ee6ceccf162e35 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Wed, 14 Jul 2021 18:54:11 +0300 Subject: ; * src/data.c (Fcar, Fcdr): Doc fix. --- src/data.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src/data.c') diff --git a/src/data.c b/src/data.c index 2706a2474e6..1c36dff51db 100644 --- a/src/data.c +++ b/src/data.c @@ -591,8 +591,8 @@ DEFUN ("condition-variable-p", Fcondition_variable_p, Scondition_variable_p, /* Extract and set components of lists. */ DEFUN ("car", Fcar, Scar, 1, 1, 0, - doc: /* Return the car of LIST. If arg is nil, return nil. -Error if arg is not nil and not a cons cell. See also `car-safe'. + doc: /* Return the car of LIST. If LIST is nil, return nil. +Error if LIST is not nil and not a cons cell. See also `car-safe'. See Info node `(elisp)Cons Cells' for a discussion of related basic Lisp concepts such as car, cdr, cons cell and list. */) @@ -609,8 +609,8 @@ DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0, } DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0, - doc: /* Return the cdr of LIST. If arg is nil, return nil. -Error if arg is not nil and not a cons cell. See also `cdr-safe'. + doc: /* Return the cdr of LIST. If LIST is nil, return nil. +Error if LIST is not nil and not a cons cell. See also `cdr-safe'. See Info node `(elisp)Cons Cells' for a discussion of related basic Lisp concepts such as cdr, car, cons cell and list. */) -- cgit v1.2.3 From 7edbcb3648e9d08a4ccc291f672f831b4f07eb5c Mon Sep 17 00:00:00 2001 From: Miha Rihtaršič Date: Tue, 20 Jul 2021 14:36:45 +0200 Subject: Quit minibuffers without aborting kmacros * doc/lispref/commands.texi (Quitting): Document `minibuffer-quit' (Recursive Editing): Document throwing of function values to `exit'. * doc/lispref/errors.texi (Standard Errors): Document `minibuffer-quit' * lisp/minibuffer.el (minibuffer-quit-recursive-edit): New function. * lisp/simple.el (minibuffer-error-function): Do not abort keyboard macro execution if is minibuffer-quit is signaled (bug#48603). * src/data.c (syms_of_data): New error symbol `minibuffer-quit' * src/keyboard.c (recursive_edit_1): Implement throwing of function values to `exit`. In that case, the function will be called without arguments before returning from the command loop. (cmd_error): (Fcommand_error_default_function): Do not abort keyboard macro execution if minibuffer-quit is signaled. (command_loop_2): New argument HANDLERS. * src/macros.c (Fexecute_kbd_macro): Use command_loop_2 instead of command_loop_1. * src/minibuf.c (Fabort_minibuffers): Use it. --- doc/lispref/commands.texi | 14 +++++++++++--- doc/lispref/errors.texi | 9 +++++++-- etc/NEWS | 9 +++++++++ lisp/minibuffer.el | 9 +++++++++ lisp/simple.el | 6 ++++-- src/data.c | 2 ++ src/keyboard.c | 45 +++++++++++++++++++++++++++++++++------------ src/lisp.h | 2 +- src/macros.c | 2 +- src/minibuf.c | 2 +- 10 files changed, 78 insertions(+), 22 deletions(-) (limited to 'src/data.c') diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi index f30419c3ee7..b4a8b733a0b 100644 --- a/doc/lispref/commands.texi +++ b/doc/lispref/commands.texi @@ -3381,6 +3381,12 @@ nil)}. This is the same thing that quitting does. (See @code{signal} in @ref{Errors}.) @end deffn + To quit without aborting a keyboard macro definition or execution, +you can signal the @code{minibuffer-quit} condition. This has almost +the same effect as the @code{quit} condition except that the error +handling in the command loop handles it without exiting keyboard macro +definition or execution. + You can specify a character other than @kbd{C-g} to use for quitting. See the function @code{set-input-mode} in @ref{Input Modes}. @@ -3565,12 +3571,14 @@ commands. @code{recursive-edit}. This function contains the command loop; it also contains a call to @code{catch} with tag @code{exit}, which makes it possible to exit the recursive editing level by throwing to @code{exit} -(@pxref{Catch and Throw}). If you throw a value other than @code{t}, -then @code{recursive-edit} returns normally to the function that called -it. The command @kbd{C-M-c} (@code{exit-recursive-edit}) does this. +(@pxref{Catch and Throw}). If you throw a @code{nil} value, then +@code{recursive-edit} returns normally to the function that called it. +The command @kbd{C-M-c} (@code{exit-recursive-edit}) does this. Throwing a @code{t} value causes @code{recursive-edit} to quit, so that control returns to the command loop one level up. This is called @dfn{aborting}, and is done by @kbd{C-]} (@code{abort-recursive-edit}). +You can also throw a function value. In that case, +@code{recursive-edit} will call it without arguments before returning. Most applications should not use recursive editing, except as part of using the minibuffer. Usually it is more convenient for the user if you diff --git a/doc/lispref/errors.texi b/doc/lispref/errors.texi index fb393b951f1..f848218e267 100644 --- a/doc/lispref/errors.texi +++ b/doc/lispref/errors.texi @@ -20,8 +20,9 @@ the errors in accessing files have the condition @code{file-error}. If we do not say here that a certain error symbol has additional error conditions, that means it has none. - As a special exception, the error symbol @code{quit} does not have the -condition @code{error}, because quitting is not considered an error. + As a special exception, the error symbols @code{quit} and +@code{minibuffer-quit} don't have the condition @code{error}, because +quitting is not considered an error. Most of these error symbols are defined in C (mainly @file{data.c}), but some are defined in Lisp. For example, the file @file{userlock.el} @@ -40,6 +41,10 @@ The message is @samp{error}. @xref{Errors}. @item quit The message is @samp{Quit}. @xref{Quitting}. +@item minibuffer-quit +The message is @samp{Quit}. This is a subcategory of @code{quit}. +@xref{Quitting}. + @item args-out-of-range The message is @samp{Args out of range}. This happens when trying to access an element beyond the range of a sequence, buffer, or other diff --git a/etc/NEWS b/etc/NEWS index 953c952d05d..df09d81bcfe 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2682,6 +2682,15 @@ also keep the type information of their arguments. Use the --- *** New face 'perl-heredoc', used for heredoc elements. ++++ +** A function can now be thrown to the 'exit' label in addition to t or nil. +The command loop will call it with zero arguments before returning. + ++++ +** New error symbol 'minibuffer-quit'. +Signaling it has almost the same effect as 'quit' except that it +doesn't cause keyboard macro termination. + --- *** The command 'cperl-set-style' offers the new value "PBP". This value customizes Emacs to use the style recommended in Damian diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 813ce14c59b..1578ab8e1ea 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -2328,6 +2328,15 @@ variables.") (setq deactivate-mark nil) (throw 'exit nil)) +(defun minibuffer-quit-recursive-edit () + "Quit the command that requested this recursive edit without error. +Like `abort-recursive-edit' without aborting keyboard macro +execution." + ;; See Info node `(elisp)Recursive Editing' for an explanation of + ;; throwing a function to `exit'. + (throw 'exit (lambda () + (signal 'minibuffer-quit nil)))) + (defun self-insert-and-exit () "Terminate minibuffer input." (interactive) diff --git a/lisp/simple.el b/lisp/simple.el index 5741c24eb7b..1a49fe24252 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2879,8 +2879,10 @@ Go to the history element by the absolute history position HIST-POS." The same as `command-error-default-function' but display error messages at the end of the minibuffer using `minibuffer-message' to not obscure the minibuffer contents." - (discard-input) - (ding) + (if (memq 'minibuffer-quit (get (car data) 'error-conditions)) + (ding t) + (discard-input) + (ding)) (let ((string (error-message-string data))) ;; If we know from where the error was signaled, show it in ;; *Messages*. diff --git a/src/data.c b/src/data.c index 9adfafacaa5..ffca7e75355 100644 --- a/src/data.c +++ b/src/data.c @@ -3901,6 +3901,7 @@ syms_of_data (void) DEFSYM (Qerror, "error"); DEFSYM (Quser_error, "user-error"); DEFSYM (Qquit, "quit"); + DEFSYM (Qminibuffer_quit, "minibuffer-quit"); DEFSYM (Qwrong_length_argument, "wrong-length-argument"); DEFSYM (Qwrong_type_argument, "wrong-type-argument"); DEFSYM (Qargs_out_of_range, "args-out-of-range"); @@ -3973,6 +3974,7 @@ syms_of_data (void) Fput (sym, Qerror_message, build_pure_c_string (msg)) PUT_ERROR (Qquit, Qnil, "Quit"); + PUT_ERROR (Qminibuffer_quit, pure_cons (Qquit, Qnil), "Quit"); PUT_ERROR (Quser_error, error_tail, ""); PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument"); diff --git a/src/keyboard.c b/src/keyboard.c index 77d6bbba623..db934686594 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -725,6 +725,9 @@ recursive_edit_1 (void) if (STRINGP (val)) xsignal1 (Qerror, val); + if (FUNCTIONP (val)) + call0 (val); + return unbind_to (count, Qnil); } @@ -921,6 +924,7 @@ static Lisp_Object cmd_error (Lisp_Object data) { Lisp_Object old_level, old_length; + Lisp_Object conditions; char macroerror[sizeof "After..kbd macro iterations: " + INT_STRLEN_BOUND (EMACS_INT)]; @@ -940,10 +944,15 @@ cmd_error (Lisp_Object data) else *macroerror = 0; + conditions = Fget (XCAR (data), Qerror_conditions); + if (NILP (Fmemq (Qminibuffer_quit, conditions))) + { + Vexecuting_kbd_macro = Qnil; + executing_kbd_macro = Qnil; + } + Vstandard_output = Qt; Vstandard_input = Qt; - Vexecuting_kbd_macro = Qnil; - executing_kbd_macro = Qnil; kset_prefix_arg (current_kboard, Qnil); kset_last_prefix_arg (current_kboard, Qnil); cancel_echoing (); @@ -998,6 +1007,7 @@ Default value of `command-error-function'. */) (Lisp_Object data, Lisp_Object context, Lisp_Object signal) { struct frame *sf = SELECTED_FRAME (); + Lisp_Object conditions; CHECK_STRING (context); @@ -1024,17 +1034,27 @@ Default value of `command-error-function'. */) } else { + conditions = Fget (XCAR (data), Qerror_conditions); + clear_message (1, 0); - Fdiscard_input (); message_log_maybe_newline (); - bitch_at_user (); + + if (!NILP (Fmemq (Qminibuffer_quit, conditions))) + { + Fding (Qt); + } + else + { + Fdiscard_input (); + bitch_at_user (); + } print_error_message (data, Qt, SSDATA (context), signal); } return Qnil; } -static Lisp_Object command_loop_2 (Lisp_Object); +static Lisp_Object command_loop_1 (void); static Lisp_Object top_level_1 (Lisp_Object); /* Entry to editor-command-loop. @@ -1062,7 +1082,7 @@ command_loop (void) if (command_loop_level > 0 || minibuf_level > 0) { Lisp_Object val; - val = internal_catch (Qexit, command_loop_2, Qnil); + val = internal_catch (Qexit, command_loop_2, Qerror); executing_kbd_macro = Qnil; return val; } @@ -1070,7 +1090,7 @@ command_loop (void) while (1) { internal_catch (Qtop_level, top_level_1, Qnil); - internal_catch (Qtop_level, command_loop_2, Qnil); + internal_catch (Qtop_level, command_loop_2, Qerror); executing_kbd_macro = Qnil; /* End of file in -batch run causes exit here. */ @@ -1083,15 +1103,16 @@ command_loop (void) editing loop, and reenter the editing loop. When there is an error, cmd_error runs and returns a non-nil value to us. A value of nil means that command_loop_1 itself - returned due to end of file (or end of kbd macro). */ + returned due to end of file (or end of kbd macro). HANDLERS is a + list of condition names, passed to internal_condition_case. */ -static Lisp_Object -command_loop_2 (Lisp_Object ignore) +Lisp_Object +command_loop_2 (Lisp_Object handlers) { register Lisp_Object val; do - val = internal_condition_case (command_loop_1, Qerror, cmd_error); + val = internal_condition_case (command_loop_1, handlers, cmd_error); while (!NILP (val)); return Qnil; @@ -1234,7 +1255,7 @@ static int read_key_sequence (Lisp_Object *, Lisp_Object, bool, bool, bool, bool); static void adjust_point_for_property (ptrdiff_t, bool); -Lisp_Object +static Lisp_Object command_loop_1 (void) { modiff_count prev_modiff = 0; diff --git a/src/lisp.h b/src/lisp.h index 1795b9d811b..b3f1dc16b13 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4417,7 +4417,7 @@ extern bool detect_input_pending_ignore_squeezables (void); extern bool detect_input_pending_run_timers (bool); extern void safe_run_hooks (Lisp_Object); extern void cmd_error_internal (Lisp_Object, const char *); -extern Lisp_Object command_loop_1 (void); +extern Lisp_Object command_loop_2 (Lisp_Object); extern Lisp_Object read_menu_command (void); extern Lisp_Object recursive_edit_1 (void); extern void record_auto_save (void); diff --git a/src/macros.c b/src/macros.c index 60d0766a754..0752a5bb6f6 100644 --- a/src/macros.c +++ b/src/macros.c @@ -324,7 +324,7 @@ buffer before the macro is executed. */) break; } - command_loop_1 (); + command_loop_2 (list1 (Qminibuffer_quit)); executing_kbd_macro_iterations = ++success_count; diff --git a/src/minibuf.c b/src/minibuf.c index 1b842b77211..0f4349e70b8 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -496,7 +496,7 @@ confirm the aborting of the current minibuffer and all contained ones. */) } } else - Fthrow (Qexit, Qt); + CALLN (Ffuncall, intern ("minibuffer-quit-recursive-edit")); return Qnil; } -- cgit v1.2.3