-/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
+ * 2011, 2012, 2013 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
#include <stdio.h>
#include <string.h>
-#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/print.h"
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/deprecation.h"
-#include "libguile/lang.h"
#include "libguile/validate.h"
+#include "libguile/bdw-gc.h"
-#define FLUID_GROW 20
-
-/* A lot of the complexity below stems from the desire to reuse fluid
- slots. Normally, fluids should be pretty global and long-lived
- things, so that reusing their slots should not be overly critical,
- but it is the right thing to do nevertheless. The code therefore
- puts the burdon on allocating and collection fluids and keeps
- accessing fluids lock free. This is achieved by manipulating the
- global state of the fluid machinery mostly in single threaded
- sections.
-
- Reusing a fluid slot means that it must be reset to #f in all
- dynamic states. We do this by maintaining a weak list of all
- dynamic states, which is used after a GC to do the resetting.
-
- Also, the fluid vectors in the dynamic states need to grow from
- time to time when more fluids are created. We do this in a single
- threaded section so that threads do not need to lock when accessing
- a fluid in the normal way.
-*/
-
-static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+/* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */
+#define FLUID_GROW 128
-/* Protected by fluid_admin_mutex, but also accessed during GC. See
- next_fluid_num for a discussion of this.
- */
+/* 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 size_t allocated_fluids_num = 0;
-static char *allocated_fluids = NULL;
-#define IS_FLUID(x) SCM_I_FLUID_P (x)
+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)
\f
-/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
+/* 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)
{
SCM new_fluids;
SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
- size_t i, new_len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
+ size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
- retry:
- new_len = allocated_fluids_num;
- new_fluids = scm_c_make_vector (new_len, SCM_BOOL_F);
+ /* Assume the assignment below is atomic. */
+ len = allocated_fluids_len;
- scm_i_pthread_mutex_lock (&fluid_admin_mutex);
- if (new_len != allocated_fluids_num)
- {
- /* We lost the race. */
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
- goto retry;
- }
-
- assert (allocated_fluids_num > old_len);
+ 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);
-
- scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
}
void
scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<fluid ", port);
+ scm_puts_unlocked ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<dynamic-state ", port);
+ scm_puts_unlocked ("#<dynamic-state ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
-static size_t
-next_fluid_num ()
+\f
+/* Return a new fluid. */
+static SCM
+new_fluid (SCM init)
{
- size_t n;
+ 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);
- if ((allocated_fluids_len > 0) &&
- (allocated_fluids_num == allocated_fluids_len))
- {
- /* All fluid numbers are in use. Run a GC to try to free some
- up.
- */
- scm_gc ();
- }
-
- if (allocated_fluids_num < allocated_fluids_len)
+ for (trial = 0; trial < 2; trial++)
{
+ /* Look for a free fluid number. */
for (n = 0; n < allocated_fluids_len; n++)
- if (allocated_fluids[n] == 0)
+ /* TODO: Use `__sync_bool_compare_and_swap' where available. */
+ if (allocated_fluids[n] == NULL)
break;
+
+ if (trial == 0 && n >= 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");
}
- else
+
+ if (n >= allocated_fluids_len)
{
/* Grow the vector of allocated fluids. */
- /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
- the GC; therefore, all fluids remain reachable for the entire
- program lifetime. Hopefully this is not a problem in practice. */
- char *new_allocated_fluids =
- scm_gc_malloc (allocated_fluids_len + FLUID_GROW,
- "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);
- memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
+ 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
allocated_fluids = new_allocated_fluids;
allocated_fluids_len += FLUID_GROW;
}
-
- allocated_fluids_num += 1;
- allocated_fluids[n] = 1;
-
+
+ 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 ();
- return n;
+
+ /* 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;
}
-SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
- (),
- "Return a newly created fluid.\n"
+SCM
+scm_make_fluid (void)
+{
+ return new_fluid (SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
+ (SCM dflt),
+ "Return a newly created fluid, whose initial value is @var{dflt},\n"
+ "or @code{#f} if @var{dflt} is not given.\n"
"Fluids are objects that can hold one\n"
"value per dynamic state. That is, modifications to this value are\n"
"only visible to code that executes with the same dynamic state as\n"
"the modifying code. When a new dynamic state is constructed, it\n"
"inherits the values from its parent. Because each thread normally executes\n"
"with its own dynamic state, you can use fluids for thread local storage.")
-#define FUNC_NAME s_scm_make_fluid
+#define FUNC_NAME s_scm_make_fluid_with_default
+{
+ return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0,
+ (),
+ "Make a fluid that is initially unbound.")
+#define FUNC_NAME s_scm_make_unbound_fluid
{
- return scm_cell (scm_tc7_fluid, (scm_t_bits) next_fluid_num ());
+ return new_fluid (SCM_UNDEFINED);
}
#undef FUNC_NAME
return IS_FLUID (obj);
}
-
-
-SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
- (SCM fluid),
- "Return the value associated with @var{fluid} in the current\n"
- "dynamic root. If @var{fluid} has not been set, then return\n"
- "@code{#f}.")
-#define FUNC_NAME s_scm_fluid_ref
+/* Does not check type of `fluid'! */
+static SCM
+fluid_ref (SCM fluid)
{
+ SCM ret;
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)))
{
- /* We should only get there when the current thread's dynamic state
- turns out to be too small compared to the set of currently allocated
- fluids. */
- assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
-
/* 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);
}
- return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
+ ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
+ if (SCM_UNBNDP (ret))
+ return SCM_I_FLUID_DEFAULT (fluid);
+ else
+ return ret;
+}
+
+SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
+ (SCM fluid),
+ "Return the value associated with @var{fluid} in the current\n"
+ "dynamic root. If @var{fluid} has not been set, then return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_ref
+{
+ SCM val;
+ 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;
}
#undef FUNC_NAME
if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
{
- /* We should only get there when the current thread's dynamic state
- turns out to be too small compared to the set of currently allocated
- fluids. */
- assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
-
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
}
#undef FUNC_NAME
+SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
+ (SCM fluid),
+ "Unset the value associated with @var{fluid}.")
+#define FUNC_NAME s_scm_fluid_unset_x
+{
+ /* FIXME: really unset the default value, too? The current test
+ suite demands it, but I would prefer not to. */
+ SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED);
+ return scm_fluid_set_x (fluid, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0,
+ (SCM fluid),
+ "Return @code{#t} iff @var{fluid} is bound to a value.\n"
+ "Throw an error if @var{fluid} is not a fluid.")
+#define FUNC_NAME s_scm_fluid_bound_p
+{
+ SCM val;
+ SCM_VALIDATE_FLUID (1, fluid);
+ val = fluid_ref (fluid);
+ return scm_from_bool (! (SCM_UNBNDP (val)));
+}
+#undef FUNC_NAME
+
static SCM
apply_thunk (void *thunk)
{
return scm_call_0 (SCM_PACK (thunk));
}
-SCM
-scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
+size_t
+scm_prepare_fluids (size_t n, SCM *fluids, SCM *values)
{
- SCM ret;
+ size_t j;
/* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
but N will usually be small, so perhaps that's OK. */
- {
- size_t i, j = n;
+ for (j = n; j--;)
+ {
+ size_t i;
+
+ if (SCM_UNLIKELY (!IS_FLUID (fluids[j])))
+ scm_wrong_type_arg ("with-fluids", 0, fluids[j]);
- while (j--)
- for (i = 0; i < j; i++)
- if (fluids[i] == fluids[j])
+ for (i = j; i--;)
+ if (scm_is_eq (fluids[i], fluids[j]))
{
- vals[i] = vals[j]; /* later bindings win */
+ values[i] = values[j]; /* later bindings win */
n--;
+ fluids[j] = fluids[n];
+ values[j] = values[n];
break;
}
- }
-
- ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
- SCM_SET_CELL_WORD_1 (ret, n);
-
- while (n--)
- {
- if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
- scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
}
- return ret;
+ return n;
}
void
-scm_i_swap_with_fluids (SCM wf, SCM dynstate)
+scm_swap_fluids (size_t n, SCM *fluids, SCM *values, SCM dynstate)
{
- SCM fluids;
+ SCM fluid_vector;
size_t i, max = 0;
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
/* We could cache the max in the with-fluids, but that would take more mem,
and we're touching all the fluids anyway, so this per-swap traversal should
be OK. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+ for (i = 0; i < n; i++)
{
- size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
+ size_t num = FLUID_NUM (fluids[i]);
max = (max > num) ? max : num;
}
- if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
{
- /* We should only get there when the current thread's dynamic state turns
- out to be too small compared to the set of currently allocated
- fluids. */
- assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
-
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (dynstate);
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
}
/* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
+ for (i = 0; i < n; i++)
{
size_t fluid_num;
SCM x;
- fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
- x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
- SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
- SCM_WITH_FLUIDS_NTH_VAL (wf, i));
- SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
+ fluid_num = FLUID_NUM (fluids[i]);
+ x = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
+ SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, values[i]);
+ values[i] = x;
}
}
scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluids"
{
- SCM wf, ans;
+ SCM ans;
long flen, vlen, i;
SCM *fluidsv, *valuesv;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
values = SCM_CDR (values);
}
- wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluids (&thread->dynstack, flen, fluidsv, valuesv,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return ans;
}
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluid"
{
- SCM ans, wf;
+ SCM ans;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
- wf = scm_i_make_with_fluids (1, &fluid, &value);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &value,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
return ans;
}
swap_fluid (SCM data)
{
SCM f = SCM_CAR (data);
- SCM t = scm_fluid_ref (f);
+ SCM t = fluid_ref (f);
scm_fluid_set_x (f, SCM_CDR (data));
SCM_SETCDR (data, t);
}
HCoop / bpt / guile.git / blobdiff