diff options
Diffstat (limited to 'libguile')
| -rw-r--r-- | libguile/Makefile.am | 1 | ||||
| -rw-r--r-- | libguile/__scm.h | 4 | ||||
| -rw-r--r-- | libguile/cache-internal.h | 111 | ||||
| -rw-r--r-- | libguile/deprecated.c | 14 | ||||
| -rw-r--r-- | libguile/deprecated.h | 4 | ||||
| -rw-r--r-- | libguile/dynstack.c | 5 | ||||
| -rw-r--r-- | libguile/dynstack.h | 10 | ||||
| -rw-r--r-- | libguile/fluids.c | 395 | ||||
| -rw-r--r-- | libguile/fluids.h | 25 | ||||
| -rw-r--r-- | libguile/threads.c | 69 | ||||
| -rw-r--r-- | libguile/threads.h | 3 | ||||
| -rw-r--r-- | libguile/throw.c | 2 | ||||
| -rw-r--r-- | libguile/vm-engine.c | 55 | ||||
| -rw-r--r-- | libguile/vm.c | 11 |
14 files changed, 416 insertions, 293 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8bf9ddf59..c36a7e5ef 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -505,6 +505,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ srfi-14.i.c \ quicksort.i.c \ atomics-internal.h \ + cache-internal.h \ posix-w32.h \ private-options.h ports-internal.h diff --git a/libguile/__scm.h b/libguile/__scm.h index dde26be05..62ceeeb9c 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -412,6 +412,10 @@ typedef void *scm_t_subr; +typedef struct scm_dynamic_state scm_t_dynamic_state; + + + /* scm_i_jmp_buf * * The corresponding SCM_I_SETJMP and SCM_I_LONGJMP are defined in the diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h new file mode 100644 index 000000000..fc1e3c139 --- /dev/null +++ b/libguile/cache-internal.h @@ -0,0 +1,111 @@ +#ifndef SCM_CACHE_INTERNAL_H +#define SCM_CACHE_INTERNAL_H + +/* Copyright (C) 2016 + * Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + + +#include <string.h> + +#include "libguile/__scm.h" +#include "libguile/gc.h" +#include "libguile/hash.h" +#include "libguile/threads.h" + + +/* A simple cache with 8 entries. The cache entries are stored in a + sorted vector. */ +struct scm_cache_entry +{ + scm_t_bits key; + scm_t_bits value; +}; + +#define SCM_CACHE_SIZE 8 + +struct scm_cache +{ + scm_t_bits eviction_cookie; + struct scm_cache_entry entries[SCM_CACHE_SIZE]; +}; + +static inline struct scm_cache* +scm_make_cache (void) +{ + struct scm_cache *ret = scm_gc_typed_calloc (struct scm_cache); + ret->eviction_cookie = (scm_t_bits) ret; + return ret; +} + +static inline int +scm_cache_full_p (struct scm_cache *cache) +{ + return cache->entries[0].key != 0; +} + +static inline void +scm_cache_evict_1 (struct scm_cache *cache, struct scm_cache_entry *evicted) +{ + size_t idx; + cache->eviction_cookie = scm_ihashq (SCM_PACK (cache->eviction_cookie), -1); + idx = cache->eviction_cookie & (SCM_CACHE_SIZE - 1); + memcpy (evicted, cache->entries + idx, sizeof (*evicted)); + memmove (cache->entries + 1, + cache->entries, + sizeof (cache->entries[0]) * idx); + cache->entries[0].key = 0; + cache->entries[0].value = 0; +} + +static inline struct scm_cache_entry* +scm_cache_lookup (struct scm_cache *cache, SCM k) +{ + scm_t_bits k_bits = SCM_UNPACK (k); + struct scm_cache_entry *entry = cache->entries; + /* Unrolled binary search, compiled to branchless cmp + cmov chain. */ + if (entry[4].key <= k_bits) entry += 4; + if (entry[2].key <= k_bits) entry += 2; + if (entry[1].key <= k_bits) entry += 1; + return entry; +} + +static inline void +scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, + struct scm_cache_entry *evicted) +{ + struct scm_cache_entry *entry; + + if (scm_cache_full_p (cache)) + scm_cache_evict_1 (cache, evicted); + entry = scm_cache_lookup (cache, k); + if (entry->key == SCM_UNPACK (k)) + { + entry->value = SCM_UNPACK (v); + return; + } + memmove (cache->entries, + cache->entries + 1, + (entry - cache->entries) * sizeof (*entry)); + entry->key = SCM_UNPACK (k); + entry->value = SCM_UNPACK (v); +} + +#endif /* SCM_CACHE_INTERNAL_H */ diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 0ea4b5e20..c3d4935d0 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -853,7 +853,7 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data, scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack)); scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); - scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED)); + scm_dynwind_current_dynamic_state (scm_current_dynamic_state ()); my_handler_data.run_handler = 0; answer = scm_i_with_continuation_barrier (body, body_data, @@ -928,6 +928,18 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) +SCM +scm_make_dynamic_state (SCM parent) +{ + scm_c_issue_deprecation_warning + ("scm_make_dynamic_state is deprecated. Dynamic states are " + "now immutable; just use the parent directly."); + return SCM_UNBNDP (parent) ? scm_current_dynamic_state () : parent; +} + + + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 69f9e1ef0..b1e455a89 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -256,6 +256,10 @@ SCM_DEPRECATED SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, +SCM_DEPRECATED SCM scm_make_dynamic_state (SCM parent); + + + /* Deprecated 2016-11-18. Never documented. Unnecessary, since array-copy! already unrolls and does it in more general cases. */ /* With this also remove SCM_I_ARRAY_FLAG_CONTIGUOUS, diff --git a/libguile/dynstack.c b/libguile/dynstack.c index bda1a16b5..7fb858391 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -163,7 +163,7 @@ scm_dynstack_push_unwinder (scm_t_dynstack *dynstack, binding. */ void scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value, - SCM dynamic_state) + scm_t_dynamic_state *dynamic_state) { scm_t_bits *words; SCM value_box; @@ -525,7 +525,8 @@ scm_dynstack_unwind_frame (scm_t_dynstack *dynstack) /* This function must not allocate. */ void -scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state) +scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, + scm_t_dynamic_state *dynamic_state) { scm_t_bits tag, *words; size_t len; diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 853f0684d..592e7c819 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -147,9 +147,9 @@ 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 dynamic_state); +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_prompt (scm_t_dynstack *, scm_t_dynstack_prompt_flags, SCM key, @@ -186,8 +186,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *, 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 dynamic_state); +SCM_INTERNAL void scm_dynstack_unwind_fluid + (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state); SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM, scm_t_dynstack_prompt_flags *, diff --git a/libguile/fluids.c b/libguile/fluids.c index 5ff92a884..72c75952d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -25,6 +25,8 @@ #include <string.h> #include "libguile/_scm.h" +#include "libguile/atomics-internal.h" +#include "libguile/cache-internal.h" #include "libguile/print.h" #include "libguile/dynwind.h" #include "libguile/fluids.h" @@ -35,52 +37,138 @@ #include "libguile/validate.h" #include "libguile/bdw-gc.h" -/* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */ -#define FLUID_GROW 128 - -/* Vector of allocated fluids indexed by fluid numbers. Access is protected by - FLUID_ADMIN_MUTEX. */ -static void **allocated_fluids = NULL; -static size_t allocated_fluids_len = 0; - -static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -#define IS_FLUID(x) SCM_FLUID_P (x) -#define FLUID_NUM(x) SCM_I_FLUID_NUM (x) - -#define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x) -#define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x) -#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y))) +/* A dynamic state associates fluids with values. There are two + representations of a dynamic state in Guile: the active + representation that is part of each thread, and a frozen + representation that can live in Scheme land as a value. + + The active dynamic state has two parts: a locals cache, and a values + table. The locals cache stores fluid values that have been recently + referenced or set. If a value isn't in the locals cache, Guile then + looks for it in the values table, which is a weak-key hash table. + Otherwise Guile falls back to the default value of the fluid. In any + case, the value is recorded in the locals cache. Likewise setting a + fluid's value simply inserts that association into the locals cache. + + The locals cache is not large, so adding an entry to it might evict + some other entry. In that case the entry gets flushed to the values + table. + + The values table begins as being inherited from the parent dynamic + state, and represents a capture of the fluid values at a point in + time. A dynamic state records when its values table might be + referenced by other dynamic states. If it is aliased, then any + update to that table has to start by making a fresh local copy to + work on. + + There are two interesting constraints on dynamic states, besides + speed. One is that they should hold onto their fluid-value + associations weakly: they shouldn't keep fluids alive indefinitely, + and if a fluid goes away, its value should become collectible too. + This is why the values table is a weak table; it makes access + somewhat slower, but this is mitigated by the cache. The cache + itself holds onto fluids and values strongly, but if there are more + than 8 fluids in use by a dynamic state, this won't be a problem. + + The other interesting constraint is memory usage: you don't want a + program with M fluids and N dynamic states to consume N*M memory. + Guile associates each thread with a dynamic state, which itself isn't + that bad as there are relatively few threads in a program. The + problem comes in with "fibers", lightweight user-space threads that + can be allocated in the millions. Here you want new fibers to + inherit the dynamic state from the fiber that created them, but you + really need to limit memory overheads. For reference, in late 2016, + non-dynamic-state memory overhead per fiber in one user-space library + is around 500 bytes, in a simple "all fibers try to send a message on + one channel" test case. + + For this reason the frozen representation of dynamic states is the + probably-shared values table at the end of a list of fluid-value + pairs, representing entries from the locals cache that differ from + the values table. This keeps per-dynamic-state memory usage in + check. A family of fibers that uses the same 3 or 4 fluids probably + won't ever have to allocate a new values table. Ideally the values + table could share more state, as in an immutable weak array-mapped + hash trie or something, but we don't have such a data structure. */ + +static inline int +is_dynamic_state (SCM x) +{ + return SCM_HAS_TYP7 (x, scm_tc7_dynamic_state); +} + +static inline SCM +get_dynamic_state (SCM dynamic_state) +{ + return SCM_CELL_OBJECT_1 (dynamic_state); +} + +static inline void +restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) +{ + int slot; + for (slot = SCM_CACHE_SIZE - 1; slot >= 0; slot--) + { + struct scm_cache_entry *entry = &state->cache.entries[slot]; + if (scm_is_pair (saved)) + { + entry->key = SCM_UNPACK (SCM_CAAR (saved)); + entry->value = SCM_UNPACK (SCM_CDAR (saved)); + saved = scm_cdr (saved); + } + else + entry->key = entry->value = 0; + } + state->values = saved; + state->has_aliased_values = 1; +} +static inline SCM +save_dynamic_state (scm_t_dynamic_state *state) +{ + int slot; + SCM saved = state->values; + for (slot = 0; slot < SCM_CACHE_SIZE; slot++) + { + struct scm_cache_entry *entry = &state->cache.entries[slot]; + SCM key = SCM_PACK (entry->key); + SCM value = SCM_PACK (entry->value); + if (entry->key && + !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED), + value)) + { + if (state->has_aliased_values) + saved = scm_acons (key, value, saved); + else + scm_weak_table_putq_x (state->values, key, value); + } + } + state->has_aliased_values = 1; + return saved; +} - -/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may - be more than necessary since ALLOCATED_FLUIDS is sparse and the current - thread may not access all the fluids anyway. Memory usage could be improved - by using a 2-level array as is done in glibc for pthread keys (TODO). */ -static void -grow_dynamic_state (SCM state) +static SCM +add_entry (void *data, SCM k, SCM v, SCM result) { - SCM new_fluids; - SCM old_fluids = DYNAMIC_STATE_FLUIDS (state); - size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids); + scm_weak_table_putq_x (result, k, v); + return result; +} - /* Assume the assignment below is atomic. */ - len = allocated_fluids_len; +static SCM +copy_value_table (SCM tab) +{ + SCM ret = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + return scm_c_weak_table_fold (add_entry, NULL, ret, tab); +} - new_fluids = scm_c_make_vector (len, SCM_UNDEFINED); - for (i = 0; i < old_len; i++) - SCM_SIMPLE_VECTOR_SET (new_fluids, i, - SCM_SIMPLE_VECTOR_REF (old_fluids, i)); - SET_DYNAMIC_STATE_FLUIDS (state, new_fluids); -} + void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#<fluid ", port); - scm_intprint ((int) FLUID_NUM (exp), 10, port); + scm_intprint (SCM_UNPACK (exp), 16, port); scm_putc ('>', port); } @@ -92,75 +180,15 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED scm_putc ('>', port); } + -/* Return a new fluid. */ + +#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x)) + static SCM new_fluid (SCM init) { - SCM fluid; - size_t trial, n; - - /* Fluids hold the type tag and the fluid number in the first word, - and the default value in the second word. */ - fluid = scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); - SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid); - - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex); - - for (trial = 0; trial < 2; trial++) - { - /* Look for a free fluid number. */ - for (n = 0; n < allocated_fluids_len; n++) - /* TODO: Use `__sync_bool_compare_and_swap' where available. */ - if (allocated_fluids[n] == NULL) - break; - - if (trial == 0 && n >= allocated_fluids_len && allocated_fluids_len) - /* All fluid numbers are in use. Run a GC and retry. Explicitly - running the GC is costly and bad-style. We only do this because - dynamic state fluid vectors would grow unreasonably if fluid numbers - weren't reused. */ - scm_i_gc ("fluids"); - } - - if (n >= allocated_fluids_len) - { - /* Grow the vector of allocated fluids. */ - void **new_allocated_fluids = - scm_gc_malloc_pointerless ((allocated_fluids_len + FLUID_GROW) - * sizeof (*allocated_fluids), - "allocated fluids"); - - /* Copy over old values and initialize rest. GC can not run - during these two operations since there is no safe point in - them. */ - memcpy (new_allocated_fluids, allocated_fluids, - allocated_fluids_len * sizeof (*allocated_fluids)); - memset (new_allocated_fluids + allocated_fluids_len, 0, - FLUID_GROW * sizeof (*allocated_fluids)); - n = allocated_fluids_len; - - /* Update the vector of allocated fluids. Dynamic states will - eventually be lazily grown to accomodate the new value of - ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */ - allocated_fluids = new_allocated_fluids; - allocated_fluids_len += FLUID_GROW; - } - - allocated_fluids[n] = SCM_UNPACK_POINTER (fluid); - SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8))); - - GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n], - SCM2PTR (fluid)); - - scm_dynwind_end (); - - /* Now null out values. We could (and probably should) do this when - the fluid is collected instead of now. */ - scm_i_reset_fluid (n); - - return fluid; + return scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); } SCM @@ -200,36 +228,72 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_p { - return scm_from_bool (IS_FLUID (obj)); + return scm_from_bool (SCM_FLUID_P (obj)); } #undef FUNC_NAME int scm_is_fluid (SCM obj) { - return IS_FLUID (obj); + return SCM_FLUID_P (obj); } -/* Does not check type of `fluid'! */ -static SCM -fluid_ref (SCM fluid) +static void +fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) { - SCM ret; - SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + struct scm_cache_entry *entry; + struct scm_cache_entry evicted = { 0, 0 }; - if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + entry = scm_cache_lookup (&dynamic_state->cache, fluid); + if (scm_is_eq (SCM_PACK (entry->key), fluid)) { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); + entry->value = SCM_UNPACK (value); + return; + } + + scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted); - fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + if (evicted.key != 0) + { + fluid = SCM_PACK (evicted.key); + value = SCM_PACK (evicted.value); + + if (dynamic_state->has_aliased_values) + { + if (scm_is_eq (scm_weak_table_refq (dynamic_state->values, + fluid, SCM_UNDEFINED), + value)) + return; + dynamic_state->values = copy_value_table (dynamic_state->values); + dynamic_state->has_aliased_values = 0; + } + + scm_weak_table_putq_x (dynamic_state->values, fluid, value); } +} - ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid)); - if (SCM_UNBNDP (ret)) - return SCM_I_FLUID_DEFAULT (fluid); +/* Return value can be SCM_UNDEFINED; caller checks. */ +static SCM +fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) +{ + SCM val; + struct scm_cache_entry *entry; + + entry = scm_cache_lookup (&dynamic_state->cache, fluid); + if (scm_is_eq (SCM_PACK (entry->key), fluid)) + val = SCM_PACK (entry->value); else - return ret; + { + val = scm_weak_table_refq (dynamic_state->values, fluid, SCM_UNDEFINED); + + if (SCM_UNBNDP (val)) + val = SCM_I_FLUID_DEFAULT (fluid); + + /* Cache this lookup. */ + fluid_set_x (dynamic_state, fluid, val); + } + + return val; } SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, @@ -239,13 +303,12 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - SCM val; + SCM ret; SCM_VALIDATE_FLUID (1, fluid); - val = fluid_ref (fluid); - if (SCM_UNBNDP (val)) - SCM_MISC_ERROR ("unbound fluid: ~S", - scm_list_1 (fluid)); - return val; + ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); + if (SCM_UNBNDP (ret)) + scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid)); + return ret; } #undef FUNC_NAME @@ -254,19 +317,8 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); - SCM_VALIDATE_FLUID (1, fluid); - - if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) - { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); - - fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); - } - - SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -278,8 +330,10 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0, { /* FIXME: really unset the default value, too? The current test suite demands it, but I would prefer not to. */ + SCM_VALIDATE_FLUID (1, fluid); SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED); - return scm_fluid_set_x (fluid, SCM_UNDEFINED); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -291,7 +345,7 @@ SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0, { SCM val; SCM_VALIDATE_FLUID (1, fluid); - val = fluid_ref (fluid); + val = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); return scm_from_bool (! (SCM_UNBNDP (val))); } #undef FUNC_NAME @@ -303,26 +357,11 @@ apply_thunk (void *thunk) } void -scm_swap_fluid (SCM fluid, SCM value_box, SCM dynstate) +scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate) { - SCM fluid_vector, tmp; - size_t fluid_num; - - fluid_num = FLUID_NUM (fluid); - - fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate); - - if (SCM_UNLIKELY (fluid_num >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector))) - { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (dynstate); - - fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate); - } - - tmp = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num); - SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, SCM_VARIABLE_REF (value_box)); - SCM_VARIABLE_SET (value_box, tmp); + SCM val = fluid_ref (dynstate, fluid); + fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box)); + SCM_VARIABLE_SET (value_box, val); } SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, @@ -395,9 +434,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 f = SCM_CAR (data); - SCM t = fluid_ref (f); - scm_fluid_set_x (f, SCM_CDR (data)); + SCM t = fluid_ref (dynstate, f); + fluid_set_x (dynstate, f, SCM_CDR (data)); SCM_SETCDR (data, t); } @@ -410,28 +450,12 @@ scm_dynwind_fluid (SCM fluid, SCM value) } SCM -scm_i_make_initial_dynamic_state () -{ - SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F); - return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); -} - -SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0, - (SCM parent), - "Return a copy of the dynamic state object @var{parent}\n" - "or of the current dynamic state when @var{parent} is omitted.") -#define FUNC_NAME s_scm_make_dynamic_state +scm_i_make_initial_dynamic_state (void) { - SCM fluids; - - if (SCM_UNBNDP (parent)) - parent = scm_current_dynamic_state (); - - SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME); - fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent)); - return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); + return scm_cell (scm_tc7_dynamic_state, + SCM_UNPACK (scm_c_make_weak_table + (0, SCM_WEAK_TABLE_KIND_KEY))); } -#undef FUNC_NAME SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0, (SCM obj), @@ -439,22 +463,25 @@ SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0, "return @code{#f} otherwise") #define FUNC_NAME s_scm_dynamic_state_p { - return scm_from_bool (IS_DYNAMIC_STATE (obj)); + return scm_from_bool (is_dynamic_state (obj)); } #undef FUNC_NAME int scm_is_dynamic_state (SCM obj) { - return IS_DYNAMIC_STATE (obj); + return is_dynamic_state (obj); } SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0, (), - "Return the current dynamic state object.") + "Return a snapshot of the current fluid-value associations\n" + "as a fresh dynamic state object.") #define FUNC_NAME s_scm_current_dynamic_state { - return SCM_I_CURRENT_THREAD->dynamic_state; + struct scm_dynamic_state *state = SCM_I_CURRENT_THREAD->dynamic_state; + return scm_cell (scm_tc7_dynamic_state, + SCM_UNPACK (save_dynamic_state (state))); } #undef FUNC_NAME @@ -465,9 +492,9 @@ SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0, #define FUNC_NAME s_scm_set_current_dynamic_state { scm_i_thread *t = SCM_I_CURRENT_THREAD; - SCM old = t->dynamic_state; - SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME); - t->dynamic_state = state; + SCM old = scm_current_dynamic_state (); + SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, FUNC_NAME); + restore_dynamic_state (get_dynamic_state (state), t->dynamic_state); return old; } #undef FUNC_NAME @@ -482,7 +509,7 @@ void scm_dynwind_current_dynamic_state (SCM state) { SCM loc = scm_cons (state, SCM_EOL); - SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL); + SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, NULL); scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc, SCM_F_WIND_EXPLICITLY); scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc, diff --git a/libguile/fluids.h b/libguile/fluids.h index 2292e40e2..8031c0d48 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -35,17 +35,19 @@ code. When a new dynamic state is constructed, it inherits the values from its parent. Because each thread executes with its own dynamic state, you can use fluids for thread local storage. - - Each fluid is identified by a small integer. This integer is used to - index a vector that holds the values of all fluids. A dynamic state - consists of this vector, wrapped in an object so that the vector can - grow. */ #define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid)) + #ifdef BUILDING_LIBGUILE -#define SCM_I_FLUID_NUM(x) ((size_t)(SCM_CELL_WORD_0 (x) >> 8)) -#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x)) +# include <libguile/cache-internal.h> + +struct scm_dynamic_state +{ + SCM values; + uint8_t has_aliased_values; + struct scm_cache cache; +}; #endif SCM_API SCM scm_make_fluid (void); @@ -58,7 +60,8 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); SCM_API SCM scm_fluid_unset_x (SCM fluid); SCM_API SCM scm_fluid_bound_p (SCM fluid); -SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, SCM dynamic_state); +SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, + scm_t_dynamic_state *dynamic_state); SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *cdata); @@ -69,12 +72,6 @@ SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk); SCM_API void scm_dynwind_fluid (SCM fluid, SCM value); -#ifdef BUILDING_LIBGUILE -#define SCM_I_DYNAMIC_STATE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_dynamic_state)) -#define SCM_I_DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x)) -#endif - -SCM_API SCM scm_make_dynamic_state (SCM parent); SCM_API SCM scm_dynamic_state_p (SCM obj); SCM_API int scm_is_dynamic_state (SCM obj); SCM_API SCM scm_current_dynamic_state (void); diff --git a/libguile/threads.c b/libguile/threads.c index 28f6cf4ea..91b18b43a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -372,25 +372,7 @@ static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZE static scm_i_thread *all_threads = NULL; static int thread_count; -static SCM scm_i_default_dynamic_state; - -/* Run when a fluid is collected. */ -void -scm_i_reset_fluid (size_t n) -{ - scm_i_thread *t; - - scm_i_pthread_mutex_lock (&thread_admin_mutex); - for (t = all_threads; t; t = t->next_thread) - if (SCM_I_DYNAMIC_STATE_P (t->dynamic_state)) - { - SCM v = SCM_I_DYNAMIC_STATE_FLUIDS (t->dynamic_state); - - if (n < SCM_SIMPLE_VECTOR_LENGTH (v)) - SCM_SIMPLE_VECTOR_SET (v, n, SCM_UNDEFINED); - } - scm_i_pthread_mutex_unlock (&thread_admin_mutex); -} +static SCM default_dynamic_state; /* Perform first stage of thread initialisation, in non-guile mode. */ @@ -409,7 +391,7 @@ guilify_self_1 (struct GC_stack_base *base) t.result = SCM_BOOL_F; t.freelists = NULL; t.pointerless_freelists = NULL; - t.dynamic_state = SCM_BOOL_F; + t.dynamic_state = NULL; t.dynstack.base = NULL; t.dynstack.top = NULL; t.dynstack.limit = NULL; @@ -463,7 +445,7 @@ guilify_self_1 (struct GC_stack_base *base) /* Perform second stage of thread initialisation, in guile mode. */ static void -guilify_self_2 (SCM parent) +guilify_self_2 (SCM dynamic_state) { scm_i_thread *t = SCM_I_CURRENT_THREAD; @@ -480,10 +462,8 @@ guilify_self_2 (SCM parent) t->pointerless_freelists = scm_gc_malloc (size, "atomic freelists"); } - if (scm_is_true (parent)) - t->dynamic_state = scm_make_dynamic_state (parent); - else - t->dynamic_state = scm_i_make_initial_dynamic_state (); + t->dynamic_state = scm_gc_typed_calloc (scm_t_dynamic_state); + scm_set_current_dynamic_state (dynamic_state); t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack"); t->dynstack.limit = t->dynstack.base + 16; @@ -557,8 +537,7 @@ init_thread_key (void) BASE is the stack base to use with GC. - PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in - which case the default dynamic state is used. + DYNAMIC_STATE is the set of fluid values to start with. Returns zero when the thread was known to guile already; otherwise return 1. @@ -569,7 +548,8 @@ init_thread_key (void) be sure. New threads are put into guile mode implicitly. */ static int -scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) +scm_i_init_thread_for_guile (struct GC_stack_base *base, + SCM dynamic_state) { scm_i_pthread_once (&init_thread_key_once, init_thread_key); @@ -612,7 +592,7 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) #endif guilify_self_1 (base); - guilify_self_2 (parent); + guilify_self_2 (dynamic_state); } return 1; } @@ -624,8 +604,7 @@ scm_init_guile () struct GC_stack_base stack_base; if (GC_get_stack_base (&stack_base) == GC_SUCCESS) - scm_i_init_thread_for_guile (&stack_base, - scm_i_default_dynamic_state); + scm_i_init_thread_for_guile (&stack_base, default_dynamic_state); else { fprintf (stderr, "Failed to get stack base for current thread.\n"); @@ -637,7 +616,7 @@ struct with_guile_args { GC_fn_type func; void *data; - SCM parent; + SCM dynamic_state; }; static void * @@ -649,14 +628,14 @@ with_guile_trampoline (void *data) } static void * -with_guile_and_parent (struct GC_stack_base *base, void *data) +with_guile (struct GC_stack_base *base, void *data) { void *res; int new_thread; scm_i_thread *t; struct with_guile_args *args = data; - new_thread = scm_i_init_thread_for_guile (base, args->parent); + new_thread = scm_i_init_thread_for_guile (base, args->dynamic_state); t = SCM_I_CURRENT_THREAD; if (new_thread) { @@ -698,22 +677,21 @@ with_guile_and_parent (struct GC_stack_base *base, void *data) } static void * -scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) +scm_i_with_guile (void *(*func)(void *), void *data, SCM dynamic_state) { struct with_guile_args args; args.func = func; args.data = data; - args.parent = parent; + args.dynamic_state = dynamic_state; - return GC_call_with_stack_base (with_guile_and_parent, &args); + return GC_call_with_stack_base (with_guile, &args); } void * scm_with_guile (void *(*func)(void *), void *data) { - return scm_i_with_guile_and_parent (func, data, - scm_i_default_dynamic_state); + return scm_i_with_guile (func, data, default_dynamic_state); } void * @@ -753,7 +731,7 @@ scm_call_with_new_thread (SCM thunk, SCM handler) } typedef struct { - SCM parent; + SCM dynamic_state; SCM thunk; } launch_data; @@ -769,7 +747,7 @@ launch_thread (void *d) { launch_data *data = (launch_data *)d; scm_i_pthread_detach (scm_i_pthread_self ()); - scm_i_with_guile_and_parent (really_launch, d, data->parent); + scm_i_with_guile (really_launch, d, data->dynamic_state); return NULL; } @@ -786,7 +764,7 @@ SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0, GC_collect_a_little (); data = scm_gc_typed_calloc (launch_data); - data->parent = scm_current_dynamic_state (); + data->dynamic_state = scm_current_dynamic_state (); data->thunk = thunk; err = scm_i_pthread_create (&id, NULL, launch_thread, data); if (err) @@ -1792,8 +1770,8 @@ scm_init_threads () sizeof (struct scm_cond)); scm_set_smob_print (scm_tc16_condvar, scm_cond_print); - scm_i_default_dynamic_state = SCM_BOOL_F; - guilify_self_2 (SCM_BOOL_F); + default_dynamic_state = SCM_BOOL_F; + guilify_self_2 (scm_i_make_initial_dynamic_state ()); threads_initialized_p = 1; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, @@ -1804,8 +1782,7 @@ scm_init_threads () void scm_init_threads_default_dynamic_state () { - SCM state = scm_make_dynamic_state (scm_current_dynamic_state ()); - scm_i_default_dynamic_state = state; + default_dynamic_state = scm_current_dynamic_state (); } diff --git a/libguile/threads.h b/libguile/threads.h index e8e56e71f..e09a2ef3a 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -72,7 +72,7 @@ typedef struct scm_i_thread { /* Other thread local things. */ - SCM dynamic_state; + scm_t_dynamic_state *dynamic_state; /* The dynamic stack. */ scm_t_dynstack dynstack; @@ -126,7 +126,6 @@ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, SCM_API void *scm_without_guile (void *(*func)(void *), void *data); SCM_API void *scm_with_guile (void *(*func)(void *), void *data); -SCM_INTERNAL void scm_i_reset_fluid (size_t); SCM_INTERNAL void scm_threads_prehistory (void *); SCM_INTERNAL void scm_init_threads (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); diff --git a/libguile/throw.c b/libguile/throw.c index 45bab7a70..a6a95bab1 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -76,7 +76,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) SCM eh, prompt_tag; SCM res; scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; - SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; + scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; scm_i_jmp_buf registers; scm_t_ptrdiff saved_stack_depth; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 03cca8d44..1ee21642f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -403,7 +403,7 @@ #define VM_VALIDATE_BYTEVECTOR(x, proc) \ VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) #define VM_VALIDATE_CHAR(x, proc) \ - VM_VALIDATE (x, SCM_CHARP, proc, char); + VM_VALIDATE (x, SCM_CHARP, proc, char) #define VM_VALIDATE_PAIR(x, proc) \ VM_VALIDATE (x, scm_is_pair, proc, pair) #define VM_VALIDATE_STRING(obj, proc) \ @@ -2166,30 +2166,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (74, fluid_ref, "fluid-ref", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; - size_t num; - SCM fluid, fluids; + SCM fluid; + struct scm_cache_entry *entry; UNPACK_12_12 (op, dst, src); fluid = SP_REF (src); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) - || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid) + && !SCM_UNBNDP (SCM_PACK (entry->value)))) { - /* Punt dynstate expansion and error handling to the C proc. */ - SYNC_IP (); - SP_SET (dst, scm_fluid_ref (fluid)); + SP_SET (dst, SCM_PACK (entry->value)); + NEXT (1); } else { - SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); - if (scm_is_eq (val, SCM_UNDEFINED)) - val = SCM_I_FLUID_DEFAULT (fluid); - VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), - vm_error_unbound_fluid (fluid)); - SP_SET (dst, val); + SYNC_IP (); + SP_SET (dst, scm_fluid_ref (fluid)); + NEXT (1); } - - NEXT (1); } /* fluid-set fluid:12 val:12 @@ -2199,23 +2195,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (75, fluid_set, "fluid-set!", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; - size_t num; - SCM fluid, fluids; + SCM fluid, value; + struct scm_cache_entry *entry; UNPACK_12_12 (op, a, b); fluid = SP_REF (a); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) - || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + value = SP_REF (b); + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid))) { - /* Punt dynstate expansion and error handling to the C proc. */ - SYNC_IP (); - scm_fluid_set_x (fluid, SP_REF (b)); + entry->value = SCM_UNPACK (value); + NEXT (1); } else - SCM_SIMPLE_VECTOR_SET (fluids, num, SP_REF (b)); - - NEXT (1); + { + SYNC_IP (); + scm_fluid_set_x (fluid, value); + NEXT (1); + } } diff --git a/libguile/vm.c b/libguile/vm.c index 3c616205b..cc7bbf158 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -37,7 +37,7 @@ #include "libguile/_scm.h" #include "libguile/atomic.h" #include "libguile/atomics-internal.h" -#include "libguile/control.h" +#include "libguile/cache-internal.h" #include "libguile/control.h" #include "libguile/frames.h" #include "libguile/gc-inline.h" @@ -434,7 +434,6 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, static void vm_error (const char *msg, SCM arg) SCM_NORETURN; static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE; -static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; @@ -480,14 +479,6 @@ vm_error_unbound (SCM sym) } static void -vm_error_unbound_fluid (SCM fluid) -{ - scm_error_scm (scm_misc_error_key, SCM_BOOL_F, - scm_from_latin1_string ("Unbound fluid: ~s"), - scm_list_1 (fluid), SCM_BOOL_F); -} - -static void vm_error_not_a_variable (const char *func_name, SCM x) { scm_error (scm_arg_type_key, func_name, "Not a variable: ~S", |