scm_gc_object_address pins its referent

* libguile/gc.h:
* libguile/gc.c (scm_gc_pin_object): New function.
(scm_gc_object_address): New function, to be used instead of SCM_UNPACK
when an object's address is exposed, for example via hashq.
* libguile/atomic.c:
* libguile/cache-internal.h:
* libguile/continuations.c:
* libguile/dynstack.c:
* libguile/dynstack.h:
* libguile/ephemerons.c:
* libguile/exceptions.c:
* libguile/finalizers.c:
* libguile/fluids-internal.h:
* libguile/fluids.c:
* libguile/foreign.c:
* libguile/frames.c:
* libguile/hash.c:
* libguile/hashtab.c:
* libguile/intrinsics.c:
* libguile/memoize.c:
* libguile/print.c:
* libguile/programs.c:
* libguile/smob.c:
* libguile/struct.c:
* libguile/struct.h:
* libguile/variable.c:
* libguile/vm.c: Use the new functions everywhere that is needed.
Because they take a thread, sometimes we have to do some extra plumbing.

libguile/atomic.c

@@ -115,7 +115,7 @@ void
 scm_i_atomic_box_print (SCM exp, SCM port, scm_print_state *pstate)
 {
   scm_puts ("#<atomic-box ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_puts (" value: ", port);
   scm_iprin1 (scm_atomic_box_ref (exp), port, pstate);
   scm_putc ('>', port);

libguile/cache-internal.h

@@ -79,7 +79,7 @@ scm_cache_lookup (struct scm_cache *cache, SCM k)
 }
 
 static inline void
-scm_cache_insert (struct scm_cache *cache, SCM k, SCM v,
+scm_cache_insert (struct scm_thread *thr, struct scm_cache *cache, SCM k, SCM v,
                   struct scm_cache_entry *evicted)
 {
   struct scm_cache_entry *entry;
@@ -95,7 +95,9 @@ scm_cache_insert (struct scm_cache *cache, SCM k, SCM v,
   memmove (cache->entries,
            cache->entries + 1,
            (entry - cache->entries) * sizeof (*entry));
-  entry->key = SCM_UNPACK (k);
+  // FIXME: Perhaps we should just reorder after a GC in which a fluid
+  // is moved.  For now, pin the key.
+  entry->key = scm_gc_object_address (thr, k);
   entry->value = SCM_UNPACK (v);
 }
 

libguile/continuations.c

@@ -109,7 +109,7 @@ scm_i_print_continuation (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
   scm_puts ("#<continuation ", port);
   scm_intprint (continuation->num_stack_items, 10, port);
   scm_puts (" @ ", port);
-  scm_uintprint (SCM_UNPACK (obj), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, obj), 16, port);
   scm_putc ('>', port);
   return 1;
 }
@@ -128,7 +128,7 @@ pin_conservative_roots (scm_thread *thread, void *base, size_t size)
       struct gc_ref ref = gc_resolve_conservative_ref (heap, maybe_ref, 0);
       if (!gc_ref_is_null (ref))
         gc_pin_object (mut, ref);
-    }
+     }
 }
 
 /* James Clark came up with this neat one instruction fix for

libguile/dynstack.c

@@ -276,7 +276,7 @@ scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
    binding.  */
 void
 scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
-                         scm_t_dynamic_state *dynamic_state)
+                         scm_thread *thread)
 {
   scm_t_bits *words;
   SCM value_box;
@@ -292,7 +292,7 @@ scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
   words[1] = SCM_UNPACK (value_box);
 
   /* Go ahead and swap them.  */
-  scm_swap_fluid (fluid, value_box, dynamic_state);
+  scm_swap_fluid (thread, fluid, value_box);
 }
 
 void
@@ -440,9 +440,9 @@ scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
       break;
 
     case SCM_DYNSTACK_TYPE_WITH_FLUID:
