Re: MPS: weak hash tables

[Pip Cet <pipcet@protonmail.com>]

[-- Attachment #1: Type: text/plain, Size: 3669 bytes --]

On Thursday, July 4th, 2024 at 16:53, Gerd Möllmann <gerd.moellmann@gmail.com> wrote:
> Pip Cet pipcet@protonmail.com writes:
> > I believe we can make key-or-value tables work, and gain a potentially
> > useful debugging aid, by allowing struct igc_header to contain a
> > tagged pointer to an extended "header" structure which resides in
> > external (non-MPS) memory (a "remote reference" in MPS speak, which is
> > usually forbidden in AMC pools but appears to work if it's non-MPS
> > memory); we'd use the extended header instead of the header word to
> > determine object size, hash, and object type. That extended header
> > could then contain a Lisp_Object which would be scanned and kept alive
> > while the object belonging to the header is allocated, not just while
> > it's still reachable.
> 
> 
> Ah, I thought what you wrote in the other mail was related to the
> IA-32 software emulation shit^Wrequirement, sorry.

It's both:

1. change the IGC header to be a uint64_t, because bitfields don't always behave as expected.
2. use the low-order bits to distinguish extended external extra dependency headers from ordinary one-word headers. (This fixes the remaining IA32 bug)
3. keep track of an extra dependency (or a hash table thereof) in the exthdr
4. implement key-or-value weakness
5. implement two-stage finalization and get rid of SPLAT_PVEC
6. give all objects an IGC header (which is now just a struct { uint64_t }) and get rid of igc_has_header
7. use two-stage finalization to shrink weak hash tables which lose their contents

I've done (1)-(4) and (5) for bignums. It all seems to work, though two-stage finalization really is in two stages: you've got to collect several times until the bignums are actually freed.

I'll be honest, this is mostly to see (a) whether MPS can do it (it can!) and (b) for some Ideas I Have which probably won't ever come to fruition. The idea here is that every object (even conses) can keep alive an extra object (which, in turn, can keep alive other objects) while it is allocated (not just while it is reachable). No extra memory is used until the extra object actually becomes non-nil, which doesn't happen, for bignums, until they become unreachable. Once they're deallocated, the extra object possibly becomes unreachable, so it's queued for finalization, which it does by freeing the bignum PVEC's exthdr and the bignum data itself.

> > So if we (puthash a b key-or-value-hash), we'd make `a' keep alive` b'
> > and vice versa, but once they're no longer strongly reachable from
> > other objects, they'd be collected. (I've tried this, it works).
> > 
> > And we could finalize objects appearing in weak hash tables.
> > 
> > This would cause some memory fragmentation (xmalloc isn't moving), but
> > I don't think that's much of an issue: if you're using exotic weak
> > hashes, you're already creating unmovable allocations in
> > weak_hash_pool; if you're debugging, you probably don't care.
> > 
> > However, the functional gains are minimal and so far no one has
> > demanded key-or-value hashes...
> 
> This all gets rather complicated :-/. I'm depressed.

I do realize it's very complicated. As I said, it's about a Big Idea that I had a while ago, but which I couldn't implement back then because mark-and-sweep GC made it impossible. I'm still trying to think of a way to use the external header to find and store retaining paths...

I'm attaching the (ugly bit manipulation) code just in case I've convinced you, but I've got to admit I'm not fully convinced myself. I've got to sleep over it. Feel free, of course, not to read it :-)

Pip

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0003-allow-IGC-to-keep-track-of-an-extra-dependency-in-th.patch --]
[-- Type: text/x-patch; name=0003-allow-IGC-to-keep-track-of-an-extra-dependency-in-th.patch, Size: 3383 bytes --]

From cd229f8346300b435a24bdec86ee2aecf1f61ba0 Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@protonmail.com>
Date: Thu, 4 Jul 2024 18:43:54 +0000
Subject: [PATCH 3/5] allow IGC to keep track of an extra dependency in the
 exthdr

---
 src/igc.c | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)

diff --git a/src/igc.c b/src/igc.c
index 9be30fcb3cf..bc697700bf7 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -542,6 +542,22 @@ igc_header_nwords (const struct igc_header *h)
   return IGC_HEADER_NWORDS (h);
 }
 
+static struct igc_exthdr *
+igc_external_header (struct igc_header *h)
+{
+  if (IGC_HEADER_TAG (h) != IGC_TAG_EXTHDR)
+    {
+      struct igc_exthdr *exthdr = xmalloc (sizeof *exthdr);
+      exthdr->nwords = IGC_HEADER_NWORDS (h);
+      exthdr->hash = IGC_HEADER_HASH (h);
+      exthdr->obj_type = IGC_HEADER_TYPE (h);
+      exthdr->extra_dependency = Qnil;
+      h->v = (intptr_t)exthdr + IGC_TAG_EXTHDR;
+    }
+
+  return IGC_HEADER_EXTHDR (h);
+}
+
 /* Value is the size in bytes of the object described by header H.
    This includes the header itself. */
 
@@ -1667,6 +1683,12 @@ dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
 	  }
       }
 
+    if (IGC_HEADER_TAG (header) == IGC_TAG_EXTHDR)
+      {
+	struct igc_exthdr *exthdr = IGC_HEADER_EXTHDR (header);
+	IGC_FIX12_OBJ (ss, &exthdr->extra_dependency);
+      }
+
     switch (igc_header_type (header))
       {
       case IGC_OBJ_INVALID:
@@ -4251,6 +4273,61 @@ DEFUN ("igc--roots", Figc__roots, Sigc__roots, 0, 0, 0, doc : /* */)
   return roots;
 }
 
+DEFUN ("igc-add-extra-dependency", Figc_add_extra_dependency,
+       Sigc_add_extra_dependency, 2, 2, 0, doc : /* */)
+  (Lisp_Object obj, Lisp_Object dependency)
+{
+  mps_word_t word = XLI (obj);
+  mps_word_t tag = word & IGC_TAG_MASK;
+  mps_addr_t client = NULL;
+  switch (tag)
+    {
+    case Lisp_Type_Unused0:
+      emacs_abort ();
+
+    case Lisp_Int0:
+    case Lisp_Int1:
+      return Qnil;
+
+    case Lisp_Symbol:
+      {
+	ptrdiff_t off = word ^ tag;
+	client = (mps_addr_t) ((char *) lispsym + off);
+      }
+      break;
+
+    case Lisp_String:
+    case Lisp_Vectorlike:
+    case Lisp_Cons:
+    case Lisp_Float:
+      client = (mps_addr_t) (word ^ tag);
+      break;
+    }
+
+  /* Objects in the the dump have igc_headers, too. */
+  if (!has_header (client, tag == Lisp_Vectorlike))
+    {
+      return Qnil;
+    }
+
+  struct igc_header *h = client_to_base (client);
+  struct igc_exthdr *exthdr = igc_external_header (h);
+  if (HASH_TABLE_P (exthdr->extra_dependency))
+    Fputhash (dependency, Qt, exthdr->extra_dependency);
+  else if (HASH_TABLE_P (dependency) || !NILP (exthdr->extra_dependency))
+    {
+      Lisp_Object hash = CALLN (Fmake_hash_table);
+      Fputhash (dependency, Qt, hash);
+      if (!NILP (exthdr->extra_dependency))
+	Fputhash (exthdr->extra_dependency, Qt, hash);
+      exthdr->extra_dependency = hash;
+    }
+  else
+    exthdr->extra_dependency = dependency;
+
+  return Qt;
+}
+
 static void
 make_arena (struct igc *gc)
 {
@@ -4678,6 +4755,7 @@ syms_of_igc (void)
   defsubr (&Sigc_info);
   defsubr (&Sigc__roots);
   defsubr (&Sigc__collect);
+  defsubr (&Sigc_add_extra_dependency);
   DEFSYM (Qambig, "ambig");
   DEFSYM (Qexact, "exact");
   Fprovide (intern_c_string ("mps"), Qnil);
-- 
2.45.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0005-finalize-bignums-later.-This-avoids-the-need-for-spl.patch --]
[-- Type: text/x-patch; name=0005-finalize-bignums-later.-This-avoids-the-need-for-spl.patch, Size: 3013 bytes --]

From 3a0d2b439dd91b569f7e03c52987bedd3034c38b Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@protonmail.com>
Date: Thu, 4 Jul 2024 19:14:57 +0000
Subject: [PATCH 5/5] finalize bignums later. This avoids the need for
 splatting PVECs.

---
 src/igc.c     | 21 ++++++++++++++++++++-
 src/lisp.h    |  1 +
 src/pdumper.c |  2 +-
 3 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/src/igc.c b/src/igc.c
index 7a42470f061..1640a490c6b 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -383,6 +383,7 @@ obj_type_name (enum igc_obj_type type)
   "PVEC_NORMAL_VECTOR",
   "PVEC_FREE",
   "PVEC_BIGNUM",
+  "PVEC_BIGNUM_FINALIZER",
   "PVEC_MARKER",
   "PVEC_OVERLAY",
   "PVEC_FINALIZER",
@@ -2448,6 +2449,9 @@ fix_vector (mps_ss_t ss, struct Lisp_Vector *v)
       case PVEC_BIGNUM:
 	break;
 
+      case PVEC_BIGNUM_FINALIZER:
+	break;
+
       case PVEC_NATIVE_COMP_UNIT:
 	IGC_FIX_CALL_FN (ss, struct Lisp_Native_Comp_Unit, v, fix_comp_unit);
 	break;
@@ -3101,6 +3105,15 @@ finalize_finalizer (struct Lisp_Finalizer *f)
 #define SPLAT_PVEC(v)				 \
   (((v)->header.size &= ~PVEC_TYPE_MASK), XSETPVECTYPE(v, PVEC_FREE))
 
+static Lisp_Object
+make_bignum_finalizer (struct Lisp_Bignum *n)
+{
+  struct Lisp_Bignum *b = ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Bignum,
+						       PVEC_BIGNUM_FINALIZER);
+  memcpy (&b->value, &n->value, sizeof (b->value));
+  return make_lisp_ptr (b, Lisp_Vectorlike);
+}
+
 static void
 finalize_vector (mps_addr_t v)
 {
@@ -3111,6 +3124,12 @@ finalize_vector (mps_addr_t v)
       emacs_abort ();
 
     case PVEC_BIGNUM:
+      Figc_add_extra_dependency (make_lisp_ptr (vec, Lisp_Vectorlike),
+				 make_bignum_finalizer (v),
+				 Qt);
+      break;
+
+    case PVEC_BIGNUM_FINALIZER:
       finalize_bignum (v);
       break;
 
@@ -3201,7 +3220,6 @@ finalize_vector (mps_addr_t v)
       igc_assert (!"finalization not implemented");
       break;
     }
-  SPLAT_PVEC (vec);
 }
 
 static void
@@ -3262,6 +3280,7 @@ maybe_finalize (mps_addr_t client, enum pvec_type tag)
   switch (tag)
     {
     case PVEC_BIGNUM:
+    case PVEC_BIGNUM_FINALIZER:
     case PVEC_FONT:
     case PVEC_THREAD:
     case PVEC_MUTEX:
diff --git a/src/lisp.h b/src/lisp.h
index 34bf483b511..a7e11a43899 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1027,6 +1027,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
   PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj.  */
   PVEC_FREE,
   PVEC_BIGNUM,
+  PVEC_BIGNUM_FINALIZER,
   PVEC_MARKER,
   PVEC_OVERLAY,
   PVEC_FINALIZER,
diff --git a/src/pdumper.c b/src/pdumper.c
index 73719567f80..76c7cf7383d 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -3131,7 +3131,7 @@ dump_vectorlike (struct dump_context *ctx,
                  Lisp_Object lv,
                  dump_off offset)
 {
-#if CHECK_STRUCTS && !defined HASH_pvec_type_914166A3B4
+#if CHECK_STRUCTS && !defined HASH_pvec_type_5F7ABD3A67
 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
 #endif
   const struct Lisp_Vector *v = XVECTOR (lv);
-- 
2.45.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #4: 0004-implement-key-or-value-hash-tables.patch --]
[-- Type: text/x-patch; name=0004-implement-key-or-value-hash-tables.patch, Size: 6764 bytes --]

From 289acb4a40595b7604b1c4e07242510d2537e214 Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@protonmail.com>
Date: Thu, 4 Jul 2024 19:00:18 +0000
Subject: [PATCH 4/5] implement key-or-value hash tables

---
 src/fns.c | 21 ++++++++++++++++-
 src/igc.c | 67 +++++++++++++++++++++++++++++++++++++++++++++++--------
 2 files changed, 78 insertions(+), 10 deletions(-)

diff --git a/src/fns.c b/src/fns.c
index 221e239c639..4faa0cd51d8 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -5508,6 +5508,7 @@ allocate_weak_hash_table (hash_table_weakness_t weak, ssize_t size, ssize_t inde
       ret->strong->index = ret->strong->entries + 3 * size;
       break;
     case Weak_Key_And_Value:
+    case Weak_Key_Or_Value:
       ret->strong->key = ret->weak->entries;
       ret->strong->value = ret->weak->entries + size;
       ret->strong->index = ret->strong->entries + 2 * size;
@@ -5661,6 +5662,7 @@ maybe_resize_weak_hash_table (struct Lisp_Weak_Hash_Table *h)
 	  strong->index = strong->entries + 3 * new_size;
 	  break;
 	case Weak_Key_And_Value:
+	case Weak_Key_Or_Value:
 	  strong->key = weak->entries;
 	  strong->value = weak->entries + new_size;
 	  strong->index = strong->entries + 2 * new_size;
@@ -5742,6 +5744,11 @@ weak_hash_put (struct Lisp_Weak_Hash_Table *h, Lisp_Object key, Lisp_Object valu
   /* Increment count after resizing because resizing may fail.  */
   maybe_resize_weak_hash_table (h);
 
+  if (h->strong->weakness == Weak_Key_Or_Value)
+    {
+      Figc_add_extra_dependency (key, value, make_lisp_weak_hash_table (h));
+      Figc_add_extra_dependency (value, key, make_lisp_weak_hash_table (h));
+    }
   /* Store key/value in the key_and_value vector.  */
   ptrdiff_t i = XFIXNUM (h->strong->next_free);
   //eassert (hash_unused_entry_key_p (HASH_KEY (h, i)));
@@ -6546,7 +6553,19 @@ DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
       Lisp_Object hash = weak_hash_from_key (wh, key);
       ptrdiff_t i = weak_hash_lookup_with_hash (wh, key, hash);
       if (i >= 0)
-	set_weak_hash_value_slot (wh, i, value);
+	{
+	  if (wh->strong->weakness == Weak_Key_Or_Value)
+	    {
+	      Figc_remove_extra_dependency (key, table);
+	      Figc_remove_extra_dependency (value, table);
+	    }
+	  set_weak_hash_value_slot (wh, i, value);
+	  if (wh->strong->weakness == Weak_Key_Or_Value)
+	    {
+	      Figc_add_extra_dependency (key, value, table);
+	      Figc_add_extra_dependency (value, key, table);
+	    }
+	}
       else
 	weak_hash_put (wh, key, value, hash);
       return value;
diff --git a/src/igc.c b/src/igc.c
index bc697700bf7..7a42470f061 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -2019,6 +2019,7 @@ fix_weak_hash_table_strong_part (mps_ss_t ss, struct Lisp_Weak_Hash_Table_Strong
 	    limit = 3 * XFIXNUM (t->table_size);
 	    break;
 	  case Weak_Key_And_Value:
+	  case Weak_Key_Or_Value:
 	    limit = 2 * XFIXNUM (t->table_size);
 	    break;
 	  default:
@@ -2054,6 +2055,7 @@ fix_weak_hash_table_weak_part (mps_ss_t ss, struct Lisp_Weak_Hash_Table_Weak_Par
 	    limit = XFIXNUM (t->table_size);
 	    break;
 	  case Weak_Key_And_Value:
+	  case Weak_Key_Or_Value:
 	    limit = 2 * XFIXNUM (t->table_size);
 	    break;
 	  default:
@@ -2074,7 +2076,8 @@ fix_weak_hash_table_weak_part (mps_ss_t ss, struct Lisp_Weak_Hash_Table_Weak_Par
 		    .weak = w,
 		  };
 		weak_hash_splat_from_table
-		  (&pseudo_h, ((t->weakness == Weak_Key_And_Value) ?
+		  (&pseudo_h, ((t->weakness == Weak_Key_And_Value ||
+				t->weakness == Weak_Key_Or_Value) ?
 			       (i % XFIXNUM (t->table_size)) : i));
 	      }
 	  }
@@ -3990,6 +3993,7 @@ igc_alloc_weak_hash_table_strong_part (hash_table_weakness_t weak,
       total_size = 3 * size + ((ptrdiff_t)1 << index_bits);
       break;
     case Weak_Key_And_Value:
+    case Weak_Key_Or_Value:
       total_size = 2 * size + ((ptrdiff_t)1 << index_bits);
       break;
     default:
@@ -4014,6 +4018,7 @@ igc_alloc_weak_hash_table_weak_part (hash_table_weakness_t weak,
       total_size = size;
       break;
     case Weak_Key_And_Value:
+    case Weak_Key_Or_Value:
       total_size = 2 * size;
       break;
     default:
@@ -4274,8 +4279,8 @@ DEFUN ("igc--roots", Figc__roots, Sigc__roots, 0, 0, 0, doc : /* */)
 }
 
 DEFUN ("igc-add-extra-dependency", Figc_add_extra_dependency,
-       Sigc_add_extra_dependency, 2, 2, 0, doc : /* */)
-  (Lisp_Object obj, Lisp_Object dependency)
+       Sigc_add_extra_dependency, 3, 3, 0, doc : /* */)
+  (Lisp_Object obj, Lisp_Object dependency, Lisp_Object key)
 {
   mps_word_t word = XLI (obj);
   mps_word_t tag = word & IGC_TAG_MASK;
@@ -4313,17 +4318,60 @@ DEFUN ("igc-add-extra-dependency", Figc_add_extra_dependency,
   struct igc_header *h = client_to_base (client);
   struct igc_exthdr *exthdr = igc_external_header (h);
   if (HASH_TABLE_P (exthdr->extra_dependency))
-    Fputhash (dependency, Qt, exthdr->extra_dependency);
-  else if (HASH_TABLE_P (dependency) || !NILP (exthdr->extra_dependency))
+    Fputhash (key, dependency, exthdr->extra_dependency);
+  else
     {
       Lisp_Object hash = CALLN (Fmake_hash_table);
-      Fputhash (dependency, Qt, hash);
-      if (!NILP (exthdr->extra_dependency))
-	Fputhash (exthdr->extra_dependency, Qt, hash);
+      Fputhash (key, dependency, hash);
       exthdr->extra_dependency = hash;
     }
+
+  return Qt;
+}
+
+DEFUN ("igc-remove-extra-dependency", Figc_remove_extra_dependency,
+       Sigc_remove_extra_dependency, 2, 2, 0, doc : /* */)
+  (Lisp_Object obj, Lisp_Object key)
+{
+  mps_word_t word = XLI (obj);
+  mps_word_t tag = word & IGC_TAG_MASK;
+  mps_addr_t client = NULL;
+  switch (tag)
+    {
+    case Lisp_Type_Unused0:
+      emacs_abort ();
+
+    case Lisp_Int0:
+    case Lisp_Int1:
+      return Qnil;
+
+    case Lisp_Symbol:
+      {
+	ptrdiff_t off = word ^ tag;
+	client = (mps_addr_t) ((char *) lispsym + off);
+      }
+      break;
+
+    case Lisp_String:
+    case Lisp_Vectorlike:
+    case Lisp_Cons:
+    case Lisp_Float:
+      client = (mps_addr_t) (word ^ tag);
+      break;
+    }
+
+  /* Objects in the the dump have igc_headers, too. */
+  if (!has_header (client, tag == Lisp_Vectorlike))
+    {
+      return Qnil;
+    }
+
+  struct igc_header *h = client_to_base (client);
+  struct igc_exthdr *exthdr = igc_external_header (h);
+  if (HASH_TABLE_P (exthdr->extra_dependency))
+    Fremhash (key, exthdr->extra_dependency);
   else
-    exthdr->extra_dependency = dependency;
+    return Qnil;
 
   return Qt;
 }
@@ -4756,6 +4804,7 @@ syms_of_igc (void)
   defsubr (&Sigc__roots);
   defsubr (&Sigc__collect);
   defsubr (&Sigc_add_extra_dependency);
+  defsubr (&Sigc_remove_extra_dependency);
   DEFSYM (Qambig, "ambig");
   DEFSYM (Qexact, "exact");
   Fprovide (intern_c_string ("mps"), Qnil);
-- 
2.45.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #5: 0001-Ugly-hack-to-satisfy-MPS-single-access-rules.patch --]
[-- Type: text/x-patch; name=0001-Ugly-hack-to-satisfy-MPS-single-access-rules.patch, Size: 7673 bytes --]

From a37c52f82ec89a8b9bd88c80b7801a7ed2329cbb Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@protonmail.com>
Date: Thu, 4 Jul 2024 18:17:16 +0000
Subject: [PATCH 1/5] Ugly hack to satisfy MPS single-access rules.

---
 src/igc.c | 89 ++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 59 insertions(+), 30 deletions(-)

diff --git a/src/igc.c b/src/igc.c
index 624bb31b2ed..b24ff19a137 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -459,21 +459,45 @@ pvec_type_name (enum pvec_type type)
 
 enum
 {
-  IGC_TYPE_BITS = 6,
-  IGC_HASH_BITS = 26,
-  IGC_SIZE_BITS = 32,
-  IGC_HASH_MASK = (1 << IGC_HASH_BITS) - 1,
+  IGC_HEADER_TAG_BITS = 2,
+  IGC_HEADER_TYPE_BITS = 6,
+  IGC_HEADER_HASH_BITS = 24,
+  IGC_HEADER_NWORDS_BITS = 32,
+  IGC_HEADER_TAG_MASK = (1LL << IGC_HEADER_TAG_BITS) - 1,
+  IGC_HEADER_TYPE_MASK = (1 << IGC_HEADER_TYPE_BITS) - 1,
+  IGC_HEADER_HASH_MASK = (1 << IGC_HEADER_HASH_BITS) - 1,
 };
 
-static_assert (IGC_OBJ_NUM_TYPES - 1 < (1 << IGC_TYPE_BITS));
+static_assert (IGC_OBJ_NUM_TYPES - 1 < (1 << IGC_HEADER_TYPE_BITS));
 
 struct igc_header
 {
-  enum igc_obj_type obj_type : IGC_TYPE_BITS;
-  mps_word_t hash : IGC_HASH_BITS;
-  mps_word_t nwords : IGC_SIZE_BITS;
+  uint64_t v;
 };
 
+#define IGC_HEADER_NWORDS(h) ((h)->v >> (64 - IGC_HEADER_NWORDS_BITS))
+#define IGC_HEADER_HASH(h) (((h)->v >> (IGC_HEADER_TYPE_BITS + IGC_HEADER_TAG_BITS)) & IGC_HEADER_HASH_MASK)
+#define IGC_HEADER_TYPE(h) (((h)->v >> IGC_HEADER_TAG_BITS) & IGC_HEADER_TYPE_MASK)
+#define IGC_HEADER_TAG(h) ((h)->v & IGC_HEADER_TAG_MASK)
+
+enum igc_tag
+{
+  IGC_TAG_NULL = 0, /* entire value must be 0 to avoid MPS issues */
+  IGC_TAG_OBJ = 1, /* IGC object */
+};
+
+static enum igc_obj_type
+igc_header_type (struct igc_header *h)
+{
+  return IGC_HEADER_TYPE (h);
+}
+
+static unsigned
+igc_header_hash (struct igc_header *h)
+{
+  return IGC_HEADER_HASH (h);
+}
+
 struct igc_fwd
 {
   struct igc_header header;
@@ -495,14 +519,20 @@ to_bytes (mps_word_t nwords)
   return nwords * sizeof (mps_word_t);
 }
 
+static size_t
+igc_header_nwords (const struct igc_header *h)
+{
+  return IGC_HEADER_NWORDS (h);
+}
+
 /* Value is the size in bytes of the object described by header H.
    This includes the header itself. */
 
 static mps_word_t
 obj_size (const struct igc_header *h)
 {
-  mps_word_t nbytes = to_bytes (h->nwords);
-  igc_assert (h->obj_type == IGC_OBJ_PAD || nbytes >= sizeof (struct igc_fwd));
+  mps_word_t nbytes = to_bytes (igc_header_nwords (h));
+  igc_assert (IGC_HEADER_TYPE (h) == IGC_OBJ_PAD || nbytes >= sizeof (struct igc_fwd));
   return nbytes;
 }
 
@@ -522,15 +552,14 @@ obj_client_size (const struct igc_header *h)
 set_header (struct igc_header *h, enum igc_obj_type type,
 	    mps_word_t nbytes, mps_word_t hash)
 {
-#if IGC_SIZE_BITS >= 32 && INTPTR_MAX > INT_MAX
+#if IGC_NWORDS_BITS >= 32 && INTPTR_MAX > INT_MAX
   /* On 32-bit architecture the assertion below is redundant and
      causes compiler warnings.  */
-  igc_assert (nbytes < ((size_t) 1 << IGC_SIZE_BITS));
+  igc_assert (nbytes < ((size_t) 1 << IGC_HEADER_NWORDS_BITS));
 #endif
   igc_assert (type == IGC_OBJ_PAD || nbytes >= sizeof (struct igc_fwd));
-  h->obj_type = type;
-  h->nwords = to_words (nbytes);
-  h->hash = hash;
+  h->v = (to_words (nbytes) << (64 - IGC_HEADER_NWORDS_BITS)) +
+    (hash << (IGC_HEADER_TAG_BITS + IGC_HEADER_TYPE_BITS)) + (type << IGC_HEADER_TAG_BITS) + IGC_TAG_OBJ;
 }
 
 /* Given a pointer to the client area of an object, CLIENT, return
@@ -587,7 +616,7 @@ alloc_size (size_t nbytes)
 alloc_hash (void)
 {
   static unsigned count = 0;
-  return count++;
+  return count++ & IGC_HEADER_HASH_MASK;
 }
 
 /* This runs in various places for --enable-checking=igc_check_fwd.  See
@@ -600,7 +629,7 @@ igc_check_fwd (void *client)
   if (has_header (client, true))
     {
       struct igc_header *h = client_to_base (client);
-      igc_assert (h->obj_type != IGC_OBJ_FWD);
+      igc_assert (IGC_HEADER_TYPE (h) != IGC_OBJ_FWD);
       igc_assert (obj_size (h) >= sizeof (struct igc_fwd));
     }
 }
@@ -1358,9 +1387,9 @@ dflt_fwd (mps_addr_t old_base_addr, mps_addr_t new_base_addr)
 {
   struct igc_header *h = old_base_addr;
   igc_assert (obj_size (h) >= sizeof (struct igc_fwd));
-  igc_assert (h->obj_type != IGC_OBJ_PAD);
+  igc_assert (IGC_HEADER_TYPE (h) != IGC_OBJ_PAD);
   struct igc_fwd *f = old_base_addr;
-  f->header.obj_type = IGC_OBJ_FWD;
+  set_header (&f->header, IGC_OBJ_FWD, to_bytes (IGC_HEADER_NWORDS (h)), 0);
   f->new_base_addr = new_base_addr;
 }
 
@@ -1368,7 +1397,7 @@ dflt_fwd (mps_addr_t old_base_addr, mps_addr_t new_base_addr)
 is_dflt_fwd (mps_addr_t base_addr)
 {
   struct igc_fwd *f = base_addr;
-  if (f->header.obj_type == IGC_OBJ_FWD)
+  if (IGC_HEADER_TYPE (&f->header) == IGC_OBJ_FWD)
     return f->new_base_addr;
   return NULL;
 }
@@ -1602,7 +1631,7 @@ dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
     if (closure)
       {
 	struct igc_stats *st = closure;
-	mps_word_t obj_type = header->obj_type;
+	mps_word_t obj_type = igc_header_type (header);
 	igc_assert (obj_type < IGC_OBJ_NUM_TYPES);
 	size_t size = obj_size (header);
 	st->obj[obj_type].nbytes += size;
@@ -1621,7 +1650,7 @@ dflt_scan_obj (mps_ss_t ss, mps_addr_t base_start, mps_addr_t base_limit,
 	  }
       }
 
-    switch (header->obj_type)
+    switch (igc_header_type (header))
       {
       case IGC_OBJ_INVALID:
       case IGC_OBJ_BUILTIN_SYMBOL:
@@ -3138,7 +3167,7 @@ finalize (struct igc *gc, mps_addr_t base)
 {
   mps_addr_t client = base_to_client (base);
   struct igc_header *h = base;
-  switch (h->obj_type)
+  switch (igc_header_type (h))
     {
     case IGC_OBJ_INVALID:
     case IGC_OBJ_PAD:
@@ -3547,12 +3576,12 @@ igc_hash (Lisp_Object key)
       // The following assertion is very expensive.
       // igc_assert (mps_arena_has_addr (global_igc->arena, client));
       struct igc_header *h = client_to_base (client);
-      return h->hash;
+      return igc_header_hash (h);
     }
 
   /* Use a hash that would fit into igc_header::hash so that we
      can keep the hash once a non-MPS object is copied to MPS. */
-  return word & IGC_HASH_MASK;
+  return word & IGC_HEADER_HASH_MASK;
 }
 
 /* Allocate an object of client size SIZE and of type TYPE from
@@ -3827,7 +3856,7 @@ igc_alloc_lisp_obj_vec (size_t n)
 weak_hash_find_dependent (mps_addr_t base)
 {
   struct igc_header *h = base;
-  switch (h->obj_type)
+  switch (igc_header_type (h))
     {
     case IGC_OBJ_WEAK_HASH_TABLE_WEAK_PART:
       {
@@ -4408,7 +4437,7 @@ pure_obj_type_and_hash (size_t *hash_o, enum igc_obj_type type, void *client)
       return type;
 
     case IGC_OBJ_STRING_DATA:
-      *hash_o = (uintptr_t) client & IGC_HASH_MASK;
+      *hash_o = (uintptr_t) client & IGC_HEADER_HASH_MASK;
       return type;
 
     case IGC_OBJ_FLOAT:
@@ -4460,9 +4489,9 @@ igc_dump_finish_obj (void *client, enum igc_obj_type type,
       && !is_in_dump)
     {
       struct igc_header *h = client_to_base (client);
-      if (h->obj_type == IGC_OBJ_MARKER_VECTOR)
+      if (igc_header_type (h) == IGC_OBJ_MARKER_VECTOR)
 	igc_assert ((type == IGC_OBJ_VECTOR
-		     && h->obj_type == IGC_OBJ_MARKER_VECTOR)
+		     && igc_header_type (h) == IGC_OBJ_MARKER_VECTOR)
 		    || h->obj_type == type);
       igc_assert (base + obj_size (h) >= end);
       *out = *h;
@@ -4526,7 +4555,7 @@ check_dump (mps_addr_t start, mps_addr_t end)
     {
       eassert (p < end);
       struct igc_header *h = p;
-      if (h->obj_type != IGC_OBJ_PAD)
+      if (IGC_HEADER_TYPE (h) != IGC_OBJ_PAD)
 	{
 	  mps_addr_t obj = pdumper_next_object (&it);
 	  eassert (p == obj);
-- 
2.45.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #6: 0002-Allow-IGC-headers-to-be-pointers-to-an-external-exte.patch --]
[-- Type: text/x-patch; name=0002-Allow-IGC-headers-to-be-pointers-to-an-external-exte.patch, Size: 1719 bytes --]

From 87062f0c05a46a146d1bd63c631da83ac0a64463 Mon Sep 17 00:00:00 2001
From: Pip Cet <pipcet@protonmail.com>
Date: Thu, 4 Jul 2024 18:17:43 +0000
Subject: [PATCH 2/5] Allow IGC headers to be pointers to an external extended
 real header

---
 src/igc.c | 17 +++++++++++++++++
 1 file changed, 17 insertions(+)

diff --git a/src/igc.c b/src/igc.c
index b24ff19a137..9be30fcb3cf 100644
--- a/src/igc.c
+++ b/src/igc.c
@@ -480,21 +480,36 @@ #define IGC_HEADER_HASH(h) (((h)->v >> (IGC_HEADER_TYPE_BITS + IGC_HEADER_TAG_BI
 #define IGC_HEADER_TYPE(h) (((h)->v >> IGC_HEADER_TAG_BITS) & IGC_HEADER_TYPE_MASK)
 #define IGC_HEADER_TAG(h) ((h)->v & IGC_HEADER_TAG_MASK)
 
+struct igc_exthdr
+{
+  EMACS_UINT nwords;
+  EMACS_UINT hash;
+  enum igc_obj_type obj_type;
+  Lisp_Object extra_dependency;
+};
+
+#define IGC_HEADER_EXTHDR(h) ((struct igc_exthdr *)(intptr_t)((h)->v & ~IGC_HEADER_TAG_MASK))
+
 enum igc_tag
 {
   IGC_TAG_NULL = 0, /* entire value must be 0 to avoid MPS issues */
   IGC_TAG_OBJ = 1, /* IGC object */
+  IGC_TAG_EXTHDR = 2, /* pointer to aligned external header */
 };
 
 static enum igc_obj_type
 igc_header_type (struct igc_header *h)
 {
+  if (IGC_HEADER_TAG (h) == IGC_TAG_EXTHDR)
+    return IGC_HEADER_EXTHDR (h)->obj_type;
   return IGC_HEADER_TYPE (h);
 }
 
 static unsigned
 igc_header_hash (struct igc_header *h)
 {
+  if (IGC_HEADER_TAG (h) == IGC_TAG_EXTHDR)
+    return IGC_HEADER_EXTHDR (h)->hash;
   return IGC_HEADER_HASH (h);
 }
 
@@ -522,6 +537,8 @@ to_bytes (mps_word_t nwords)
 static size_t
 igc_header_nwords (const struct igc_header *h)
 {
+  if (IGC_HEADER_TAG (h) == IGC_TAG_EXTHDR)
+    return IGC_HEADER_EXTHDR (h)->nwords;
   return IGC_HEADER_NWORDS (h);
 }
 
-- 
2.45.2