* gc.c (scm_init_storage): init `scm_gc_registered_roots'.

(scm_igc): mark from them, too (precisely, not conservatively!).

* root.h (scm_gc_registered_roots): new object in
scm_sys_protects.

* hooks.c (scm_create_hook): call `scm_gc_protect_object' instead
`scm_protect_object'.  shouldn't call it at all, though, it seems.

* gc.c (scm_[un]protect_object): deprecated.
(scm_gc_[un]protect_object): new names for scm_[un]protect_object.
(scm_gc_[un]register_root[s]): new.

* gc.h: add prototypes for scm_gc_[un]protect_object,
scm_gc_[un]register_root[s].

libguile/ChangeLog

@@ -1,3 +1,21 @@
+2001-05-27  Michael Livshin  <mlivshin@bigfoot.com>
+
+	* gc.c (scm_init_storage): init `scm_gc_registered_roots'.
+	(scm_igc): mark from them, too (precisely, not conservatively!).
+
+	* root.h (scm_gc_registered_roots): new object in
+	scm_sys_protects.
+
+	* hooks.c (scm_create_hook): call `scm_gc_protect_object' instead
+	`scm_protect_object'.  shouldn't call it at all, though, it seems.
+
+	* gc.c (scm_[un]protect_object): deprecated.
+	(scm_gc_[un]protect_object): new names for scm_[un]protect_object.
+	(scm_gc_[un]register_root[s]): new.
+
+	* gc.h: add prototypes for scm_gc_[un]protect_object,
+	scm_gc_[un]register_root[s].
+
 2001-05-26  Michael Livshin  <mlivshin@bigfoot.com>
 
 	revert the controversial part of the 2001-05-24 changes.

libguile/gc.c

@@ -1063,7 +1063,7 @@ scm_igc (const char *what)
 			  / sizeof (SCM_STACKITEM)));
 
   {
-    size_t stack_len = scm_stack_size (scm_stack_base);
+    unsigned long stack_len = scm_stack_size (scm_stack_base);
 #ifdef SCM_STACK_GROWS_UP
     scm_mark_locations (scm_stack_base, stack_len);
 #else
@@ -1082,6 +1082,18 @@ scm_igc (const char *what)
   while (j--)
     scm_gc_mark (scm_sys_protects[j]);
 
+  /* mark the registered roots */
+  {
+    long i;
+    for (i = 0; i < SCM_VECTOR_LENGTH (scm_gc_registered_roots); ++i) {
+      SCM l = SCM_VELTS (scm_gc_registered_roots)[i];
+      for (; ! SCM_NULLP (l); l = SCM_CDR (l)) {
+        SCM *p = (SCM *) (scm_num2long (SCM_CAAR (l), 0, NULL));
+        scm_gc_mark (*p);
+      }
+    }
+  }
+
   /* FIXME: we should have a means to register C functions to be run
    * in different phases of GC
    */
@@ -2464,6 +2476,22 @@ scm_remember (SCM *ptr)
                                    "Use the `scm_remember_upto_here*' family of functions instead.");
 }
 
+SCM
+scm_protect_object (SCM obj)
+{
+  scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
+                                   "Use `scm_gc_protect_object' instead.");
+  return scm_gc_protect_object (obj);
+}
+
+SCM
+scm_unprotect_object (SCM obj)
+{
+  scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
+                                   "Use `scm_gc_unprotect_object' instead.");
+  return scm_gc_unprotect_object (obj);
+}
+
 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 
 /*
@@ -2499,7 +2527,7 @@ scm_permanent_object (SCM obj)
 
 /* Protect OBJ from the garbage collector.  OBJ will not be freed, even if all
    other references are dropped, until the object is unprotected by calling
-   scm_unprotect_object (OBJ).  Calls to scm_protect/unprotect_object nest,
+   scm_gc_unprotect_object (OBJ).  Calls to scm_gc_protect/unprotect_object nest,
    i. e. it is possible to protect the same object several times, but it is
    necessary to unprotect the object the same number of times to actually get
    the object unprotected.  It is an error to unprotect an object more often
@@ -2508,11 +2536,11 @@ scm_permanent_object (SCM obj)
 */
 
 /* Implementation note:  For every object X, there is a counter which
-   scm_protect_object(X) increments and scm_unprotect_object(X) decrements.
+   scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
 */
 
 SCM
