emacs-27 8ecca2f 1/3: Backport: Fix memory leak for global module objects (Bug#42482).

[Philipp Stephani]

branch: emacs-27
commit 8ecca2f09f6bc387412f258c4fc4e3ddf807b2b3
Author: Philipp Stephani <phst@google.com>
Commit: Philipp Stephani <phst@google.com>

    Backport: Fix memory leak for global module objects (Bug#42482).
    
    Instead of storing the global values in a global 'emacs_value_storage'
    object, store them as hash values alongside the reference counts.
    That way the garbage collector takes care of cleaning them up.
    
    * src/emacs-module.c (global_storage): Remove.
    (struct module_global_reference): New pseudovector type.
    (XMODULE_GLOBAL_REFERENCE): New helper function.
    (module_make_global_ref, module_free_global_ref): Use
    'module_global_reference' struct for global reference values.
    (value_to_lisp, module_handle_nonlocal_exit): Adapt to deletion of
    'global_storage'.
    
    (cherry picked from commit 5c5eb9790898e4ab10bcbbdb6871947ed3018569)
---
 src/emacs-module.c | 82 +++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 54 insertions(+), 28 deletions(-)

diff --git a/src/emacs-module.c b/src/emacs-module.c
index 911b82b..4269b0b 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -159,11 +159,11 @@ struct emacs_value_frame
 /* A structure that holds an initial frame (so that the first local
    values require no dynamic allocation) and keeps track of the
    current frame.  */
-static struct emacs_value_storage
+struct emacs_value_storage
 {
   struct emacs_value_frame initial;
   struct emacs_value_frame *current;
-} global_storage;
+};
 
 
 /* Private runtime and environment members.  */
@@ -351,10 +351,35 @@ module_get_environment (struct emacs_runtime *ert)
 }
 
 /* To make global refs (GC-protected global values) keep a hash that
-   maps global Lisp objects to reference counts.  */
+   maps global Lisp objects to 'struct module_global_reference'
+   objects.  We store the 'emacs_value' in the hash table so that it
+   is automatically garbage-collected (Bug#42482).  */
 
 static Lisp_Object Vmodule_refs_hash;
 
+/* Pseudovector type for global references.  The pseudovector tag is
+   PVEC_OTHER since these values are never printed and don't need to
+   be special-cased for garbage collection.  */
+
+struct module_global_reference {
+  /* Pseudovector header, must come first. */
+  union vectorlike_header header;
+
+  /* Holds the emacs_value for the object.  The Lisp_Object stored
+     therein must be the same as the hash key.  */
+  struct emacs_value_tag value;
+
+  /* Reference count, always positive.  */
+  ptrdiff_t refcount;
+};
+
+static struct module_global_reference *
+XMODULE_GLOBAL_REFERENCE (Lisp_Object o)
+{
+  eassert (PSEUDOVECTORP (o, PVEC_OTHER));
+  return XUNTAG (o, Lisp_Vectorlike, struct module_global_reference);
+}
+
 static emacs_value
 module_make_global_ref (emacs_env *env, emacs_value ref)
 {
@@ -363,21 +388,30 @@ module_make_global_ref (emacs_env *env, emacs_value ref)
   Lisp_Object new_obj = value_to_lisp (ref), hashcode;
   ptrdiff_t i = hash_lookup (h, new_obj, &hashcode);
 
+  /* Note: This approach requires the garbage collector to never move
+     objects.  */
+
   if (i >= 0)
     {
       Lisp_Object value = HASH_VALUE (h, i);
-      EMACS_INT refcount = XFIXNAT (value) + 1;
-      if (MOST_POSITIVE_FIXNUM < refcount)
+      struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value);
+      bool overflow = INT_ADD_WRAPV (ref->refcount, 1, &ref->refcount);
+      if (overflow)
        overflow_error ();
-      value = make_fixed_natnum (refcount);
-      set_hash_value_slot (h, i, value);
+      return &ref->value;
     }
   else
     {
-      hash_put (h, new_obj, make_fixed_natnum (1), hashcode);
+      struct module_global_reference *ref
+        = ALLOCATE_PLAIN_PSEUDOVECTOR (struct module_global_reference,
+                                       PVEC_OTHER);
+      ref->value.v = new_obj;
+      ref->refcount = 1;
+      Lisp_Object value;
+      XSETPSEUDOVECTOR (value, ref, PVEC_OTHER);
+      hash_put (h, new_obj, value, hashcode);
+      return &ref->value;
     }
-
-  return allocate_emacs_value (env, &global_storage, new_obj);
 }
 
 static void
@@ -393,23 +427,16 @@ module_free_global_ref (emacs_env *env, emacs_value ref)
 
   if (i >= 0)
     {
-      EMACS_INT refcount = XFIXNAT (HASH_VALUE (h, i)) - 1;
-      if (refcount > 0)
-        set_hash_value_slot (h, i, make_fixed_natnum (refcount));
-      else
-        {
-          eassert (refcount == 0);
-          hash_remove_from_table (h, obj);
-        }
+      Lisp_Object value = HASH_VALUE (h, i);
+      struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value);
+      eassert (0 < ref->refcount);
+      if (--ref->refcount == 0)
+        hash_remove_from_table (h, obj);
     }
-
-  if (module_assertions)
+  else if (module_assertions)
     {
-      ptrdiff_t count = 0;
-      if (value_storage_contains_p (&global_storage, ref, &count))
-        return;
       module_abort ("Global value was not found in list of %"pD"d globals",
-                    count);
+                    h->count);
     }
 }
 
@@ -1190,8 +1217,10 @@ value_to_lisp (emacs_value v)
           ++num_environments;
         }
       /* Also check global values.  */
-      if (value_storage_contains_p (&global_storage, v, &num_values))
+      struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash);
+      if (hash_lookup (h, v->v, NULL) != -1)
         goto ok;
+      INT_ADD_WRAPV (num_values, h->count, &num_values);
       module_abort (("Emacs value not found in %"pD"d values "
                     "of %"pD"d environments"),
                     num_values, num_environments);
@@ -1404,10 +1433,7 @@ module_handle_nonlocal_exit (emacs_env *env, enum 
nonlocal_exit type,
 void
 init_module_assertions (bool enable)
 {
-  /* If enabling module assertions, use a hidden environment for
-     storing the globals.  This environment is never freed.  */
   module_assertions = enable;
-  initialize_storage (&global_storage);
 }
 
 /* Return whether STORAGE contains VALUE.  Used to check module