-      scm_swap_fluid (WITH_FLUID_FLUID (item),
+      scm_swap_fluid (SCM_I_CURRENT_THREAD,
-                      WITH_FLUID_VALUE_BOX (item),
+                      WITH_FLUID_FLUID (item),
-                      &SCM_I_CURRENT_THREAD->dynamic_state);
+                      WITH_FLUID_VALUE_BOX (item));
       break;
 
     case SCM_DYNSTACK_TYPE_PROMPT:
@@ -497,9 +497,9 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
       break;
 
     case SCM_DYNSTACK_TYPE_WITH_FLUID:
-      scm_swap_fluid (WITH_FLUID_FLUID (words),
+      scm_swap_fluid (SCM_I_CURRENT_THREAD,
-                      WITH_FLUID_VALUE_BOX (words),
+                      WITH_FLUID_FLUID (words),
-                      &SCM_I_CURRENT_THREAD->dynamic_state);
+                      WITH_FLUID_VALUE_BOX (words));
       clear_scm_t_bits (words, WITH_FLUID_WORDS);
       break;
 
@@ -739,8 +739,7 @@ scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
 
 /* This function must not allocate.  */
 void
-scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
+scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, scm_thread *thread)
-                           scm_t_dynamic_state *dynamic_state)
 {
   scm_t_bits tag, *words;
   size_t len;
@@ -751,8 +750,7 @@ scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
   assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUID);
   assert (len == WITH_FLUID_WORDS);
 
-  scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
+  scm_swap_fluid (thread, WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words));
-                  dynamic_state);
   clear_scm_t_bits (words, len);
 }
 

libguile/dynstack.h

@@ -160,9 +160,8 @@ SCM_INTERNAL void scm_dynstack_push_rewinder (scm_t_dynstack *,
 SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
                                               scm_t_dynstack_winder_flags,
                                               scm_t_guard, void *);
-SCM_INTERNAL void scm_dynstack_push_fluid (
+SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *, SCM fluid,
-  scm_t_dynstack *, SCM fluid, SCM value,
+                                           SCM value, scm_thread *thread);
-  scm_t_dynamic_state *dynamic_state);
 SCM_INTERNAL void scm_dynstack_push_dynamic_state (scm_t_dynstack *, SCM,
                                                    scm_t_dynamic_state *);
 SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
@@ -203,7 +202,7 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *,
 
 SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
 SCM_INTERNAL void scm_dynstack_unwind_fluid
-  (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
+  (scm_t_dynstack *dynstack, scm_thread *thread);
 SCM_INTERNAL void scm_dynstack_unwind_dynamic_state
   (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state);
 

libguile/ephemerons.c

@@ -213,7 +213,7 @@ int
 scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<ephemeron ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_puts (")>", port);
   return 1;
 }
@@ -441,7 +441,7 @@ int
 scm_i_print_ephemeron_table (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<ephemeron-table ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_puts (")>", port);
   return 1;
 }

libguile/exceptions.c

@@ -156,8 +156,7 @@ scm_c_with_exception_handler (SCM type, scm_t_exception_handler handler,
                             mra,
                             &registers);
   scm_dynstack_push_fluid (dynstack, exception_handler_fluid,
-                           scm_cons (prompt_tag, type),
+                           scm_cons (prompt_tag, type), t);
-                           dynamic_state);
 
   if (setjmp (registers))
     {
@@ -182,7 +181,7 @@ scm_c_with_exception_handler (SCM type, scm_t_exception_handler handler,
 
   SCM res = thunk (thunk_data);
 
-  scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+  scm_dynstack_unwind_fluid (dynstack, t);
   scm_dynstack_pop (dynstack);
 
   return res;

libguile/finalizers.c

@@ -533,7 +533,7 @@ int
 scm_i_print_finalizer (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<finalizer ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_puts (")>", port);
   return 1;
 }

libguile/fluids-internal.h

@@ -79,8 +79,7 @@ struct scm_dynamic_state
 
 SCM_INTERNAL SCM scm_i_fluid_ref (scm_thread *thread, SCM fluid);
 
-SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box,
+SCM_INTERNAL void scm_swap_fluid (scm_thread *thread, SCM fluid, SCM value_box);
-                                  scm_t_dynamic_state *dynamic_state);
 
 SCM_INTERNAL SCM scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt);
 

