Fix finalizer resuscitation causing excessive GC

* libguile/finalizers.c (async_gc_finalizer):
  (scm_i_register_async_gc_callback): Replace "weak gc callback"
  mechanism with "async gc callback" mechanism.  Very similar but the
  new API is designed to be called a bounded number of times, to avoid
  running afoul of libgc heuristics.
* libguile/weak-list.h: New internal header.
* libguile/Makefile.am (noinst_HEADERS): Add weak-list.h.
* libguile/weak-set.c (vacuum_all_weak_sets):
  (scm_c_make_weak_set, scm_init_weak_set):
* libguile/weak-table.c (vacuum_all_weak_tables):
  (scm_c_make_weak_table, scm_init_weak_table): Arrange to vacuum all
  weak sets from a single async GC callback, and likewise for weak
  tables.

Thanks to Ludovic Courtès for tracking this bug down!

libguile/Makefile.am

@@ -507,7 +507,9 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c		\
                  atomics-internal.h				\
                  cache-internal.h				\
                  posix-w32.h					\
-		 private-options.h ports-internal.h
+		 private-options.h 				\
+		 ports-internal.h 				\
+		 weak-list.h
 
 # vm instructions
 noinst_HEADERS += vm-engine.c

libguile/finalizers.c

@@ -296,59 +296,46 @@ scm_i_finalizer_pre_fork (void)
 
 
 
-static void*
-weak_pointer_ref (void *weak_pointer) 
-{
-  return *(void **) weak_pointer;
-}
-
 static void
-weak_gc_finalizer (void *ptr, void *data)
+async_gc_finalizer (void *ptr, void *data)
 {
-  void **weak = ptr;
-  void *val;
-  void (*callback) (SCM) = weak[1];
+  void **obj = ptr;
+  void (*callback) (void) = obj[0];
 
-  val = GC_call_with_alloc_lock (weak_pointer_ref, &weak[0]);
+  callback ();
 
-  if (!val)
-    return;
-
-  callback (SCM_PACK_POINTER (val));
-
-  scm_i_set_finalizer (ptr, weak_gc_finalizer, data);
+  scm_i_set_finalizer (ptr, async_gc_finalizer, data);
 }
 
-/* CALLBACK will be called on OBJ, as long as OBJ is accessible.  It
-   will be called from a finalizer, which may be from an async or from
+/* Arrange to call CALLBACK asynchronously after each GC.  The callback
+   will be invoked from a finalizer, which may be from an async or from
    another thread.
 
-   As an implementation detail, the way this works is that we allocate
-   a fresh pointer-less object holding two words.  We know that this
+   As an implementation detail, the way this works is that we allocate a
+   fresh object and put the callback in the object.  We know that this
    object should get collected the next time GC is run, so we attach a
-   finalizer to it so that we get a callback after GC happens.
+   finalizer to it to trigger the callback.
 
-   The first word of the object holds a weak reference to OBJ, and the
-   second holds the callback pointer.  When the callback is called, we
-   check if the weak reference on OBJ still holds.  If it doesn't hold,
-   then OBJ is no longer accessible, and we're done.  Otherwise we call
-   the callback and re-register a finalizer for our two-word GC object,
-   effectively resuscitating the object so that we will get a callback
-   on the next GC.
+   Once the callback runs, we re-attach a finalizer to that fresh object
+   to prepare for the next GC, and the process repeats indefinitely.
 
    We could use the scm_after_gc_hook, but using a finalizer has the
    advantage of potentially running in another thread, decreasing pause
-   time.  */
+   time.
+
+   Note that libgc currently has a heuristic that adding 500 finalizable
+   objects will cause GC to collect rather than expand the heap,
+   drastically reducing performance on workloads that actually need to
+   expand the heap.  Therefore scm_i_register_async_gc_callback is
+   inappropriate for using on unbounded numbers of callbacks.  */
 void
-scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+scm_i_register_async_gc_callback (void (*callback) (void))
 {
-  void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
+  void **obj = GC_MALLOC_ATOMIC (sizeof (void*));
 
-  weak[0] = SCM_UNPACK_POINTER (obj);
-  weak[1] = (void*)callback;
-  GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+  obj[0] = (void*)callback;
 
-  scm_i_set_finalizer (weak, weak_gc_finalizer, NULL);
+  scm_i_set_finalizer (obj, async_gc_finalizer, NULL);
 }
 
 

libguile/finalizers.h

@@ -36,10 +36,10 @@ SCM_INTERNAL void scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc,
 
 SCM_INTERNAL void scm_i_finalizer_pre_fork (void);
 
