(sym-to-c-name-h (make-hash-table :test #'eq) :type hash-table
:documentation "symbol-function -> c-name.
This is only for optimizing intra CU calls at speed 3.")
- (byte-func-to-func-h (make-hash-table :test #'eq) :type hash-table
+ (byte-func-to-func-h (make-hash-table :test #'equal) :type hash-table
:documentation "byte-function -> comp-func.
Needed to replace immediate byte-compiled lambdas with the compiled reference.")
+ (lambda-fixups-h (make-hash-table :test #'equal) :type hash-table
+ :documentation "Hash table byte-func -> mvar to fixup.")
(function-docs (make-hash-table :test #'eql) :type (or hash-table vector)
:documentation "Documentation index -> documentation")
(d-default (make-comp-data-container) :type comp-data-container
(make-comp-mvar :constant form))
(make-comp-mvar :constant t))))))
+(defun comp-emit-lambda-for-top-level (func)
+ "Emit the creation of subrs for lambda FUNC.
+These are stored in the reloc data array."
+ (let ((args (comp-func-args func)))
+ (let ((comp-curr-allocation-class 'd-impure))
+ (comp-add-const-to-relocs (comp-func-byte-func func)))
+ (comp-emit
+ (comp-call 'comp--register-lambda
+ ;; mvar to be fixed-up when containers are
+ ;; finalized.
+ (or (gethash (comp-func-byte-func func)
+ (comp-ctxt-lambda-fixups-h comp-ctxt))
+ (puthash (comp-func-byte-func func)
+ (make-comp-mvar :constant nil)
+ (comp-ctxt-lambda-fixups-h comp-ctxt)))
+ (make-comp-mvar :constant (comp-args-base-min args))
+ (make-comp-mvar :constant (if (comp-args-p args)
+ (comp-args-max args)
+ 'many))
+ (make-comp-mvar :constant (comp-func-c-name func))
+ (make-comp-mvar
+ :constant (let* ((h (comp-ctxt-function-docs comp-ctxt))
+ (i (hash-table-count h)))
+ (puthash i (comp-func-doc func) h)
+ i))
+ (make-comp-mvar :constant (comp-func-int-spec func))
+ ;; This is the compilation unit it-self passed as
+ ;; parameter.
+ (make-comp-mvar :slot 0)))))
+
(defun comp-limplify-top-level (for-late-load)
"Create a limple function to modify the global environment at load.
When FOR-LATE-LOAD is non nil the emitted function modifies only
(d-impure-idx (comp-data-container-idx d-impure))
(d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
(d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
+ ;; We never want compiled lambdas ending up in pure space. A copy must
+ ;; be already present in impure (see `comp-emit-lambda-for-top-level').
+ (cl-loop for obj being each hash-keys of d-default-idx
+ when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
+ do (cl-assert (gethash obj d-impure-idx))
+ (remhash obj d-default-idx))
;; Remove entries in d-impure already present in d-default.
(cl-loop for obj being each hash-keys of d-impure-idx
when (gethash obj d-default-idx)
for doc = (gethash idx h)
do (setf (aref v idx) doc)
finally
- do (setf (comp-ctxt-function-docs comp-ctxt) v))))
+ do (setf (comp-ctxt-function-docs comp-ctxt) v))
+ ;; And now we conclude with the following: We need to pass to
+ ;; `comp--register-lambda' the index in the impure relocation
+ ;; array to store revived lambdas, but given we know it only now
+ ;; we fix it up as last.
+ (cl-loop for f being each hash-keys of (comp-ctxt-lambda-fixups-h comp-ctxt)
+ using (hash-value mvar)
+ with reverse-h = (make-hash-table) ;; Make sure idx is unique.
+ for idx = (gethash f d-impure-idx)
+ do
+ (cl-assert (null (gethash idx reverse-h)))
+ (cl-assert (fixnump idx))
+ (setf (comp-mvar-constant mvar) idx)
+ (puthash idx t reverse-h))))
(defun comp-compile-ctxt-to-file (name)
"Compile as native code the current context naming it NAME.
Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM);
if (!saved_cu)
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
- bool reloading_cu = !NILP (*saved_cu);
+ comp_u->loaded_once = !NILP (*saved_cu);
Lisp_Object *data_eph_relocs =
dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
/* While resurrecting from an image dump loading more than once the
same compilation unit does not make any sense. */
- eassert (!(loading_dump && reloading_cu));
+ eassert (!(loading_dump && comp_u->loaded_once));
- if (reloading_cu)
+ if (comp_u->loaded_once)
/* 'dlopen' returns the same handle when trying to load two times
the same shared. In this case touching 'd_reloc' etc leads to
fails in case a frame with a reference to it in a live reg is
= dynlib_sym (handle,
late_load ? "late_top_level_run" : "top_level_run");
- if (!reloading_cu)
+ /* Always set data_imp_relocs pointer in the compilation unit (in can be
+ used in 'dump_do_dump_relocation'). */
+ comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
+
+ if (!comp_u->loaded_once)
{
struct thread_state ***current_thread_reloc =
dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
- Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
+ Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
if (!(current_thread_reloc
return AREF (cu->data_fdoc_v, XSUBR (function)->doc);
}
-DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
- 7, 7, 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_idx, Lisp_Object intspec,
- Lisp_Object comp_u)
+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)
{
- dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->handle;
+ struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
+ dynlib_handle_ptr handle = cu->handle;
if (!handle)
xsignal0 (Qwrong_register_subr_call);
x->s.function.a0 = func;
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.symbol_name = xstrdup (SSDATA (symbol_name));
x->s.native_intspec = intspec;
x->s.doc = XFIXNUM (doc_idx);
x->s.native_comp_u[0] = comp_u;
Lisp_Object tem;
XSETSUBR (tem, &x->s);
- set_symbol_function (name, tem);
- Fputhash (name, c_name, Vcomp_sym_subr_c_name_h);
+ return tem;
+}
+
+DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda,
+ 7, 7, 0,
+ doc: /* This gets called by top_level_run during load phase to register
+ anonymous lambdas. */)
+ (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg,
+ Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec,
+ Lisp_Object comp_u)
+{
+ struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
+ if (cu->loaded_once)
+ return Qnil;
+
+ Lisp_Object tem =
+ make_subr (c_name, minarg, maxarg, c_name, doc_idx, intspec, comp_u);
+
+ /* We must protect it against GC because the function is not
+ reachable through symbols. */
+ Fputhash (tem, Qt, cu->lambda_gc_guard);
+ /* This is for fixing up the value in d_reloc while resurrecting
+ from dump. See 'dump_do_dump_relocation'. */
+ Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h);
+ /* The key is not really important as long is the same as
+ symbol_name so use c_name. */
+ Fputhash (Fintern (c_name, Qnil), c_name, Vcomp_sym_subr_c_name_h);
+ /* Do the real relocation fixup. */
+ cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem;
+
+ return tem;
+}
+
+DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
+ 7, 7, 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_idx, Lisp_Object intspec,
+ Lisp_Object comp_u)
+{
+ Lisp_Object tem =
+ make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec,
+ comp_u);
+
+ set_symbol_function (name, tem);
LOADHIST_ATTACH (Fcons (Qdefun, name));
+ Fputhash (name, c_name, Vcomp_sym_subr_c_name_h);
- return Qnil;
+ return tem;
}
DEFUN ("comp--late-register-subr", Fcomp__late_register_subr,
/* Load related routines. */
DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0,
doc: /* Load native elisp code FILE.
- LATE_LOAD has to be non nil when loading for deferred
- compilation. */)
+ LATE_LOAD has to be non nil when loading for deferred
+ compilation. */)
(Lisp_Object file, Lisp_Object late_load)
{
CHECK_STRING (file);
xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ()));
comp_u->file = file;
comp_u->data_vec = Qnil;
+ comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq);
+ comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
load_comp_unit (comp_u, false, !NILP (late_load));
return Qt;
defsubr (&Scomp__init_ctxt);
defsubr (&Scomp__release_ctxt);
defsubr (&Scomp__compile_ctxt_to_file);
+ defsubr (&Scomp__register_lambda);
defsubr (&Scomp__register_subr);
defsubr (&Scomp__late_register_subr);
defsubr (&Snative_elisp_load);
static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state;
struct Lisp_Native_Comp_Unit *comp_u =
dump_ptr (dump_base, reloc_offset);
-
+ comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq);
if (!CONSP (comp_u->file))
error ("Trying to load incoherent dumped .eln");
}
case RELOC_NATIVE_SUBR:
{
+ /* When resurrecting from a dump given non all the original
+ native compiled subrs may be still around we can't rely on
+ a 'top_level_run' mechanism, we revive them one-by-one
+ here. */
struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset);
Lisp_Object name = intern (subr->symbol_name);
struct Lisp_Native_Comp_Unit *comp_u =
if (!func)
error ("can't find function in compilation unit");
subr->function.a0 = func;
+ Lisp_Object lambda_data_idx =
+ Fgethash (c_name, comp_u->lambda_c_name_idx_h, Qnil);
+ if (!NILP (lambda_data_idx))
+ {
+ /* This is an anonymous lambda.
+ We must fixup data_vec so the lambda can be referenced
+ by code. */
+ Lisp_Object tem;
+ XSETSUBR (tem, subr);
+ comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)] = tem;
+ Fputhash (tem, Qnil, comp_u->lambda_gc_guard);
+ }
break;
}
#endif
projects / emacs.git / commitdiff