libguile/fluids.c

@@ -188,7 +188,7 @@ scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
     scm_puts ("#<thread-local-fluid ", port);
   else
     scm_puts ("#<fluid ", port);
-  scm_intprint (SCM_UNPACK (exp), 16, port);
+  scm_intprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_putc ('>', port);
 }
 
@@ -196,7 +196,7 @@ void
 scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 {
   scm_puts ("#<dynamic-state ", port);
-  scm_intprint (SCM_UNPACK (exp), 16, port);
+  scm_intprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_putc ('>', port);
 }
 
@@ -282,8 +282,9 @@ SCM_DEFINE (scm_fluid_thread_local_p, "fluid-thread-local?", 1, 0, 0,
 #undef FUNC_NAME
 
 static void
-fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
+fluid_set_x (scm_thread *thread, SCM fluid, SCM value)
 {
+  scm_t_dynamic_state *dynamic_state = &thread->dynamic_state;
   struct scm_cache_entry *entry;
   struct scm_cache_entry evicted = { 0, 0 };
 
@@ -294,7 +295,7 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
       return;
     }
 
-  scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted);
+  scm_cache_insert (thread, &dynamic_state->cache, fluid, value, &evicted);
 
   if (evicted.key != 0)
     {
@@ -325,10 +326,11 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value)
 
 /* Return value can be SCM_UNDEFINED; caller checks.  */
 static SCM
-fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
+fluid_ref (scm_thread *thread, SCM fluid)
 {
   SCM val;
   struct scm_cache_entry *entry;
+  scm_t_dynamic_state *dynamic_state = &thread->dynamic_state;
 
   entry = scm_cache_lookup (&dynamic_state->cache, fluid);
   if (scm_is_eq (SCM_PACK (entry->key), fluid))
@@ -342,7 +344,7 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
                                            fluid_default_value (scm_to_fluid (fluid)));
 
   /* Cache this lookup.  */
-  fluid_set_x (dynamic_state, fluid, val);
+  fluid_set_x (thread, fluid, val);
 
   return val;
 }
@@ -350,7 +352,7 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid)
 SCM
 scm_i_fluid_ref (scm_thread *thread, SCM fluid)
 {
-  SCM ret = fluid_ref (&thread->dynamic_state, fluid);
+  SCM ret = fluid_ref (thread, fluid);
 
   if (SCM_UNBNDP (ret))
     scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid));
@@ -379,10 +381,10 @@ SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
 #define FUNC_NAME s_scm_fluid_ref_star
 {
   SCM ret;
-  size_t c_depth;
 
   SCM_VALIDATE_FLUID (1, fluid);
-  c_depth = SCM_NUM2SIZE (2, depth);
+  size_t c_depth = SCM_NUM2SIZE (2, depth);
+  scm_thread *thread = SCM_I_CURRENT_THREAD;
 
   /* Because this function is called to look up the current exception
      handler and this can happen in an out-of-memory situation, we avoid
@@ -390,7 +392,7 @@ SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0,
      disappearing link.  */
   if (c_depth == 0)
     {
-      scm_t_dynamic_state *dynamic_state = &SCM_I_CURRENT_THREAD->dynamic_state;
+      scm_t_dynamic_state *dynamic_state = &thread->dynamic_state;
       struct scm_cache_entry *entry;
 
       entry = scm_cache_lookup (&dynamic_state->cache, fluid);
@@ -429,7 +431,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 #define FUNC_NAME s_scm_fluid_set_x
 {
   SCM_VALIDATE_FLUID (1, fluid);
-  fluid_set_x (&SCM_I_CURRENT_THREAD->dynamic_state, fluid, value);
+  fluid_set_x (SCM_I_CURRENT_THREAD, fluid, value);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -443,7 +445,7 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
      suite demands it, but I would prefer not to.  */
   SCM_VALIDATE_FLUID (1, fluid);
   SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
-  fluid_set_x (&SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED);
+  fluid_set_x (SCM_I_CURRENT_THREAD, fluid, SCM_UNDEFINED);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
@@ -456,7 +458,7 @@ SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0,
 {
   SCM val;
   SCM_VALIDATE_FLUID (1, fluid);
-  val = fluid_ref (&SCM_I_CURRENT_THREAD->dynamic_state, fluid);
+  val = fluid_ref (SCM_I_CURRENT_THREAD, fluid);
   return scm_from_bool (! (SCM_UNBNDP (val)));
 }
 #undef FUNC_NAME
@@ -468,10 +470,10 @@ apply_thunk (void *thunk)
 }
 
 void
-scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate)
+scm_swap_fluid (scm_thread *thread, SCM fluid, SCM value_box)
 {
-  SCM val = fluid_ref (dynstate, fluid);
+  SCM val = fluid_ref (thread, fluid);
-  fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box));
+  fluid_set_x (thread, fluid, SCM_VARIABLE_REF (value_box));
   SCM_VARIABLE_SET (value_box, val);
 }
   
