Generalized BGC's finalizer mechanism. Use it in `guardians.c'.

* libguile/gc.c (finalizer_trampoline): New.
  (scm_gc_register_finalizer): New.

* libguile/gc.h (scm_gc_register_finalizer): New declaration.

* libguile/guardians.c (finalize_guarded): Updated to the new prototype.
  (scm_i_guard): Use `scm_gc_register_finalizer ()' instead of
  `GC_REGISTER_FINALIZER_NO_ORDER ()'.

git-archimport-id: lcourtes@laas.fr--2005-libre/guile-core--boehm-gc--1.9--patch-23

libguile/gc.c

@@ -678,8 +678,96 @@ scm_gc_unregister_roots (SCM *b, unsigned long n)
 int scm_i_terminating;
 
 
+/* Finalizers.  */
+
+static void
+finalizer_trampoline (GC_PTR ptr, GC_PTR data)
+{
+  register SCM obj, finalizers;
+
+  obj = PTR2SCM (ptr);
+  for (finalizers = PTR2SCM (data);
+       scm_is_pair (finalizers);
+       finalizers = SCM_CDR (finalizers))
+    {
+      SCM f = SCM_CAR (finalizers);
+
+      scm_call_2 (SCM_CAR (f), obj, SCM_CDR (f));
+    }
+}
 
 
+/* Register FINALIZER as a finalization procedure for OBJ.  FINALIZER will be
+   invoked when storage for OBJ is to be reclaimed and will be passed OBJ and
+   DATA.  If ORDERED is non-zero, finalization will be "ordered" (see the
+   Boehm-GC doc for details).  The function returns the data previously
+   registered for OBJ and FINALIZER, or `#f' if FINALIZER had not been
+   registered for OBJ before.
+
+   Note that finalizers in general are known to be problematic.  As such,
+   this function should only be used internally, and only to implement
+   functionalities that could not be implemented otherwise (e.g., guardians,
+   SMOB's free procedures).  */
+SCM
+scm_gc_register_finalizer (SCM obj, SCM (*finalizer) (SCM, SCM),
+			   SCM data, int ordered)
+{
+  SCM prev_data = SCM_BOOL_F;
+  SCM finalization_data, finalization_subr;
+  GC_finalization_proc old_finalizer;
+  GC_PTR old_finalization_data;
+
+  finalization_subr = scm_c_make_gsubr ("%%finalizer", 2, 0, 0,
+					finalizer);
+  finalization_data = scm_cons (scm_cons (finalization_subr, data),
+				SCM_EOL);
+  if (ordered)
+    GC_REGISTER_FINALIZER (SCM2PTR (obj), finalizer_trampoline,
+			   SCM2PTR (finalization_data),
+			   &old_finalizer, &old_finalization_data);
+  else
+    GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalizer_trampoline,
+				    SCM2PTR (finalization_data),
+				    &old_finalizer, &old_finalization_data);
+
+  if ((old_finalizer != NULL) && (old_finalizer != finalizer_trampoline))
+    /* Inconsistent use of the mechanism.  */
+    abort ();
+
+  if (old_finalization_data != NULL)
+    {
+      SCM f, prev, old_finalizer_list = PTR2SCM (old_finalization_data);
+
+      if (!scm_is_pair (old_finalizer_list))
+	abort ();
+
+      /* Look for FINALIZER among the previously-installed finalizers.  */
+      for (f = old_finalizer_list, prev = SCM_BOOL_F;
+	   scm_is_pair (f);
+	   prev = f, f = SCM_CDR (f))
+	{
+	  if (SCM_SUBRF (SCM_CAR (f)) == finalizer)
+	    break;
+	}
+
+      if (scm_is_pair (f))
+	{
+	  prev_data = SCM_CDAR (f);
+	  if (prev != SCM_BOOL_F)
+	    SCM_SETCDR (prev, SCM_CDR (f));
+	  else
+	    old_finalizer_list = SCM_CDR (old_finalizer_list);
+	}
+
+      /* Concatenate the new finalizer list with the old one.  */
+      SCM_SETCDR (finalization_data, old_finalizer_list);
+    }
+
+  return prev_data;
+}
+
+
+
 /*
   MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
  */

