1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
2 * 2011, 2012, 2013 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "libguile/_scm.h"
28 #include "libguile/print.h"
29 #include "libguile/dynwind.h"
30 #include "libguile/fluids.h"
31 #include "libguile/alist.h"
32 #include "libguile/eval.h"
33 #include "libguile/ports.h"
34 #include "libguile/deprecation.h"
35 #include "libguile/validate.h"
36 #include "libguile/bdw-gc.h"
38 /* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */
39 #define FLUID_GROW 128
41 /* Vector of allocated fluids indexed by fluid numbers. Access is protected by
43 static void **allocated_fluids
= NULL
;
44 static size_t allocated_fluids_len
= 0;
46 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
48 #define IS_FLUID(x) SCM_FLUID_P (x)
49 #define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
51 #define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x)
52 #define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x)
53 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
57 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may
58 be more than necessary since ALLOCATED_FLUIDS is sparse and the current
59 thread may not access all the fluids anyway. Memory usage could be improved
60 by using a 2-level array as is done in glibc for pthread keys (TODO). */
62 grow_dynamic_state (SCM state
)
65 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
66 size_t i
, len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
68 /* Assume the assignment below is atomic. */
69 len
= allocated_fluids_len
;
71 new_fluids
= scm_c_make_vector (len
, SCM_UNDEFINED
);
73 for (i
= 0; i
< old_len
; i
++)
74 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
75 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
76 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
80 scm_i_fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
82 scm_puts_unlocked ("#<fluid ", port
);
83 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
84 scm_putc_unlocked ('>', port
);
88 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
90 scm_puts_unlocked ("#<dynamic-state ", port
);
91 scm_intprint (SCM_UNPACK (exp
), 16, port
);
92 scm_putc_unlocked ('>', port
);
96 /* Return a new fluid. */
103 /* Fluids hold the type tag and the fluid number in the first word,
104 and the default value in the second word. */
105 fluid
= scm_cell (scm_tc7_fluid
, SCM_UNPACK (init
));
106 SCM_SET_CELL_TYPE (fluid
, scm_tc7_fluid
);
108 scm_dynwind_begin (0);
109 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
111 for (trial
= 0; trial
< 2; trial
++)
113 /* Look for a free fluid number. */
114 for (n
= 0; n
< allocated_fluids_len
; n
++)
115 /* TODO: Use `__sync_bool_compare_and_swap' where available. */
116 if (allocated_fluids
[n
] == NULL
)
119 if (trial
== 0 && n
>= allocated_fluids_len
)
120 /* All fluid numbers are in use. Run a GC and retry. Explicitly
121 running the GC is costly and bad-style. We only do this because
122 dynamic state fluid vectors would grow unreasonably if fluid numbers
127 if (n
>= allocated_fluids_len
)
129 /* Grow the vector of allocated fluids. */
130 void **new_allocated_fluids
=
131 scm_gc_malloc_pointerless ((allocated_fluids_len
+ FLUID_GROW
)
132 * sizeof (*allocated_fluids
),
135 /* Copy over old values and initialize rest. GC can not run
136 during these two operations since there is no safe point in
138 memcpy (new_allocated_fluids
, allocated_fluids
,
139 allocated_fluids_len
* sizeof (*allocated_fluids
));
140 memset (new_allocated_fluids
+ allocated_fluids_len
, 0,
141 FLUID_GROW
* sizeof (*allocated_fluids
));
142 n
= allocated_fluids_len
;
144 /* Update the vector of allocated fluids. Dynamic states will
145 eventually be lazily grown to accomodate the new value of
146 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
147 allocated_fluids
= new_allocated_fluids
;
148 allocated_fluids_len
+= FLUID_GROW
;
151 allocated_fluids
[n
] = SCM_UNPACK_POINTER (fluid
);
152 SCM_SET_CELL_WORD_0 (fluid
, (scm_tc7_fluid
| (n
<< 8)));
154 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
159 /* Now null out values. We could (and probably should) do this when
160 the fluid is collected instead of now. */
161 scm_i_reset_fluid (n
);
167 scm_make_fluid (void)
169 return new_fluid (SCM_BOOL_F
);
172 SCM_DEFINE (scm_make_fluid_with_default
, "make-fluid", 0, 1, 0,
174 "Return a newly created fluid, whose initial value is @var{dflt},\n"
175 "or @code{#f} if @var{dflt} is not given.\n"
176 "Fluids are objects that can hold one\n"
177 "value per dynamic state. That is, modifications to this value are\n"
178 "only visible to code that executes with the same dynamic state as\n"
179 "the modifying code. When a new dynamic state is constructed, it\n"
180 "inherits the values from its parent. Because each thread normally executes\n"
181 "with its own dynamic state, you can use fluids for thread local storage.")
182 #define FUNC_NAME s_scm_make_fluid_with_default
184 return new_fluid (SCM_UNBNDP (dflt
) ? SCM_BOOL_F
: dflt
);
188 SCM_DEFINE (scm_make_unbound_fluid
, "make-unbound-fluid", 0, 0, 0,
190 "Make a fluid that is initially unbound.")
191 #define FUNC_NAME s_scm_make_unbound_fluid
193 return new_fluid (SCM_UNDEFINED
);
197 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
199 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
201 #define FUNC_NAME s_scm_fluid_p
203 return scm_from_bool (IS_FLUID (obj
));
208 scm_is_fluid (SCM obj
)
210 return IS_FLUID (obj
);
213 /* Does not check type of `fluid'! */
215 fluid_ref (SCM fluid
)
218 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
220 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
222 /* Lazily grow the current thread's dynamic state. */
223 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
225 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
228 ret
= SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
229 if (SCM_UNBNDP (ret
))
230 return SCM_I_FLUID_DEFAULT (fluid
);
235 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
237 "Return the value associated with @var{fluid} in the current\n"
238 "dynamic root. If @var{fluid} has not been set, then return\n"
240 #define FUNC_NAME s_scm_fluid_ref
243 SCM_VALIDATE_FLUID (1, fluid
);
244 val
= fluid_ref (fluid
);
245 if (SCM_UNBNDP (val
))
246 SCM_MISC_ERROR ("unbound fluid: ~S",
252 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
253 (SCM fluid
, SCM value
),
254 "Set the value associated with @var{fluid} in the current dynamic root.")
255 #define FUNC_NAME s_scm_fluid_set_x
257 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
259 SCM_VALIDATE_FLUID (1, fluid
);
261 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
263 /* Lazily grow the current thread's dynamic state. */
264 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
266 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
269 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
270 return SCM_UNSPECIFIED
;
274 SCM_DEFINE (scm_fluid_unset_x
, "fluid-unset!", 1, 0, 0,
276 "Unset the value associated with @var{fluid}.")
277 #define FUNC_NAME s_scm_fluid_unset_x
279 /* FIXME: really unset the default value, too? The current test
280 suite demands it, but I would prefer not to. */
281 SCM_SET_CELL_OBJECT_1 (fluid
, SCM_UNDEFINED
);
282 return scm_fluid_set_x (fluid
, SCM_UNDEFINED
);
286 SCM_DEFINE (scm_fluid_bound_p
, "fluid-bound?", 1, 0, 0,
288 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
289 "Throw an error if @var{fluid} is not a fluid.")
290 #define FUNC_NAME s_scm_fluid_bound_p
293 SCM_VALIDATE_FLUID (1, fluid
);
294 val
= fluid_ref (fluid
);
295 return scm_from_bool (! (SCM_UNBNDP (val
)));
300 apply_thunk (void *thunk
)
302 return scm_call_0 (SCM_PACK (thunk
));
306 scm_swap_fluid (SCM fluid
, SCM value_box
, SCM dynstate
)
308 SCM fluid_vector
, tmp
;
311 fluid_num
= FLUID_NUM (fluid
);
313 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
315 if (SCM_UNLIKELY (fluid_num
>= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector
)))
317 /* Lazily grow the current thread's dynamic state. */
318 grow_dynamic_state (dynstate
);
320 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
323 tmp
= SCM_SIMPLE_VECTOR_REF (fluid_vector
, fluid_num
);
324 SCM_SIMPLE_VECTOR_SET (fluid_vector
, fluid_num
, SCM_VARIABLE_REF (value_box
));
325 SCM_VARIABLE_SET (value_box
, tmp
);
328 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
329 (SCM fluids
, SCM values
, SCM thunk
),
330 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
331 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
332 "number of their values to be applied. Each substitution is done\n"
333 "one after another. @var{thunk} must be a procedure with no argument.")
334 #define FUNC_NAME s_scm_with_fluids
336 return scm_c_with_fluids (fluids
, values
,
337 apply_thunk
, (void *) SCM_UNPACK (thunk
));
342 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
343 #define FUNC_NAME "scm_c_with_fluids"
347 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
349 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
350 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
352 scm_out_of_range (s_scm_with_fluids
, values
);
354 for (i
= 0; i
< flen
; i
++)
356 scm_dynstack_push_fluid (&thread
->dynstack
,
357 SCM_CAR (fluids
), SCM_CAR (values
),
358 thread
->dynamic_state
);
359 fluids
= SCM_CDR (fluids
);
360 values
= SCM_CDR (values
);
365 for (i
= 0; i
< flen
; i
++)
366 scm_dynstack_unwind_fluid (&thread
->dynstack
, thread
->dynamic_state
);
373 scm_with_fluid (SCM fluid
, SCM value
, SCM thunk
)
375 return scm_c_with_fluid (fluid
, value
,
376 apply_thunk
, (void *) SCM_UNPACK (thunk
));
380 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
381 #define FUNC_NAME "scm_c_with_fluid"
384 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
386 scm_dynstack_push_fluid (&thread
->dynstack
, fluid
, value
,
387 thread
->dynamic_state
);
389 scm_dynstack_unwind_fluid (&thread
->dynstack
, thread
->dynamic_state
);
396 swap_fluid (SCM data
)
398 SCM f
= SCM_CAR (data
);
399 SCM t
= fluid_ref (f
);
400 scm_fluid_set_x (f
, SCM_CDR (data
));
401 SCM_SETCDR (data
, t
);
405 scm_dynwind_fluid (SCM fluid
, SCM value
)
407 SCM data
= scm_cons (fluid
, value
);
408 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
409 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
413 scm_i_make_initial_dynamic_state ()
415 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
416 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
419 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
421 "Return a copy of the dynamic state object @var{parent}\n"
422 "or of the current dynamic state when @var{parent} is omitted.")
423 #define FUNC_NAME s_scm_make_dynamic_state
427 if (SCM_UNBNDP (parent
))
428 parent
= scm_current_dynamic_state ();
430 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
431 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
432 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
436 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
438 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
439 "return @code{#f} otherwise")
440 #define FUNC_NAME s_scm_dynamic_state_p
442 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
447 scm_is_dynamic_state (SCM obj
)
449 return IS_DYNAMIC_STATE (obj
);
452 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
454 "Return the current dynamic state object.")
455 #define FUNC_NAME s_scm_current_dynamic_state
457 return SCM_I_CURRENT_THREAD
->dynamic_state
;
461 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
463 "Set the current dynamic state object to @var{state}\n"
464 "and return the previous current dynamic state object.")
465 #define FUNC_NAME s_scm_set_current_dynamic_state
467 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
468 SCM old
= t
->dynamic_state
;
469 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
470 t
->dynamic_state
= state
;
476 swap_dynamic_state (SCM loc
)
478 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
482 scm_dynwind_current_dynamic_state (SCM state
)
484 SCM loc
= scm_cons (state
, SCM_EOL
);
485 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
486 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
487 SCM_F_WIND_EXPLICITLY
);
488 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
489 SCM_F_WIND_EXPLICITLY
);
493 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
496 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
497 scm_dynwind_current_dynamic_state (state
);
498 result
= func (data
);
503 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
504 (SCM state
, SCM proc
),
505 "Call @var{proc} while @var{state} is the current dynamic\n"
507 #define FUNC_NAME s_scm_with_dynamic_state
510 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
511 scm_dynwind_current_dynamic_state (state
);
512 result
= scm_call_0 (proc
);
522 #include "libguile/fluids.x"