igc--alloc-vectors

* src/igc.h:
* src/igc.c (scan_comp_units, igc_register_cu): Now conditioned by
HAVE_NATIVE_COMP.

src/comp.c

@@ -21,6 +21,9 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 #include <config.h>
 
 #include "lisp.h"
+#include "igc.h"
+#include "comp.h"
+#include "pdumper.h"
 
 #ifdef HAVE_NATIVE_COMP
 
@@ -5152,8 +5155,12 @@ eln_load_path_final_clean_up (void)
 static void
 register_native_comp_unit (Lisp_Object comp_u)
 {
-  Fputhash (
-    XNATIVE_COMP_UNIT (comp_u)->file, comp_u, Vcomp_loaded_comp_units_h);
+  Fputhash (XNATIVE_COMP_UNIT (comp_u)->file, comp_u,
+	    Vcomp_loaded_comp_units_h);
+# ifdef HAVE_MPS
+  if (pdumper_object_p (XNATIVE_COMP_UNIT (comp_u)))
+    igc_register_cu (comp_u);
+#endif
 }
 
 

src/igc.c

@@ -299,6 +299,16 @@ igc_round (size_t nbytes, size_t align)
   return ROUNDUP (nbytes, align);
 }
 
+void
+igc_check_fwd (void *client)
+{
+  if (is_mps (client))
+    {
+      struct igc_header *h = client_to_base (client);
+      igc_assert (h->obj_type != IGC_OBJ_FWD);
+    }
+}
+
 /* Value is the size in bytes that we need to allocate from MPS
    for a client object of size NBYTES. */
 
@@ -350,6 +360,8 @@ struct igc
   mps_pool_t weak_pool;
   struct igc_root_list *roots;
   struct igc_thread_list *threads;
+  Lisp_Object *cu;
+  ptrdiff_t cu_capacity, ncu;
 };
 
 static struct igc *global_igc;
@@ -1686,6 +1698,7 @@ fix_comp_unit (mps_ss_t ss, struct Lisp_Native_Comp_Unit *u)
   MPS_SCAN_BEGIN (ss)
   {
     IGC_FIX_CALL_FN (ss, struct Lisp_Vector, u, fix_vectorlike);
+    //fprintf (stderr, "+++ %p %zu\n", u->data_relocs, u->n_data_relocs);
     if (u->data_imp_relocs)
       IGC_FIX12_NOBJS (ss, u->data_imp_relocs, u->n_data_imp_relocs);
     if (u->data_relocs)
@@ -1699,6 +1712,24 @@ fix_comp_unit (mps_ss_t ss, struct Lisp_Native_Comp_Unit *u)
   return MPS_RES_OK;
 }
 
+#ifdef HAVE_NATIVE_COMP
+static mps_res_t
+scan_comp_units (mps_ss_t ss, void *start, void *end, void *closure)
+{
+  MPS_SCAN_BEGIN (ss)
+  {
+    for (Lisp_Object *p = start; (void *) p < end; ++p)
+      if (*p)
+	{
+	  struct Lisp_Native_Comp_Unit *u = XNATIVE_COMP_UNIT (*p);
+	  IGC_FIX_CALL (ss, fix_comp_unit (ss, u));
+	}
+  }
+  MPS_SCAN_END (ss);
+  return MPS_RES_OK;
+}
+#endif
+
 #ifdef HAVE_XWIDGETS
 
 static mps_res_t
@@ -2291,6 +2322,36 @@ igc_xnrealloc_ambig (void *pa, ptrdiff_t nitems, ptrdiff_t item_size)
   return pa;
 }
 
