wingo pushed a commit to branch wip-whippet
in repository guile.
commit a7d7ff501909268ddffb74c4ebaa0116c9a801dc
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Thu Jun 26 15:00:22 2025 +0200
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 | 2 +-
libguile/cache-internal.h | 6 +++--
libguile/continuations.c | 4 +--
libguile/dynstack.c | 22 +++++++--------
libguile/dynstack.h | 7 +++--
libguile/ephemerons.c | 4 +--
libguile/exceptions.c | 5 ++--
libguile/finalizers.c | 2 +-
libguile/fluids-internal.h | 3 +--
libguile/fluids.c | 48 +++++++++++++++++----------------
libguile/foreign.c | 2 +-
libguile/frames.c | 3 ++-
libguile/gc.c | 17 +++++++++++-
libguile/gc.h | 3 +++
libguile/hash.c | 67 +++++++++++++++++++++++++---------------------
libguile/hashtab.c | 2 +-
libguile/intrinsics.c | 4 +--
libguile/memoize.c | 4 +--
libguile/print.c | 17 ++++--------
libguile/programs.c | 9 ++++---
libguile/smob.c | 2 +-
libguile/struct.c | 12 +++------
libguile/struct.h | 1 -
libguile/variable.c | 2 +-
libguile/vm.c | 2 +-
25 files changed, 133 insertions(+), 117 deletions(-)
diff --git a/libguile/atomic.c b/libguile/atomic.c
index 29d49051b..366576f2b 100644
--- a/libguile/atomic.c
+++ b/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);
diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h
index 08e3fde22..f7b5cae74 100644
--- a/libguile/cache-internal.h
+++ b/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);
}
diff --git a/libguile/continuations.c b/libguile/continuations.c
index d6ba396e2..d15a281d1 100644
--- a/libguile/continuations.c
+++ b/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
diff --git a/libguile/dynstack.c b/libguile/dynstack.c
index 25a1f11eb..6d188f24d 100644
--- a/libguile/dynstack.c
+++ b/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),
- WITH_FLUID_VALUE_BOX (item),
- &SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_swap_fluid (SCM_I_CURRENT_THREAD,
+ WITH_FLUID_FLUID (item),
+ 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),
- WITH_FLUID_VALUE_BOX (words),
- &SCM_I_CURRENT_THREAD->dynamic_state);
+ scm_swap_fluid (SCM_I_CURRENT_THREAD,
+ WITH_FLUID_FLUID (words),
+ 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_t_dynamic_state *dynamic_state)
+scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, scm_thread *thread)
{
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),
- dynamic_state);
+ scm_swap_fluid (thread, WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX
(words));
clear_scm_t_bits (words, len);
}
diff --git a/libguile/dynstack.h b/libguile/dynstack.h
index 29cf9a081..b2fe015d7 100644
--- a/libguile/dynstack.h
+++ b/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_t_dynstack *, SCM fluid, SCM value,
- scm_t_dynamic_state *dynamic_state);
+SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *, SCM fluid,
+ SCM value, scm_thread *thread);
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);
diff --git a/libguile/ephemerons.c b/libguile/ephemerons.c
index 73fa1f3d8..6029333e2 100644
--- a/libguile/ephemerons.c
+++ b/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;
}
diff --git a/libguile/exceptions.c b/libguile/exceptions.c
index ccaa04f63..555af7a34 100644
--- a/libguile/exceptions.c
+++ b/libguile/exceptions.c
@@ -156,8 +156,7 @@ scm_c_with_exception_handler (SCM type,
scm_t_exception_handler handler,
mra,
®isters);
scm_dynstack_push_fluid (dynstack, exception_handler_fluid,
- scm_cons (prompt_tag, type),
- dynamic_state);
+ scm_cons (prompt_tag, type), t);
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;
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index 961a59a29..8849c5c47 100644
--- a/libguile/finalizers.c
+++ b/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;
}
diff --git a/libguile/fluids-internal.h b/libguile/fluids-internal.h
index 98492be13..90a6608f6 100644
--- a/libguile/fluids-internal.h
+++ b/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_t_dynamic_state *dynamic_state);
+SCM_INTERNAL void scm_swap_fluid (scm_thread *thread, SCM fluid, SCM
value_box);
SCM_INTERNAL SCM scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt);
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 462734050..80437924b 100644
--- a/libguile/fluids.c
+++ b/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);
- fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box));
+ SCM val = fluid_ref (thread, fluid);
+ 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);
- fluid_set_x (dynstate, f, SCM_CDR (data));
+ SCM t = fluid_ref (thread, f);
+ fluid_set_x (thread, f, SCM_CDR (data));
SCM_SETCDR (data, t);
}
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 5ccf481d8..21495b166 100644
--- a/libguile/foreign.c
+++ b/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
diff --git a/libguile/frames.c b/libguile/frames.c
index a69a6eb48..5d615608a 100644
--- a/libguile/frames.c
+++ b/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);
diff --git a/libguile/gc.c b/libguile/gc.c
index 80a93cce3..6bbb32d26 100644
--- a/libguile/gc.c
+++ b/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
diff --git a/libguile/gc.h b/libguile/gc.h
index fbf774468..f545c2aa6 100644
--- a/libguile/gc.h
+++ b/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)
diff --git a/libguile/hash.c b/libguile/hash.c
index 7799c039d..e3643aee1 100644
--- a/libguile/hash.c
+++ b/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;
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index ffac51184..d200c7288 100644
--- a/libguile/hashtab.c
+++ b/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);
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index f60b3f479..3243e8ce9 100644
--- a/libguile/intrinsics.c
+++ b/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
diff --git a/libguile/memoize.c b/libguile/memoize.c
index cfad6babc..e35ea5be2 100644
--- a/libguile/memoize.c
+++ b/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;
}
diff --git a/libguile/print.c b/libguile/print.c
index 949d7e572..70894931b 100644
--- a/libguile/print.c
+++ b/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);
diff --git a/libguile/programs.c b/libguile/programs.c
index 065120e7d..246197c2d 100644
--- a/libguile/programs.c
+++ b/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);
diff --git a/libguile/smob.c b/libguile/smob.c
index e96ca554d..c1564315c 100644
--- a/libguile/smob.c
+++ b/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;
}
diff --git a/libguile/struct.c b/libguile/struct.c
index 51a31f32e..8d7b00161 100644
--- a/libguile/struct.c
+++ b/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}.")
diff --git a/libguile/struct.h b/libguile/struct.h
index 26697352c..38a4dcebb 100644
--- a/libguile/struct.h
+++ b/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);
diff --git a/libguile/variable.c b/libguile/variable.c
index 8d0b10fbc..ec61faffa 100644
--- a/libguile/variable.c
+++ b/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);
diff --git a/libguile/vm.c b/libguile/vm.c
index 856c7b0fe..f879fd771 100644
--- a/libguile/vm.c
+++ b/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);
}