-/* CALLBACK will be called on OBJ after each garbage collection, as long
-   as OBJ is accessible.  It will be called from a finalizer, which may
-   be from an async or from another thread. */
-SCM_INTERNAL void scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM));
+/* CALLBACK will be called after each garbage collection.  It will be
+   called from a finalizer, which may be from an async or from another
+   thread. */
+SCM_INTERNAL void scm_i_register_async_gc_callback (void (*callback) (void));
 
 SCM_API int scm_set_automatic_finalization_enabled (int enabled_p);
 SCM_API int scm_run_finalizers (void);

libguile/weak-list.h

@@ -0,0 +1,73 @@
+/* classes: h_files */
+
+#ifndef SCM_WEAK_LIST_H
+#define SCM_WEAK_LIST_H
+
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+#include "libguile/weak-vector.h"
+
+
+
+static inline SCM
+scm_i_weak_cons (SCM car, SCM cdr)
+{
+  return scm_cons (scm_c_make_weak_vector (1, car), cdr);
+}
+
+static inline SCM
+scm_i_weak_car (SCM pair)
+{
+  return scm_c_weak_vector_ref (scm_car (pair), 0);
+}
+
+static inline void
+scm_i_visit_weak_list (SCM *list_loc, void (*visit) (SCM))
+{
+  SCM in = *list_loc, out = SCM_EOL;
+
+  while (scm_is_pair (in))
+    {
+      SCM car = scm_i_weak_car (in);
+      SCM cdr = scm_cdr (in);
+
+      if (!scm_is_eq (car, SCM_BOOL_F))
+        {
+          scm_set_cdr_x (in, out);
+          out = in;
+          visit (car);
+        }
+
+      in = cdr;
+    }
+
+  *list_loc = out;
+}
+
+
+#endif  /* SCM_WEAK_LIST_H */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/weak-set.c

@@ -31,6 +31,7 @@
 #include "libguile/bdw-gc.h"
 
 #include "libguile/validate.h"
+#include "libguile/weak-list.h"
 #include "libguile/weak-set.h"
 
 
@@ -698,6 +699,17 @@ do_vacuum_weak_set (SCM set)
   scm_i_pthread_mutex_unlock (&s->lock);
 }
 
+static scm_i_pthread_mutex_t all_weak_sets_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM all_weak_sets = SCM_EOL;
+
+static void
+vacuum_all_weak_sets (void)
+{
+  scm_i_pthread_mutex_lock (&all_weak_sets_lock);
+  scm_i_visit_weak_list (&all_weak_sets, do_vacuum_weak_set);
+  scm_i_pthread_mutex_unlock (&all_weak_sets_lock);
+}
+
 SCM
 scm_c_make_weak_set (unsigned long k)
 {
@@ -705,7 +717,9 @@ scm_c_make_weak_set (unsigned long k)
 
   ret = make_weak_set (k);
 
-  scm_i_register_weak_gc_callback (ret, do_vacuum_weak_set);
+  scm_i_pthread_mutex_lock (&all_weak_sets_lock);
+  all_weak_sets = scm_i_weak_cons (ret, all_weak_sets);
+  scm_i_pthread_mutex_unlock (&all_weak_sets_lock);
 
   return ret;
 }
@@ -883,6 +897,8 @@ void
 scm_init_weak_set ()
 {
 #include "libguile/weak-set.x"
+
+  scm_i_register_async_gc_callback (vacuum_all_weak_sets);
 }
 
 /*

libguile/weak-table.c

@@ -33,6 +33,7 @@
 #include "libguile/ports.h"
 
 #include "libguile/validate.h"
+#include "libguile/weak-list.h"
 #include "libguile/weak-table.h"
 
 
@@ -832,6 +833,17 @@ do_vacuum_weak_table (SCM table)
   return;
 }
 
+static scm_i_pthread_mutex_t all_weak_tables_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static SCM all_weak_tables = SCM_EOL;
+
+static void
+vacuum_all_weak_tables (void)
+{
+  scm_i_pthread_mutex_lock (&all_weak_tables_lock);
+  scm_i_visit_weak_list (&all_weak_tables, do_vacuum_weak_table);
+  scm_i_pthread_mutex_unlock (&all_weak_tables_lock);
+}
+
 SCM
 scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 {
@@ -839,7 +851,9 @@ scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
 
   ret = make_weak_table (k, kind);
 
-  scm_i_register_weak_gc_callback (ret, do_vacuum_weak_table);
+  scm_i_pthread_mutex_lock (&all_weak_tables_lock);
+  all_weak_tables = scm_i_weak_cons (ret, all_weak_tables);
+  scm_i_pthread_mutex_unlock (&all_weak_tables_lock);
 
   return ret;
 }
@@ -1155,6 +1169,8 @@ void
 scm_init_weak_table ()
 {
 #include "libguile/weak-table.x"
+
+  scm_i_register_async_gc_callback (vacuum_all_weak_tables);
 }
 
 /*