+#ifdef HAVE_NATIVE_COMP
+void
+igc_register_cu (Lisp_Object cu)
+{
+  igc_assert (pdumper_object_p (XNATIVE_COMP_UNIT (cu)));
+  struct igc *gc = global_igc;
+  if (gc->ncu == gc->cu_capacity)
+    {
+      IGC_WITH_PARKED (global_igc)
+	{
+	  if (gc->cu)
+	    {
+	      struct igc_root_list *r = root_find (gc->cu);
+	      igc_assert (r != NULL);
+	      destroy_root (&r);
+	    }
+
+	  gc->cu = xpalloc (gc->cu, &gc->cu_capacity, 10, 2 * gc->cu_capacity,
+			    sizeof *gc->cu);
+	  for (int i = gc->ncu; i < gc->cu_capacity; ++i)
+	    gc->cu[i] = Qnil;
+	  root_create (gc, gc->cu, gc->cu + gc->cu_capacity, mps_rank_exact (),
+		       scan_comp_units, false);
+	}
+    }
+
+  gc->cu[gc->ncu++] = cu;
+}
+#endif
+
 void
 igc_create_charset_root (void *table, size_t size)
 {
@@ -3091,6 +3152,29 @@ DEFUN ("igc-roots", Figc_roots, Sigc_roots, 0, 0, 0, doc : /* */)
   return roots;
 }
 
