From 44b0ce6e38f06df10b60ffdd9d9ade4b7e229088 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 2 May 2020 17:29:11 +0100 Subject: [PATCH] Add anonymous lambdas reload mechanism * src/pdumper.c (dump_do_dump_relocation): Initialize 'lambda_gc_guard' while resurrecting. (dump_do_dump_relocation): Revive lambdas and fixup them. * src/comp.h (struct Lisp_Native_Comp_Unit): Define new 'lambda_gc_guard' 'lambda_c_name_idx_h' 'data_imp_relocs' 'loaded_once' fields. * src/comp.c (load_comp_unit): Use compilaiton unit 'loaded_once' field. (make_subr, Fcomp__register_lambda): New functions. (Fcomp__register_subr): Make use of 'make_subr'. (Fnative_elisp_load): Indent. (Fnative_elisp_load): Initialize 'lambda_gc_guard' 'lambda_c_name_idx_h' fields. (syms_of_comp): Add Scomp__register_lambda. * lisp/emacs-lisp/comp.el (comp-ctxt): Change 'byte-func-to-func-h' hash key test. (comp-ctxt): Add 'lambda-fixups-h' slot. (comp-emit-lambda-for-top-level): New function. (comp-finalize-relocs): Never emit lambdas in pure space. (comp-finalize-relocs): Fixup relocation indexes. --- lisp/emacs-lisp/comp.el | 55 +++++++++++++++++++++++++- src/comp.c | 88 ++++++++++++++++++++++++++++++++--------- src/comp.h | 14 +++++-- src/pdumper.c | 18 ++++++++- 4 files changed, 150 insertions(+), 25 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 3bcfdc9420b..94ffc2d1778 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -230,9 +230,11 @@ Can be one of: 'd-default', 'd-impure' or 'd-ephemeral'. See `comp-ctxt'.") (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 @@ -1276,6 +1278,36 @@ the annotation emission." (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 @@ -2143,6 +2175,12 @@ Update all insn accordingly." (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) @@ -2162,7 +2200,20 @@ Update all insn accordingly." 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. diff --git a/src/comp.c b/src/comp.c index 947da9a8e27..5ace2d28052 100644 --- a/src/comp.c +++ b/src/comp.c @@ -3583,15 +3583,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, 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 @@ -3612,13 +3612,17 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, = 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 @@ -3704,15 +3708,13 @@ native_function_doc (Lisp_Object function) 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); @@ -3727,18 +3729,63 @@ DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, 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, @@ -3759,8 +3806,8 @@ 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); @@ -3773,6 +3820,8 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, 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; @@ -3886,6 +3935,7 @@ syms_of_comp (void) 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); diff --git a/src/comp.h b/src/comp.h index cbdcaccd5fe..b03a8055142 100644 --- a/src/comp.h +++ b/src/comp.h @@ -37,13 +37,21 @@ struct Lisp_Native_Comp_Unit /* Original eln file loaded. */ Lisp_Object file; Lisp_Object optimize_qualities; - /* Hash doc-idx -> function documentaiton. */ + /* Guard anonymous lambdas against Garbage Collection and make them + dumpable. */ + Lisp_Object lambda_gc_guard; + /* Hash c_name -> d_reloc_imp index. */ + Lisp_Object lambda_c_name_idx_h; + /* Hash doc-idx -> function documentaiton. */ Lisp_Object data_fdoc_v; /* Analogous to the constant vector but per compilation unit. */ Lisp_Object data_vec; - /* Same but for data that cannot be moved to pure space. - Must be the last lisp object here. */ + /* 'data_impure_vec' must be last (see allocate_native_comp_unit). + Same as data_vec but for data that cannot be moved to pure space. */ Lisp_Object data_impure_vec; + /* STUFFS WE DO NOT DUMP!! */ + Lisp_Object *data_imp_relocs; + bool loaded_once; dynlib_handle_ptr handle; }; diff --git a/src/pdumper.c b/src/pdumper.c index f837dfc38d2..a1b71e87ac6 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -5297,7 +5297,7 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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"); @@ -5320,6 +5320,10 @@ dump_do_dump_relocation (const uintptr_t dump_base, } 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 = @@ -5333,6 +5337,18 @@ dump_do_dump_relocation (const uintptr_t dump_base, 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 -- 2.39.5