feature/native-comp 44b0ce6 10/17: Add anonymous lambdas reload mechanism

[Andrea Corallo]

branch: feature/native-comp
commit 44b0ce6e38f06df10b60ffdd9d9ade4b7e229088
Author: Andrea Corallo <address@hidden>
Commit: Andrea Corallo <address@hidden>

    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 3bcfdc9..94ffc2d 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 947da9a..5ace2d2 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 cbdcacc..b03a805 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 f837dfc..a1b71e8 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