@@ -505,7 +507,7 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
     {
       scm_dynstack_push_fluid (&thread->dynstack,
                                SCM_CAR (fluids), SCM_CAR (values),
-                               &thread->dynamic_state);
+                               thread);
       fluids = SCM_CDR (fluids);
       values = SCM_CDR (values);
     }
@@ -513,7 +515,7 @@ scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
   ans = cproc (cdata);
 
   for (i = 0; i < flen; i++)
-    scm_dynstack_unwind_fluid (&thread->dynstack, &thread->dynamic_state);
+    scm_dynstack_unwind_fluid (&thread->dynstack, thread);
 
   return ans;
 }
@@ -534,9 +536,9 @@ scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
   scm_thread *thread = SCM_I_CURRENT_THREAD;
 
   scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
-                           &thread->dynamic_state);
+                           thread);
   ans = cproc (cdata);
-  scm_dynstack_unwind_fluid (&thread->dynstack, &thread->dynamic_state);
+  scm_dynstack_unwind_fluid (&thread->dynstack, thread);
 
   return ans;
 }
@@ -545,10 +547,10 @@ scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 static void
 swap_fluid (SCM data)
 {
-  scm_t_dynamic_state *dynstate = &SCM_I_CURRENT_THREAD->dynamic_state;
+  scm_thread *thread = SCM_I_CURRENT_THREAD;
   SCM f = SCM_CAR (data);
-  SCM t = fluid_ref (dynstate, f);
+  SCM t = fluid_ref (thread, f);
-  fluid_set_x (dynstate, f, SCM_CDR (data));
+  fluid_set_x (thread, f, SCM_CDR (data));
   SCM_SETCDR (data, t);
 }
 

libguile/foreign.c

@@ -272,7 +272,7 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0,
             "of @var{scm}.")
 #define FUNC_NAME s_scm_scm_to_pointer
 {
-  return make_pointer_1 (SCM_UNPACK (scm), scm);
+  return make_pointer_1 (scm_gc_object_address (SCM_I_CURRENT_THREAD, scm), scm);
 }
 #undef FUNC_NAME
 

libguile/frames.c

@@ -60,7 +60,8 @@ void
 scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
 {
   scm_puts ("#<frame ", port);
-  scm_uintprint (SCM_UNPACK (frame), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, frame),
+                 16, port);
   if (scm_module_system_booted_p)
     {
       SCM name = scm_frame_procedure_name (frame);

libguile/gc.c

@@ -421,7 +421,7 @@ SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
 	    "returned by this function for @var{obj}")
 #define FUNC_NAME s_scm_object_address
 {
-  return scm_from_ulong (SCM_UNPACK (obj));
+  return scm_from_ulong (scm_gc_object_address (SCM_I_CURRENT_THREAD, obj));
 }
 #undef FUNC_NAME
 
@@ -452,6 +452,21 @@ scm_i_gc (const char *what)
  */
 
 
