feature/native-comp 94dcb69 3/6: Add ephemeral relocation data class

[Andrea Corallo]

branch: feature/native-comp
commit 94dcb69256a0daea2c51540217c3abdc2fd50552
Author: AndreaCorallo <address@hidden>
Commit: Andrea Corallo <address@hidden>

    Add ephemeral relocation data class
    
    Add a new class of relocated objects that is in use just during load
    process.  This in order to avoid having to maintain them in the heap
    and traverse them at every GC.
---
 lisp/emacs-lisp/comp.el | 39 ++++++++++++++++---------
 src/comp.c              | 78 +++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 88 insertions(+), 29 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 7054c58..000f266 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -32,6 +32,7 @@
 (require 'gv)
 (require 'cl-lib)
 (require 'cl-extra)
+(require 'cl-macs)
 (require 'subr-x)
 
 (defgroup comp nil
@@ -113,7 +114,9 @@ Can be used by code that wants to expand differently in 
this case.")
 (defvar comp-pass nil
   "Every pass has the right to bind what it likes here.")
 
-(defvar comp-emitting-impure nil "Non nil to emit only impure objects.")
+(defvar comp-curr-allocation-class 'd-base
+  "Current allocation class.
+Can be one of: 'd-base', 'd-impure' or 'd-ephemeral'.  See `comp-ctxt'.")
 
 (defconst comp-passes '(comp-spill-lap
                         comp-limplify
@@ -196,8 +199,10 @@ This is to build the prev field.")
   (d-base (make-comp-data-container) :type comp-data-container
           :documentation "Standard data relocated in use by functions.")
   (d-impure (make-comp-data-container) :type comp-data-container
-          :documentation "Data relocated that cannot be moved into pure space.
-This is tipically for top-level forms other than defun."))
+          :documentation "Relocated data that cannot be moved into pure space.
+This is tipically for top-level forms other than defun.")
+  (d-ephemeral (make-comp-data-container) :type comp-data-container
+               :documentation "Relocated data not necessary after load."))
 
 (cl-defstruct comp-args-base
   (min nil :type number
@@ -314,8 +319,9 @@ structure.")
   (type nil :type symbol
         :documentation "When non nil indicates the type when known at compile
  time.")
-  (impure nil :type boolean
-          :documentation "When non nil can't be copied into pure space."))
+  (alloc-class nil :type symbol
+               :documentation "Can be one of: 'd-base' 'd-impure'
+               or 'd-ephemeral'."))
 
 ;; Special vars used by some passes
 (defvar comp-func)
@@ -352,13 +358,17 @@ The corresponding index is returned."
       (push obj (comp-data-container-l cont))
       (puthash obj (hash-table-count h) h))))
 
+(defsubst comp-alloc-class-to-container (alloc-class)
+  "Given ALLOC-CLASS return the data container for the current context.
+Assume allocaiton class 'd-base as default."
+  (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-base) comp-ctxt))
+
 (defun comp-add-const-to-relocs (obj)
   "Keep track of OBJ into the ctxt relocations.
 The corresponding index is returned."
   (comp-add-const-to-relocs-to-cont obj
-                                    (if comp-emitting-impure
-                                        (comp-ctxt-d-impure comp-ctxt)
-                                      (comp-ctxt-d-base comp-ctxt))))
+                                    (comp-alloc-class-to-container
+                                     comp-curr-allocation-class)))
 
 (defmacro comp-within-log-buff (&rest body)
   "Execute BODY while at the end the log-buffer.
@@ -632,7 +642,7 @@ STACK-OFF is the index of the first slot frame involved."
   (when const-vld
     (comp-add-const-to-relocs constant))
   (make--comp-mvar :slot slot :const-vld const-vld :constant constant
-                   :type type :impure comp-emitting-impure))
+                   :type type :alloc-class comp-curr-allocation-class))
 
 (defun comp-new-frame (size &optional ssa)
   "Return a clean frame of meta variables of size SIZE.
@@ -1143,7 +1153,7 @@ the annotation emission."
 (cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level))
   (let ((form (byte-to-native-top-level-form form)))
     (comp-emit (comp-call 'eval
-                          (let ((comp-emitting-impure t))
+                          (let ((comp-curr-allocation-class 'd-impure))
                             (make-comp-mvar :constant form))
                           (make-comp-mvar :constant t)))))
 
@@ -1158,7 +1168,7 @@ into the C code forwarding the compilation unit."
   ;; Once an .eln is loaded and Emacs is dumped 'top_level_run' has no
   ;; reasons to be execute ever again.  Therefore all objects can be
   ;; just impure.
-  (let* ((comp-emitting-impure t)
+  (let* ((comp-curr-allocation-class 'd-impure)
          (func (make-comp-func :name 'top-level-run
                                :c-name "top_level_run"
                                :args (make-comp-args :min 1 :max 1)
@@ -1271,11 +1281,13 @@ Top-level forms for the current context are rendered 
too."
 ;; this form is called 'minimal SSA form'.
 ;; This pass should be run every time basic blocks or m-var are shuffled.
 
-(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
+(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type
+                                   (alloc-class comp-curr-allocation-class))
   (let ((mvar (make--comp-mvar :slot slot
                                :const-vld const-vld
                                :constant constant
-                               :type type)))
+                               :type type
+                               :alloc-class alloc-class)))
     (setf (comp-mvar-id mvar) (sxhash-eq mvar))
     mvar))
 
@@ -1960,6 +1972,7 @@ These are substituted with a normal 'set' op."
 Prepare every function for final compilation and drive the C back-end."
   (comp-data-container-check (comp-ctxt-d-base comp-ctxt))
   (comp-data-container-check (comp-ctxt-d-impure comp-ctxt))
+  (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt))
   (unless comp-dry-run
     (comp--compile-ctxt-to-file name)))
 
diff --git a/src/comp.c b/src/comp.c
index 2f24b10..b6de0ec 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -40,11 +40,13 @@ along with GNU Emacs.  If not, see 
<https://www.gnu.org/licenses/>.  */
 #define PURE_RELOC_SYM "pure_reloc"
 #define DATA_RELOC_SYM "d_reloc"
 #define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
+#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
 #define FUNC_LINK_TABLE_SYM "freloc_link_table"
 #define LINK_TABLE_HASH_SYM "freloc_hash"
 #define COMP_UNIT_SYM "comp_unit"
 #define TEXT_DATA_RELOC_SYM "text_data_reloc"
 #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp"
+#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
 
 #define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed))
 #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug))
@@ -178,6 +180,8 @@ typedef struct {
   gcc_jit_rvalue *data_relocs;
   /* Same as before but can't go in pure space. */
   gcc_jit_rvalue *data_relocs_impure;
+  /* Same as before but content does not survive load phase. */
+  gcc_jit_rvalue *data_relocs_ephemeral;
   /* Synthesized struct holding func relocs.  */
   gcc_jit_lvalue *func_relocs;
 } comp_t;
@@ -382,6 +386,20 @@ register_emitter (Lisp_Object key, void *func)
   Fputhash (key, value, comp.emitter_dispatcher);
 }
 
+static gcc_jit_rvalue *
+alloc_class_to_reloc (Lisp_Object alloc_class)
+{
+  if (alloc_class == Qd_base)
+    return comp.data_relocs;
+  else if (alloc_class == Qd_impure)
+    return comp.data_relocs_impure;
+  else if (alloc_class == Qd_ephemeral)
+    return comp.data_relocs_ephemeral;
+  xsignal (Qnative_ice,
+          build_string ("inconsistent allocation class"));
+  assume (false);
+}
+
 static void
 emit_comment (const char *str)
 {
@@ -893,7 +911,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj)
 }
 
 static gcc_jit_rvalue *
-emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure)
+emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class)
 {
   emit_comment (format_string ("const lisp obj: %s",
                               SSDATA (Fprin1_to_string (obj, Qnil))));
@@ -904,8 +922,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure)
                                                           comp.void_ptr_type,
                                                           NULL));
 
-  Lisp_Object container = impure ? CALL1I (comp-ctxt-d-impure, Vcomp_ctxt)
-                                 : CALL1I (comp-ctxt-d-base, Vcomp_ctxt);
+  Lisp_Object container = CALL1I (comp-alloc-class-to-container, alloc_class);
   Lisp_Object reloc_idx =
     Fgethash (obj, CALL1I (comp-data-container-idx, container), Qnil);
   eassert (!NILP (reloc_idx));
@@ -917,8 +934,7 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object impure)
     gcc_jit_lvalue_as_rvalue (
       gcc_jit_context_new_array_access (comp.ctxt,
                                        NULL,
-                                       impure ? comp.data_relocs_impure
-                                              : comp.data_relocs,
+                                       alloc_class_to_reloc (alloc_class),
                                        reloc_n));
 }
 
@@ -926,7 +942,7 @@ static gcc_jit_rvalue *
 emit_NILP (gcc_jit_rvalue *x)
 {
   emit_comment ("NILP");
-  return emit_EQ (x, emit_const_lisp_obj (Qnil, Qnil));
+  return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_base));
 }
 
 static gcc_jit_rvalue *
@@ -1029,7 +1045,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
 
   gcc_jit_rvalue *args[] =
     { emit_CONSP (x),
-      emit_const_lisp_obj (Qconsp, Qnil),
+      emit_const_lisp_obj (Qconsp, Qd_base),
       x };
 
   gcc_jit_block_add_eval (
@@ -1140,7 +1156,8 @@ emit_mvar_val (Lisp_Object mvar)
          return emit_cast (comp.lisp_obj_type, word);
        }
       /* Other const objects are fetched from the reloc array.  */
-      return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar));
+      return emit_const_lisp_obj (constant,
+                                 CALL1I (comp-mvar-alloc-class, mvar));
     }
 
   return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar));
@@ -1175,7 +1192,7 @@ emit_set_internal (Lisp_Object args)
   gcc_jit_rvalue *gcc_args[4];
   FOR_EACH_TAIL (args)
     gcc_args[i++] = emit_mvar_val (XCAR (args));
-  gcc_args[2] = emit_const_lisp_obj (Qnil, Qnil);
+  gcc_args[2] = emit_const_lisp_obj (Qnil, Qd_base);
   gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
                                                     comp.int_type,
                                                     SET_INTERNAL_SET);
@@ -1563,7 +1580,9 @@ emit_limple_insn (Lisp_Object insn)
        gcc_jit_lvalue_as_rvalue (
          gcc_jit_context_new_array_access (comp.ctxt,
                                            NULL,
-                                           comp.data_relocs,
+                                           alloc_class_to_reloc (
+                                             CALL1I (comp-mvar-alloc-class,
+                                                     arg[0])),
                                            reloc_n)));
     }
   else if (EQ (op, Qcomment))
@@ -1825,6 +1844,10 @@ declare_imported_data (void)
     declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt),
                                  DATA_RELOC_IMPURE_SYM,
                                  TEXT_DATA_RELOC_IMPURE_SYM);
+  comp.data_relocs_ephemeral =
+    declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt),
+                                 DATA_RELOC_EPHEMERAL_SYM,
+                                 TEXT_DATA_RELOC_EPHEMERAL_SYM);
 }
 
 /*
@@ -2417,11 +2440,11 @@ define_CAR_CDR (void)
       comp.block = is_nil_b;
       gcc_jit_block_end_with_return (comp.block,
                                     NULL,
-                                    emit_const_lisp_obj (Qnil, Qnil));
+                                    emit_const_lisp_obj (Qnil, Qd_base));
 
       comp.block = not_nil_b;
       gcc_jit_rvalue *wrong_type_args[] =
-       { emit_const_lisp_obj (Qlistp, Qnil), c };
+       { emit_const_lisp_obj (Qlistp, Qd_base), c };
 
       gcc_jit_block_add_eval (comp.block,
                              NULL,
@@ -2430,7 +2453,7 @@ define_CAR_CDR (void)
                                         false));
       gcc_jit_block_end_with_return (comp.block,
                                     NULL,
-                                    emit_const_lisp_obj (Qnil, Qnil));
+                                    emit_const_lisp_obj (Qnil, Qd_base));
     }
   comp.car = func[0];
   comp.cdr = func[1];
@@ -2810,13 +2833,12 @@ define_bool_to_lisp_obj (void)
   comp.block = ret_t_block;
   gcc_jit_block_end_with_return (ret_t_block,
                                 NULL,
-                                emit_const_lisp_obj (Qt, Qnil));
+                                emit_const_lisp_obj (Qt, Qd_base));
 
   comp.block = ret_nil_block;
   gcc_jit_block_end_with_return (ret_nil_block,
                                 NULL,
-                                emit_const_lisp_obj (Qnil, Qnil));
-
+                                emit_const_lisp_obj (Qnil, Qd_base));
 }
 
 /* Declare a function being compiled and add it to comp.exported_funcs_h.  */
@@ -3358,12 +3380,25 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, 
bool loading_dump)
       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_eph_relocs =
+       dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
       void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
+      Lisp_Object volatile data_ephemeral_vec;
+
+      /* Note: data_ephemeral_vec is not GC protected except than by
+        this function frame.  After this functions will be
+        deactivated GC will be free to collect it, but it MUST
+        survive till 'top_level_run' has finished his job.  We store
+        into the ephemeral allocation class only objects that we know
+        are necessary exclusively during the first load.  Once these
+        are collected we don't have to maintain them in the heap
+        forever.  */
 
       if (!(current_thread_reloc
            && pure_reloc
            && data_relocs
            && data_imp_relocs
+           && data_eph_relocs
            && freloc_link_table
            && top_level_run)
          || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
@@ -3382,6 +3417,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, 
bool loading_dump)
          comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM);
          comp_u->data_impure_vec =
            load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM);
+         data_ephemeral_vec =
+           load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM);
+
+         EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec));
+         for (EMACS_INT i = 0; i < d_vec_len; i++)
+           data_eph_relocs[i] = AREF (data_ephemeral_vec, i);
 
          if (!NILP (Vpurify_flag))
            /* Non impure can be copied into pure space.  */
@@ -3512,6 +3553,11 @@ syms_of_comp (void)
   DEFSYM (Qnumberp, "numberp");
   DEFSYM (Qintegerp, "integerp");
 
+  /* Allocation classes. */
+  DEFSYM (Qd_base, "d-base");
+  DEFSYM (Qd_impure, "d-impure");
+  DEFSYM (Qd_ephemeral, "d-ephemeral");
+
   /* Others.  */
   DEFSYM (Qfixnum, "fixnum");
   DEFSYM (Qscratch, "scratch");