[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 2b3c7c7 6/6: Store function type and expose it with
From: |
Andrea Corallo |
Subject: |
feature/native-comp 2b3c7c7 6/6: Store function type and expose it with `subr-type' |
Date: |
Mon, 28 Dec 2020 10:33:16 -0500 (EST) |
branch: feature/native-comp
commit 2b3c7c751739f48545c3888549ae312ea334951b
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
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 3b84569..35a9e05 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 754b8f2..bdf721e 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 ee8ae98..04bf997 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 544b20d..c547649 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 efbb7a4..6f00ae8 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 ae5bbef..a9c43a4 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 d4eb39a..c79190e 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
- feature/native-comp updated (42fb6de -> 2b3c7c7), Andrea Corallo, 2020/12/28
- feature/native-comp ccce152 1/6: * Improve some slot type into comp.el, Andrea Corallo, 2020/12/28
- feature/native-comp 8a0467e 2/6: ; lisp/emacs-lisp/comp.el (comp-emit-narg-prologue): Nit., Andrea Corallo, 2020/12/28
- feature/native-comp eafcc8e 4/6: Propagate function calls also when hiddend under funcall, Andrea Corallo, 2020/12/28
- feature/native-comp 5a8622b 5/6: Reorder subr register function arguments to make some room, Andrea Corallo, 2020/12/28
- feature/native-comp e532ec9 3/6: Compute function type for native compiled functions, Andrea Corallo, 2020/12/28
- feature/native-comp 2b3c7c7 6/6: Store function type and expose it with `subr-type',
Andrea Corallo <=