+void
+scm_gc_pin_object (struct scm_thread *thr, SCM x)
+{
+  if (SCM_IMP (x))
+    return;
+  gc_pin_object (thr->mutator, scm_to_ref (x));
+}
+
+uintptr_t
+scm_gc_object_address (struct scm_thread *thr, SCM x)
+{
+  scm_gc_pin_object (thr, x);
+  return SCM_UNPACK (x);
+}
+
 /*
  * If within a function you need to protect one or more scheme objects from
  * garbage collection, pass them as parameters to one of the

libguile/gc.h

@@ -116,6 +116,9 @@ SCM_API void *scm_allocate_pointerless (struct scm_thread *thr, size_t size);
 SCM_API void *scm_allocate_tagged (struct scm_thread *thr, size_t size);
 SCM_API void *scm_allocate_sloppy (struct scm_thread *thr, size_t size);
 
+SCM_API void scm_gc_pin_object (struct scm_thread *thr, SCM x);
+SCM_API uintptr_t scm_gc_object_address (struct scm_thread *thr, SCM x);
+
 SCM_API void *scm_gc_malloc_pointerless (size_t size, const char *what)
   SCM_MALLOC;
 SCM_API void *scm_gc_calloc (size_t size, const char *what)

libguile/hash.c

@@ -40,6 +40,7 @@
 #include "struct.h"
 #include "symbols.h"
 #include "syntax.h"
+#include "threads-internal.h"
 #include "vectors.h"
 
 #include "hash.h"
@@ -232,33 +233,6 @@ scm_i_utf8_string_hash (const char *str, size_t len)
   return ret;
 }
 
-static unsigned long scm_raw_ihashq (scm_t_bits key);
-static unsigned long scm_raw_ihash (SCM obj, size_t depth);
-
-/* Return the hash of struct OBJ.  Traverse OBJ's fields to compute the
-   result, unless DEPTH is zero.  Assumes that OBJ is a struct.  */
-static unsigned long
-scm_i_struct_hash (SCM obj, size_t depth)
-{
-  size_t struct_size, field_num;
-  unsigned long hash;
-
-  struct_size = SCM_STRUCT_SIZE (obj);
-
-  hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
-  if (depth > 0)
-    {
-      for (field_num = 0; field_num < struct_size; field_num++)
-        if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, field_num))
-          hash ^= scm_raw_ihashq (SCM_STRUCT_DATA_REF (obj, field_num));
-        else
-          hash ^= scm_raw_ihash (SCM_STRUCT_SLOT_REF (obj, field_num),
-                                 depth / 2);
-    }
-
-  return hash;
-}
-
 /* Thomas Wang's integer hasher, from
    http://www.cris.com/~Ttwang/tech/inthash.htm.  */
 static unsigned long
@@ -286,6 +260,39 @@ scm_raw_ihashq (scm_t_bits key)
   return key;
 }
 
+static unsigned long
+scm_pinned_ihashq (SCM x)
+{
+  scm_gc_pin_object (SCM_I_CURRENT_THREAD, x);
+
+  return scm_raw_ihashq (SCM_UNPACK (x));
+}
+
+/* Return the hash of struct OBJ.  Traverse OBJ's fields to compute the
+   result, unless DEPTH is zero.  Assumes that OBJ is a struct.  */
+static unsigned long scm_raw_ihash (SCM obj, size_t depth);
+static unsigned long
+scm_i_struct_hash (SCM obj, size_t depth)
+{
+  size_t struct_size, field_num;
+  unsigned long hash;
+
+  struct_size = SCM_STRUCT_SIZE (obj);
+
+  hash = scm_pinned_ihashq (SCM_STRUCT_VTABLE (obj));
+  if (depth > 0)
+    {
+      for (field_num = 0; field_num < struct_size; field_num++)
+        if (SCM_STRUCT_FIELD_IS_UNBOXED (obj, field_num))
+          hash ^= scm_raw_ihashq (SCM_STRUCT_DATA_REF (obj, field_num));
+        else
+          hash ^= scm_raw_ihash (SCM_STRUCT_SLOT_REF (obj, field_num),
+                                 depth / 2);
+    }
+
+  return hash;
+}
+
 /* `depth' is used to limit recursion. */
 static unsigned long
 scm_raw_ihash (SCM obj, size_t depth)
