feature/native-comp 5543338 4/7: Optimize relocation classes for object duplication

[Andrea Corallo]

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

    Optimize relocation classes for object duplication
    
    Merge duplicated  objects during final. Precendece is:
    1 d-default
    2 d-impure
    3 d-ephemeral
    
    Now every object identify uniquely a relocation class.  Because of
    this there's no need to keep the reloc class into m-var.
---
 lisp/emacs-lisp/comp.el |  95 +++++++++++++++++++++----------------
 src/comp.c              | 121 ++++++++++++++++++++++++++++--------------------
 2 files changed, 124 insertions(+), 92 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 6ad9706..7792605 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -318,10 +318,7 @@ structure.")
  a value known at compile time.")
   (type nil :type symbol
         :documentation "When non nil indicates the type when known at compile
- time.")
-  (alloc-class nil :type symbol
-               :documentation "Can be one of: 'd-default' 'd-impure'
-               or 'd-ephemeral'."))
+ time."))
 
 ;; Special vars used by some passes
 (defvar comp-func)
@@ -344,31 +341,15 @@ structure.")
   "Type hint predicate for function name FUNC."
   (when (memq func comp-type-hints) t))
 
-(defun comp-data-container-check (cont)
-  "Sanity check CONT coherency."
-  (cl-assert (= (length (comp-data-container-l cont))
-                (hash-table-count (comp-data-container-idx cont)))))
-
-(defun comp-add-const-to-relocs-to-cont (obj cont)
-  "Keep track of OBJ into the CONT relocation container.
-The corresponding index is returned."
-  (let ((h (comp-data-container-idx cont)))
-    (if-let ((idx (gethash obj h)))
-        idx
-      (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-default as default."
   (cl-struct-slot-value 'comp-ctxt (or alloc-class 'd-default) 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
-                                    (comp-alloc-class-to-container
-                                     comp-curr-allocation-class)))
+(defsubst comp-add-const-to-relocs (obj)
+  "Keep track of OBJ into the ctxt relocations."
+  (puthash obj t (comp-data-container-idx (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.
@@ -642,7 +623,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 :alloc-class comp-curr-allocation-class))
+                   :type type))
 
 (defun comp-new-frame (size &optional ssa)
   "Return a clean frame of meta variables of size SIZE.
@@ -679,11 +660,12 @@ If DST-N is specified use it otherwise assume it to be 
the current slot."
   "Emit annotation STR."
   (comp-emit `(comment ,str)))
 
-(defun comp-emit-setimm (val)
+(defsubst comp-emit-setimm (val)
   "Set constant VAL to current slot."
-  (let ((rel-idx (comp-add-const-to-relocs val)))
-    (cl-assert (numberp rel-idx))
-    (comp-emit `(setimm ,(comp-slot) ,rel-idx ,val))))
+  (comp-add-const-to-relocs val)
+  ;; Leave relocation index nil on purpose, will be fixed-up in final
+  ;; by `comp-finalize-relocs'.
+  (comp-emit `(setimm ,(comp-slot) nil ,val)))
 
 (defun comp-make-curr-block (block-name entry-sp &optional addr)
   "Create a basic block with BLOCK-NAME and set it as current block.
@@ -1281,13 +1263,11 @@ 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
-                                   (alloc-class comp-curr-allocation-class))
+(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
   (let ((mvar (make--comp-mvar :slot slot
                                :const-vld const-vld
                                :constant constant
-                               :type type
-                               :alloc-class alloc-class)))
+                               :type type)))
     (setf (comp-mvar-id mvar) (sxhash-eq mvar))
     mvar))
 
@@ -1674,10 +1654,11 @@ Here goes everything that can be done not iteratively 
(read once).
       ;; pruning in order to be sure that this is not dead-code.  This
       ;; is now left to gcc, to be implemented only if we want a
       ;; reliable diagnostic here.
