mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-01 15:20:34 +02:00
Code Activity

scm_gc_object_address pins its referent

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2025-06-26 15:00:22 +02:00
parent b0ce014801
commit a7d7ff5019
25 changed files with 133 additions and 117 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/atomic.c
View file

@ -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);

6
libguile/cache-internal.h
View file

@ -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);
}

4
libguile/continuations.c
View file

@ -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

22
libguile/dynstack.c
View file

@ -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);
}

7
libguile/dynstack.h
View file

@ -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);

4
libguile/ephemerons.c
View file

@ -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;
}

5
libguile/exceptions.c
View file

@ -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),
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;

2
libguile/finalizers.c
View file

@ -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;
}

3
libguile/fluids-internal.h
View file

@ -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);

48
libguile/fluids.c
View file

@ -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);
}

2
libguile/foreign.c
View file

@ -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

3
libguile/frames.c
View file

@ -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);

17
libguile/gc.c
View file

@ -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

3
libguile/gc.h
View file

@ -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)

67
libguile/hash.c
View file

@ -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;
}

2
libguile/hashtab.c
View file

@ -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);

4
libguile/intrinsics.c
View file

@ -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

4
libguile/memoize.c
View file

@ -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;
}

17
libguile/print.c
View file

@ -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);

9
libguile/programs.c
View file

@ -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);

2
libguile/smob.c
View file

@ -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;
}

12
libguile/struct.c
View file

@ -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}.")

1
libguile/struct.h
View file

@ -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);

2
libguile/variable.c
View file

@ -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);

2
libguile/vm.c
View file

@ -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);
}