@@ -347,7 +354,7 @@ scm_raw_ihash (SCM obj, size_t depth)
     case scm_tc7_program:
     case scm_tc7_vm_cont:
     case scm_tc7_port:
-      return scm_raw_ihashq (SCM_UNPACK (obj));
+      return scm_pinned_ihashq (obj);
 
     case scm_tcs_cons_imcar: 
     case scm_tcs_cons_nimcar:
@@ -369,7 +376,7 @@ scm_raw_ihash (SCM obj, size_t depth)
 unsigned long
 scm_ihashq (SCM obj, unsigned long n)
 {
-  return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
+  return scm_pinned_ihashq (obj) % n;
 }
 
 
@@ -402,7 +409,7 @@ scm_ihashv (SCM obj, unsigned long n)
   if (SCM_NUMP(obj))
     return scm_raw_ihash (obj, 10) % n;
   else
-    return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
+    return scm_pinned_ihashq (obj) % n;
 }
 
 

libguile/hashtab.c

@@ -641,7 +641,7 @@ scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
   struct scm_t_hashtable *ht = scm_to_hashtable (exp);
   
   scm_puts ("#<hash-table ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_putc (' ', port);
   scm_uintprint (hashtable_n_items (ht), 10, port);
   scm_putc ('/', port);

libguile/intrinsics.c

@@ -179,13 +179,13 @@ static void
 push_fluid (scm_thread *thread, SCM fluid, SCM value)
 {
   scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
-                           &thread->dynamic_state);
+                           thread);
 }
 
 static void
 pop_fluid (scm_thread *thread)
 {
-  scm_dynstack_unwind_fluid (&thread->dynstack, &thread->dynamic_state);
+  scm_dynstack_unwind_fluid (&thread->dynstack, thread);
 }
 
 static SCM

libguile/memoize.c

@@ -99,7 +99,7 @@ do_push_fluid (SCM fluid, SCM val)
 {
   scm_thread *thread = SCM_I_CURRENT_THREAD;
   scm_dynstack_push_fluid (&thread->dynstack, fluid, val,
-                           &thread->dynamic_state);
+                           thread);
   return SCM_UNSPECIFIED;
 }
 
@@ -107,7 +107,7 @@ static SCM
 do_pop_fluid (void)
 {
   scm_thread *thread = SCM_I_CURRENT_THREAD;
-  scm_dynstack_unwind_fluid (&thread->dynstack, &thread->dynamic_state);
+  scm_dynstack_unwind_fluid (&thread->dynstack, thread);
   return SCM_UNSPECIFIED;
 }
 

libguile/print.c