-      (let ((values (apply f (mapcar #'comp-mvar-constant args))))
+      (let ((value (apply f (mapcar #'comp-mvar-constant args))))
         ;; See `comp-emit-setimm'.
+        (comp-add-const-to-relocs value)
         (setf (car insn) 'setimm
-              (cddr insn) (list (comp-add-const-to-relocs values) values))))))
+              (cddr insn) `(nil ,value))))))
 
 (defun comp-propagate-insn (insn)
   "Propagate within INSN."
@@ -1967,15 +1948,47 @@ These are substituted with a normal 'set' op."
 
 ;;; Final pass specific code.
 
+(defun comp-finalize-container (cont)
+  "Finalize data container CONT."
+  (setf (comp-data-container-l cont)
+        (cl-loop with h = (comp-data-container-idx cont)
+                 for obj each hash-keys of h
+                 for i from 0
+                 do (puthash obj i h)
+                 collect obj)))
+
+(defun comp-finalize-relocs ()
+  "Finalize data containers for each relocation class.
+Remove immediate duplicates within relocation classes.
+Update all insn accordingly."
+  ;; Symbols imported by C inlined functions.  We do this here because
+  ;; is better to add all objs to the relocation containers before we
+  ;; compacting them.
+  (mapc #'comp-add-const-to-relocs '(nil t consp listp))
+
+  (let* ((d-default (comp-ctxt-d-default comp-ctxt))
+         (d-default-idx (comp-data-container-idx d-default))
+         (d-impure (comp-ctxt-d-impure comp-ctxt))
+         (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)))
+    ;; Remove things in d-impure that are already in d-default.
+    (cl-loop for obj being each hash-keys of d-impure-idx
+             when (gethash obj d-default-idx)
+               do (remhash obj d-impure-idx))
+    ;; Remove things in d-ephemeral that are already in d-default or
+    ;; d-impure.
+    (cl-loop for obj being each hash-keys of d-ephemeral-idx
+             when (or (gethash obj d-default-idx) (gethash obj d-impure-idx))
+               do (remhash obj d-ephemeral-idx))
+    ;; Fix-up indexes in each relocation class and fill corresponding
+    ;; reloc lists.
+    (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))))
+
 (defun comp-compile-ctxt-to-file (name)
   "Compile as native code the current context naming it NAME.
 Prepare every function for final compilation and drive the C back-end."
-  (comp-data-container-check (comp-ctxt-d-default comp-ctxt))
-  (comp-data-container-check (comp-ctxt-d-impure comp-ctxt))
-  (comp-data-container-check (comp-ctxt-d-ephemeral comp-ctxt))
-  ;; TODO: here we could optimize cleaning up objects present in the
-  ;; impure and or in the ephemeral container that are also in the
-  ;; default one.
+  (comp-finalize-relocs)
   (unless comp-dry-run
     (comp--compile-ctxt-to-file name)))
 
diff --git a/src/comp.c b/src/comp.c
index 0fc6e41..bcb0c69 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -185,6 +185,9 @@ typedef struct {
   gcc_jit_rvalue *data_relocs_ephemeral;
   /* Synthesized struct holding func relocs.  */
   gcc_jit_lvalue *func_relocs;
+  Lisp_Object d_default_idx;
+  Lisp_Object d_impure_idx;
+  Lisp_Object d_ephemeral_idx;
 } comp_t;
 
 static comp_t comp;
@@ -197,6 +200,11 @@ typedef struct {
   const char data[];
 } static_obj_t;
 
+typedef struct {
+  gcc_jit_rvalue *array;
+  gcc_jit_rvalue *idx;
+} imm_reloc_t;
+
 
 /*
    Helper functions called by the run-time.
@@ -387,18 +395,43 @@ 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_default)
-    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"));
+static imm_reloc_t
+obj_to_reloc (Lisp_Object obj)
+{
+  imm_reloc_t reloc;
+  Lisp_Object idx;
+
+  idx = Fgethash (obj, comp.d_default_idx, Qnil);
+  if (!NILP (idx)) {
+      reloc.array = comp.data_relocs;
+      goto found;
+  }
+
+  idx = Fgethash (obj, comp.d_impure_idx, Qnil);
+  if (!NILP (idx))
+    {
+      reloc.array = comp.data_relocs_impure;
+      goto found;
+    }
+
+  idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil);
+  if (!NILP (idx))
+    {
+      reloc.array = comp.data_relocs_ephemeral;
+      goto found;
+    }
+
+  xsignal1 (Qnative_ice,
+           build_string ("cant't find data in relocation containers"));
   assume (false);
+ found:
+  if (!FIXNUMP (idx))
+    xsignal1 (Qnative_ice,
+             build_string ("inconsistent data relocation container"));
+  reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+                                                  comp.ptrdiff_type,
+                                                  XFIXNUM (idx));
+  return reloc;
 }
 
 static void
@@ -912,7 +945,7 @@ emit_make_fixnum (gcc_jit_rvalue *obj)
 }
 
 static gcc_jit_rvalue *
-emit_const_lisp_obj (Lisp_Object obj, Lisp_Object alloc_class)
+emit_const_lisp_obj (Lisp_Object obj)
 {
   emit_comment (format_string ("const lisp obj: %s",
                               SSDATA (Fprin1_to_string (obj, Qnil))));
@@ -922,28 +955,20 @@ emit_const_lisp_obj (Lisp_Object obj, Lisp_Object 
alloc_class)
                      gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
                                                           comp.void_ptr_type,
                                                           NULL));
-
-  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));
-  gcc_jit_rvalue *reloc_n =
-    gcc_jit_context_new_rvalue_from_int (comp.ctxt,
-                                        comp.ptrdiff_type,
-                                        XFIXNUM (reloc_idx));
+  imm_reloc_t reloc = obj_to_reloc (obj);
   return
     gcc_jit_lvalue_as_rvalue (
       gcc_jit_context_new_array_access (comp.ctxt,
                                        NULL,
-                                       alloc_class_to_reloc (alloc_class),
-                                       reloc_n));
+                                       reloc.array,
+                                       reloc.idx));
 }
 
 static gcc_jit_rvalue *
 emit_NILP (gcc_jit_rvalue *x)
 {
   emit_comment ("NILP");
-  return emit_EQ (x, emit_const_lisp_obj (Qnil, Qd_default));
+  return emit_EQ (x, emit_const_lisp_obj (Qnil));
 }
 
 static gcc_jit_rvalue *
@@ -1046,7 +1071,7 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
 
   gcc_jit_rvalue *args[] =
     { emit_CONSP (x),
-      emit_const_lisp_obj (Qconsp, Qd_default),
+      emit_const_lisp_obj (Qconsp),
       x };
 
   gcc_jit_block_add_eval (
@@ -1157,8 +1182,7 @@ 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-alloc-class, mvar));
+      return emit_const_lisp_obj (constant);
     }
 
   return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar));
@@ -1193,7 +1217,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, Qd_default);
+  gcc_args[2] = emit_const_lisp_obj (Qnil);
   gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
                                                     comp.int_type,
                                                     SET_INTERNAL_SET);
@@ -1571,20 +1595,15 @@ emit_limple_insn (Lisp_Object insn)
   else if (EQ (op, Qsetimm))
     {
       /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) 3 a).  */
-      gcc_jit_rvalue *reloc_n =
-       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
-                                            comp.int_type,
-                                            XFIXNUM (arg[1]));
       emit_comment (SSDATA (Fprin1_to_string (arg[2], Qnil)));
+      imm_reloc_t reloc = obj_to_reloc (arg[2]);
       emit_frame_assignment (
        arg[0],
        gcc_jit_lvalue_as_rvalue (
          gcc_jit_context_new_array_access (comp.ctxt,
                                            NULL,
-                                           alloc_class_to_reloc (
-                                             CALL1I (comp-mvar-alloc-class,
-                                                     arg[0])),
-                                           reloc_n)));
+                                           reloc.array,
+                                           reloc.idx)));
     }
   else if (EQ (op, Qcomment))
     {
@@ -1807,7 +1826,7 @@ declare_imported_data_relocs (Lisp_Object container, 
const char *code_symbol,
   EMACS_INT d_reloc_len =
     XFIXNUM (CALL1I (hash-table-count,
                     CALL1I (comp-data-container-idx, container)));
-  Lisp_Object d_reloc = Fnreverse (CALL1I (comp-data-container-l, container));
+  Lisp_Object d_reloc = CALL1I (comp-data-container-l, container);
   d_reloc = Fvconcat (1, &d_reloc);
 
   gcc_jit_rvalue *reloc_struct =
@@ -1830,12 +1849,6 @@ declare_imported_data_relocs (Lisp_Object container, 
const char *code_symbol,
 static void
 declare_imported_data (void)
 {
-  /* Imported symbols by inliner functions.  */
-  CALL1I (comp-add-const-to-relocs, Qnil);
-  CALL1I (comp-add-const-to-relocs, Qt);
-  CALL1I (comp-add-const-to-relocs, Qconsp);
-  CALL1I (comp-add-const-to-relocs, Qlistp);
-
   /* Imported objects.  */
   comp.data_relocs =
     declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt),
@@ -2449,11 +2462,11 @@ define_CAR_CDR (void)
       comp.block = is_nil_b;
       gcc_jit_block_end_with_return (comp.block,
                                     NULL,
-                                    emit_const_lisp_obj (Qnil, Qd_default));
+                                    emit_const_lisp_obj (Qnil));
 
       comp.block = not_nil_b;
       gcc_jit_rvalue *wrong_type_args[] =
-       { emit_const_lisp_obj (Qlistp, Qd_default), c };
+       { emit_const_lisp_obj (Qlistp), c };
 
       gcc_jit_block_add_eval (comp.block,
                              NULL,
@@ -2462,7 +2475,7 @@ define_CAR_CDR (void)
                                         false));
       gcc_jit_block_end_with_return (comp.block,
                                     NULL,
-                                    emit_const_lisp_obj (Qnil, Qd_default));
+                                    emit_const_lisp_obj (Qnil));
     }
   comp.car = func[0];
   comp.cdr = func[1];
