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 ("#', 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 ("#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 ("#", 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 ("#", 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 ("#", 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 ("#', port); } @@ -196,7 +196,7 @@ void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#', 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 ("#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 ("#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 ("#', port); } break; @@ -845,17 +846,17 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc16_random_state: scm_puts ("#', port); break; case scm_tc16_regexp: scm_puts ("#', port); break; case scm_tc16_locale: scm_puts ("#', port); break; default: @@ -936,14 +937,6 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) { scm_puts ("#', 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 ("#', port); } else if (scm_program_is_partial_continuation (p)) { /* twingliness */ scm_puts ("#', port); } else if (scm_is_false (write_program) || print_error) { scm_puts ("#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 ("#', 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 ("#", port); }