@@ -627,6 +627,7 @@ print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
 static void
 iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 {
+  struct scm_thread *thr = SCM_I_CURRENT_THREAD;
   switch (SCM_ITAG3 (exp))
     {
     case scm_tc3_tc7_1:
@@ -736,7 +737,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	      scm_puts ("#<uninterned-symbol ", port);
 	      print_symbol (exp, port);
 	      scm_putc (' ', port);
-	      scm_uintprint (SCM_UNPACK (exp), 16, port);
+	      scm_uintprint (scm_gc_object_address (thr, exp), 16, port);
 	      scm_putc ('>', port);
 	    }
 	  break;
@@ -845,17 +846,17 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
                 break;
               case scm_tc16_random_state:
                 scm_puts ("#<random-state ", port);
-                scm_uintprint (SCM_UNPACK (exp), 16, port);
+                scm_uintprint (scm_gc_object_address (thr, exp), 16, port);
                 scm_putc ('>', port);
                 break;
               case scm_tc16_regexp:
                 scm_puts ("#<regexp ", port);
-                scm_uintprint (SCM_UNPACK (exp), 16, port);
+                scm_uintprint (scm_gc_object_address (thr, exp), 16, port);
                 scm_putc ('>', port);
                 break;
               case scm_tc16_locale:
                 scm_puts ("#<locale ", port);
-                scm_uintprint (SCM_UNPACK (exp), 16, port);
+                scm_uintprint (scm_gc_object_address (thr, exp), 16, port);
                 scm_putc ('>', port);
                 break;
               default:
@@ -936,14 +937,6 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
 {
   scm_puts ("#<unknown-", port);
   scm_puts (hdr, port);
-  if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
-    {
-      scm_puts (" (0x", port);
-      scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
-      scm_puts (" . 0x", port);
-      scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
-      scm_puts (") @", port);
-    }
   scm_puts (" 0x", port);
   scm_uintprint (SCM_UNPACK (ptr), 16, port);
   scm_putc ('>', port);

libguile/programs.c

@@ -126,20 +126,23 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
     {
       /* twingliness */
       scm_puts ("#<continuation ", port);
-      scm_uintprint (SCM_UNPACK (program), 16, port);
+      scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, program),
+                     16, port);
       scm_putc ('>', port);
     }
   else if (scm_program_is_partial_continuation (p))
     {
       /* twingliness */
       scm_puts ("#<partial-continuation ", port);
-      scm_uintprint (SCM_UNPACK (program), 16, port);
+      scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, program),
+                     16, port);
       scm_putc ('>', port);
     }
   else if (scm_is_false (write_program) || print_error)
     {
       scm_puts ("#<program ", port);
-      scm_uintprint (SCM_UNPACK (program), 16, port);
+      scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, program),
+                     16, port);
       scm_putc (' ', port);
       scm_uintprint ((uintptr_t) p->code, 16, port);
       scm_putc ('>', port);

libguile/smob.c

@@ -76,7 +76,7 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
   if (scm_smobs[n].size)
     scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
   else
-    scm_uintprint (SCM_UNPACK (exp), 16, port);
+    scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_putc ('>', port);
   return 1;
 }

libguile/struct.c

@@ -242,6 +242,8 @@ scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
     }
 
   SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VALIDATED);
+
+  scm_gc_pin_object (SCM_I_CURRENT_THREAD, obj);
 }
 #undef FUNC_NAME
 
@@ -536,6 +538,8 @@ scm_i_make_vtable_vtable (SCM fields)
     else
       SCM_STRUCT_SLOT_SET (obj, n, SCM_BOOL_F);
 
+  scm_gc_pin_object (SCM_I_CURRENT_THREAD, obj);
+
   return obj;
 }
 #undef FUNC_NAME
@@ -727,14 +731,6 @@ SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
  * how to associate names with vtables.
  */
 
-unsigned long
-scm_struct_ihashq (SCM obj, unsigned long n, void *closure)
-{
-  /* The length of the hash table should be a relative prime it's not
-     necessary to shift down the address.  */
-  return SCM_UNPACK (obj) % n;
-}
-
 SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, 
             (SCM vtable),
 	    "Return the name of the vtable @var{vtable}.")

libguile/struct.h

@@ -247,7 +247,6 @@ SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
 SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
 
 SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
-SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
 SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
 SCM_INTERNAL void scm_i_finalize_struct (struct scm_thread *thread, SCM obj);
 SCM_INTERNAL void scm_init_struct (void);

libguile/variable.c

@@ -41,7 +41,7 @@ void
 scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
 {
   scm_puts ("#<variable ", port);
-  scm_uintprint (SCM_UNPACK (exp), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, exp), 16, port);
   scm_puts (" value: ", port);
   scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
   scm_putc ('>', port);

libguile/vm.c

@@ -137,7 +137,7 @@ void
 scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
 {
   scm_puts ("#<vm-continuation ", port);
-  scm_uintprint (SCM_UNPACK (x), 16, port);
+  scm_uintprint (scm_gc_object_address (SCM_I_CURRENT_THREAD, x), 16, port);
   scm_puts (">", port);
 }