libguile/gc.h

@@ -235,6 +235,8 @@ SCM_API void *scm_gc_realloc (void *mem, size_t old_size,
 SCM_API void scm_gc_free (void *mem, size_t size, const char *what);
 SCM_API char *scm_gc_strdup (const char *str, const char *what);
 SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what);
+SCM_API SCM scm_gc_register_finalizer (SCM obj, SCM (*finalizer) (SCM, SCM),
+				       SCM data, int ordered);
 
 SCM_API void scm_remember_upto_here_1 (SCM obj);
 SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);

libguile/guardians.c

@@ -96,14 +96,14 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
 
 /* Handle finalization of OBJ which is guarded by the guardians listed in
    GUARDIAN_LIST.  */
-static void
+static SCM
-finalize_guarded (GC_PTR obj, GC_PTR guardian_list)
+finalize_guarded (SCM obj, SCM guardian_list)
 {
   SCM cell_pool;
 
 #if 0
   printf ("finalizing guarded %p (%u guardians)\n",
-	  obj, scm_to_uint (scm_length (guardian_list)));
+	  SCM2PTR (obj), scm_to_uint (scm_length (guardian_list)));
   scm_write (guardian_list, scm_current_output_port ());
 #endif
 
@@ -130,7 +130,7 @@ finalize_guarded (GC_PTR obj, GC_PTR guardian_list)
       cell_pool = SCM_CDR (cell_pool);
 
       /* Compute and update G's zombie list.  */
-      SCM_SETCAR (zombies, SCM_PACK (obj));
+      SCM_SETCAR (zombies, obj);
       SCM_SETCDR (zombies, g->zombies);
       g->zombies = zombies;
 
@@ -139,8 +139,10 @@ finalize_guarded (GC_PTR obj, GC_PTR guardian_list)
     }
 
 #if 0
-  printf ("end of finalize (%p)\n", obj);
+  printf ("end of finalize (%p)\n", SCM2PTR (obj));
 #endif
+
+  return SCM_UNSPECIFIED;
 }
 
 /* Add OBJ as a guarded object of GUARDIAN.  */
@@ -153,28 +155,18 @@ scm_i_guard (SCM guardian, SCM obj)
     {
       /* Register a finalizer and pass a list of guardians interested in OBJ
 	 as the ``client data'' argument.  */
-      GC_finalization_proc prev_finalizer;
+      SCM guardians_for_obj, prev_guardians_for_obj;
-      GC_PTR prev_data;
-      SCM guardians_for_obj;
 
       g->live++;
       guardians_for_obj = scm_cons (guardian, SCM_EOL);
 
-      GC_REGISTER_FINALIZER_NO_ORDER ((GC_PTR)obj, finalize_guarded,
+      prev_guardians_for_obj =
-				      (GC_PTR)guardians_for_obj,
+	scm_gc_register_finalizer (obj, finalize_guarded,
-				      &prev_finalizer, &prev_data);
+				   guardians_for_obj, 0);
 
-      if ((prev_finalizer == finalize_guarded) && (prev_data != NULL))
+      if (scm_is_pair (prev_guardians_for_obj))
-	{
+	/* Concatenate the previous list of guardians for OBJ.  */
-	  /* OBJ is already guarded by another guardian: add GUARDIAN to its
+	SCM_SETCDR (guardians_for_obj, prev_guardians_for_obj);
-	     list of guardians.  */
-	  SCM prev_guardian_list = SCM_PACK (prev_data);
-
-	  if (!scm_is_pair (prev_guardian_list))
-	    abort ();
-
-	  SCM_SETCDR (guardians_for_obj, prev_guardian_list);
-	}
     }
 }