@@ -2842,12 +2855,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, Qd_default));
+                                emit_const_lisp_obj (Qt));
 
   comp.block = ret_nil_block;
   gcc_jit_block_end_with_return (ret_nil_block,
                                 NULL,
-                                emit_const_lisp_obj (Qnil, Qd_default));
+                                emit_const_lisp_obj (Qnil));
 }
 
 /* Declare a function being compiled and add it to comp.exported_funcs_h.  */
@@ -3206,8 +3219,14 @@ DEFUN ("comp--compile-ctxt-to-file", 
Fcomp__compile_ctxt_to_file,
   gcc_jit_context_set_int_option (comp.ctxt,
                                  GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
                                  SPEED);
-  sigset_t oldset;
+  comp.d_default_idx =
+    CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
+  comp.d_impure_idx =
+    CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt));
+  comp.d_ephemeral_idx =
+    CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, 
Vcomp_ctxt));
 
+  sigset_t oldset;
   if (!noninteractive)
     {
       sigset_t blocked;
@@ -3231,8 +3250,8 @@ DEFUN ("comp--compile-ctxt-to-file", 
Fcomp__compile_ctxt_to_file,
   define_add1_sub1 ();
   define_negate ();
 
-  struct Lisp_Hash_Table *func_h
-    = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
+  struct Lisp_Hash_Table *func_h =
+    XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
   for (ptrdiff_t i = 0; i < func_h->count; i++)
     declare_function (HASH_VALUE (func_h, i));
   /* Compile all functions. Can't be done before because the