-scm_protect_object (SCM obj)
+scm_gc_protect_object (SCM obj)
 {
   SCM handle;
 
@@ -2533,7 +2561,7 @@ scm_protect_object (SCM obj)
 
    See scm_protect_object for more information.  */
 SCM
-scm_unprotect_object (SCM obj)
+scm_gc_unprotect_object (SCM obj)
 {
   SCM handle;
 
@@ -2561,6 +2589,65 @@ scm_unprotect_object (SCM obj)
   return obj;
 }
 
+void
+scm_gc_register_root (SCM *p)
+{
+  SCM handle;
+  SCM key = scm_long2num ((long) p);
+  
+  /* This critical section barrier will be replaced by a mutex. */
+  SCM_REDEFER_INTS;
+
+  handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key, SCM_MAKINUM (0));
+  SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), SCM_MAKINUM (1)));
+
+  SCM_REALLOW_INTS;
+}
+
+void
+scm_gc_unregister_root (SCM *p)
+{
+  SCM handle;
+  SCM key = scm_long2num ((long) p);
+
+  /* This critical section barrier will be replaced by a mutex. */
+  SCM_REDEFER_INTS;
+
+  handle = scm_hashv_get_handle (scm_gc_registered_roots, key);
+
+  if (SCM_FALSEP (handle))
+    {
+      fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n");
+      abort ();
+    }
+  else
+    {
+      SCM count = scm_difference (SCM_CDR (handle), SCM_MAKINUM (1));
+      if (SCM_EQ_P (count, SCM_MAKINUM (0)))
+	scm_hashv_remove_x (scm_gc_registered_roots, key);
+      else
+	SCM_SETCDR (handle, count);
+    }
+
+  SCM_REALLOW_INTS;
+}
+
+void
+scm_gc_register_roots (SCM *b, unsigned long n)
+{
+  SCM *p = b;
+  for (; p < b + n; ++p)
+    scm_gc_register_root (p);
+}
+
+void
+scm_gc_unregister_roots (SCM *b, unsigned long n)
+{
+  SCM *p = b;
+  for (; p < b + n; ++p)
+    scm_gc_unregister_root (p);
+}
+
 int terminating;
 
 /* called on process termination.  */
@@ -2712,6 +2799,7 @@ scm_init_storage ()
   scm_stand_in_procs = SCM_EOL;
   scm_permobjs = SCM_EOL;
   scm_protects = scm_c_make_hash_table (31);
+  scm_gc_registered_roots = scm_c_make_hash_table (31);
 
   return 0;
 }

libguile/gc.h

@@ -381,8 +381,12 @@ extern void scm_remember_upto_here (SCM obj1, ...);
 extern SCM scm_return_first (SCM elt, ...);
 extern int scm_return_first_int (int x, ...);
 extern SCM scm_permanent_object (SCM obj);
-extern SCM scm_protect_object (SCM obj);
+extern SCM scm_gc_protect_object (SCM obj);
-extern SCM scm_unprotect_object (SCM obj);
+extern SCM scm_gc_unprotect_object (SCM obj);
+extern void scm_gc_register_root (SCM *p);
+extern void scm_gc_unregister_root (SCM *p);
+extern void scm_gc_register_roots (SCM *b, unsigned long n);
+extern void scm_gc_unregister_roots (SCM *b, unsigned long n);
 extern int scm_init_storage (void);
 extern void *scm_get_stack_base (void);
 extern void scm_init_gc (void);
@@ -391,6 +395,9 @@ extern void scm_init_gc (void);
 
 #if (SCM_DEBUG_DEPRECATED == 0)
 
+extern SCM scm_protect_object (SCM obj);
+extern SCM scm_unprotect_object (SCM obj);
+
 #define SCM_SETAND_CAR(x, y) \
   (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
 #define SCM_SETOR_CAR(x, y)\

libguile/hooks.c

@@ -199,7 +199,7 @@ scm_create_hook (const char *name, int n_args)
 {
   SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook");
   scm_c_define (name, hook);
-  scm_protect_object (hook);
+  scm_gc_protect_object (hook); /* cmm:FIXME:: qua? */
   return hook;
 }
 

libguile/root.h

@@ -68,11 +68,12 @@
 #define scm_asyncs scm_sys_protects[9]
 #define scm_protects scm_sys_protects[10]
 #define scm_properties_whash scm_sys_protects[11]
+#define scm_gc_registered_roots scm_sys_protects[12]
 #ifdef DEBUG_EXTENSIONS
-#define scm_source_whash scm_sys_protects[12]
+#define scm_source_whash scm_sys_protects[13]
-#define SCM_NUM_PROTECTS 13
+#define SCM_NUM_PROTECTS 14
 #else
-#define SCM_NUM_PROTECTS 12
+#define SCM_NUM_PROTECTS 13
 #endif
 
 extern SCM scm_sys_protects[];