+DEFUN ("igc--alloc-vectors", Figc__alloc_vectors, Sigc__alloc_vectors,
+       1, 1, 0, doc: /* Allocate vectors from MPS according to SPEC.
+SPEC is a list of conses (N . SIZE).  N is the number of vectors and
+SIZE is the SIZE of the vectors to allocate. Allocations happen with
+MPS arena in parked state. */)
+  (Lisp_Object specs)
+{
+  specpdl_ref count = igc_park_arena ();
+  CHECK_LIST (specs);
+  FOR_EACH_TAIL_SAFE (specs)
+    {
+      Lisp_Object s = Fcar (specs);
+      CHECK_FIXNAT (Fcar (s));
+      CHECK_FIXNAT (Fcdr (s));
+      int n = XFIXNAT (Fcar (s));
+      int size = XFIXNAT (Fcdr (s));
+
+      for (int i = 0; i < n; ++i)
+	igc_alloc_vector (size);
+    }
+  return unbind_to (count, Qnil);
+}
+
 static void
 arena_extended (mps_arena_t arena, void *base, size_t size)
 {
@@ -3246,6 +3330,7 @@ syms_of_igc (void)
   defsubr (&Sigc_make_weak_ref);
   defsubr (&Sigc_weak_ref_deref);
   defsubr (&Sigc__collect);
+  defsubr (&Sigc__alloc_vectors);
   DEFSYM (Qambig, "ambig");
   DEFSYM (Qexact, "exact");
   DEFSYM (Qweak_ref_p, "weak-ref-p");

src/igc.h

@@ -95,6 +95,9 @@ void igc_collect (void);
 void igc_root_create_ambig (void *start, void *end);
 void igc_root_create_exact (Lisp_Object *start, Lisp_Object *end);
 void igc_root_create_exact_ptr (void *var_addr);
+#ifdef HAVE_NATIVE_COMP
+void igc_register_cu (Lisp_Object cu);
+#endif
 
 struct Lisp_Weak_Ref;
 Lisp_Object igc_weak_ref_deref (struct Lisp_Weak_Ref *);

src/lisp.h

@@ -43,6 +43,10 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 
 INLINE_HEADER_BEGIN
 
+# ifdef HAVE_MPS
+void igc_check_fwd (void *);
+# endif
+
 /* Define a TYPE constant ID as an externally visible name.  Use like this:
 
       DEFINE_GDB_SYMBOL_BEGIN (TYPE, ID)
@@ -1121,8 +1125,14 @@ SYMBOLP (Lisp_Object x)
 INLINE struct Lisp_Symbol_With_Pos *
 XSYMBOL_WITH_POS (Lisp_Object a)
 {
-    eassert (SYMBOL_WITH_POS_P (a));
-    return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
+  eassert (SYMBOL_WITH_POS_P (a));
+
+  struct Lisp_Symbol_With_Pos *s
+    = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
+  # if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (s);
+# endif
+  return s;
 }
 
 INLINE Lisp_Object
@@ -1152,6 +1162,9 @@ XBARE_SYMBOL (Lisp_Object a)
   eassert (BARE_SYMBOL_P (a));
   intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
   void *p = (char *) lispsym + i;
+#if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (p);
+#endif
   return p;
 }
 
@@ -1505,7 +1518,11 @@ INLINE struct Lisp_Cons *
 XCONS (Lisp_Object a)
 {
   eassert (CONSP (a));
-  return XUNTAG (a, Lisp_Cons, struct Lisp_Cons);
+  struct Lisp_Cons *c = XUNTAG (a, Lisp_Cons, struct Lisp_Cons);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (c);
+# endif
+  return c;
 }
 
 /* Take the car or cdr of something known to be a cons cell.  */
@@ -1629,7 +1646,11 @@ INLINE struct Lisp_String *
 XSTRING (Lisp_Object a)
 {
   eassert (STRINGP (a));
-  return XUNTAG (a, Lisp_String, struct Lisp_String);
+  struct Lisp_String *s = XUNTAG (a, Lisp_String, struct Lisp_String);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (s);
+# endif
+  return s;
 }
 
 /* True if STR is a multibyte string.  */
@@ -1776,7 +1797,11 @@ INLINE struct Lisp_Vector *
 XVECTOR (Lisp_Object a)
 {
   eassert (VECTORLIKEP (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Vector);
+  struct Lisp_Vector *v = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Vector);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (v);
+# endif
+  return v;
 }
 
 INLINE ptrdiff_t
@@ -1925,7 +1950,12 @@ INLINE struct Lisp_Bool_Vector *
 XBOOL_VECTOR (Lisp_Object a)
 {
   eassert (BOOL_VECTOR_P (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bool_Vector);
+  struct Lisp_Bool_Vector *v
+    = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Bool_Vector);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (v);
+# endif
+  return v;
 }
 
 INLINE EMACS_INT
@@ -2113,7 +2143,11 @@ INLINE struct Lisp_Char_Table *
 XCHAR_TABLE (Lisp_Object a)
 {
   eassert (CHAR_TABLE_P (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Char_Table);
+  struct Lisp_Char_Table *t = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Char_Table);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (t);
+# endif
+  return t;
 }
 
 struct Lisp_Sub_Char_Table
@@ -2436,7 +2470,11 @@ INLINE struct Lisp_Obarray *
 XOBARRAY (Lisp_Object a)
 {
   eassert (OBARRAYP (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Obarray);
+  struct Lisp_Obarray *o = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Obarray);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (o);
+# endif
+  return o;
 }
 
 INLINE void
@@ -2692,7 +2730,12 @@ INLINE struct Lisp_Hash_Table *
 XHASH_TABLE (Lisp_Object a)
 {
   eassert (HASH_TABLE_P (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
+  struct Lisp_Hash_Table *h
+    = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (h);
+# endif
+  return h;
 }
 
 INLINE Lisp_Object
@@ -2990,7 +3033,11 @@ INLINE struct Lisp_Marker *
 XMARKER (Lisp_Object a)
 {
   eassert (MARKERP (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Marker);
+  struct Lisp_Marker *m = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Marker);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (m);
+# endif
+  return m;
 }
 
 INLINE bool
@@ -3003,7 +3050,11 @@ INLINE struct Lisp_Overlay *
 XOVERLAY (Lisp_Object a)
 {
   eassert (OVERLAYP (a));
-  return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
+  struct Lisp_Overlay *o = XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (o);
+# endif
+  return o;
 }
 
 INLINE bool
@@ -3207,7 +3258,11 @@ INLINE struct Lisp_Float *
 XFLOAT (Lisp_Object a)
 {
   eassert (FLOATP (a));
-  return XUNTAG (a, Lisp_Float, struct Lisp_Float);
+  struct Lisp_Float *f = XUNTAG (a, Lisp_Float, struct Lisp_Float);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (f);
+# endif
+  return f;
 }
 
 INLINE double
@@ -4969,7 +5024,12 @@ INLINE struct Lisp_Module_Function *
 XMODULE_FUNCTION (Lisp_Object o)
 {
   eassert (MODULE_FUNCTIONP (o));
-  return XUNTAG (o, Lisp_Vectorlike, struct Lisp_Module_Function);
+  struct Lisp_Module_Function *f
+    = XUNTAG (o, Lisp_Vectorlike, struct Lisp_Module_Function);
+# if defined HAVE_MPS && defined ENABLE_CHECKING
+  igc_check_fwd (f);
+# endif
+  return f;
 }
 
 #ifdef HAVE_MODULES