From 2b3c7c751739f48545c3888549ae312ea334951b Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 28 Dec 2020 13:41:38 +0100 Subject: [PATCH] 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(-) 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 -- 2.39.5