1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 #include "libguile/_scm.h"
22 #include "libguile/print.h"
23 #include "libguile/smob.h"
24 #include "libguile/dynwind.h"
25 #include "libguile/fluids.h"
26 #include "libguile/alist.h"
27 #include "libguile/eval.h"
28 #include "libguile/ports.h"
29 #include "libguile/deprecation.h"
30 #include "libguile/lang.h"
31 #include "libguile/validate.h"
35 /* A lot of the complexity below stems from the desire to reuse fluid
36 slots. Normally, fluids should be pretty global and long-lived
37 things, so that reusing their slots should not be overly critical,
38 but it is the right thing to do nevertheless. The code therefore
39 puts the burdon on allocating and collection fluids and keeps
40 accessing fluids lock free. This is achieved by manipulating the
41 global state of the fluid machinery mostly in single threaded
44 Reusing a fluid slot means that it must be reset to #f in all
45 dynamic states. We do this by maintaining a weak list of all
46 dynamic states, which is used after a GC to do the resetting.
48 Also, the fluid vectors in the dynamic states need to grow from
49 time to time when more fluids are created. We do this in a single
50 threaded section so that threads do not need to lock when accessing
51 a fluid in the normal way.
54 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
56 /* Protected by fluid_admin_mutex, but also accessed during GC. See
57 next_fluid_num for a discussion of this.
59 static size_t allocated_fluids_len
= 0;
60 static size_t allocated_fluids_num
= 0;
61 static char *allocated_fluids
= NULL
;
63 static scm_t_bits tc16_fluid
;
65 #define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
66 #define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
67 #define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
68 #define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
69 #define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
71 static scm_t_bits tc16_dynamic_state
;
73 #define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
74 #define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
75 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
76 #define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
77 #define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
78 #define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
80 /* Weak lists of all dynamic states and all fluids.
82 static SCM all_dynamic_states
= SCM_EOL
;
83 static SCM all_fluids
= SCM_EOL
;
85 /* Make sure that all states have the right size. This must be called
86 while fluid_admin_mutex is held.
91 SCM new_vectors
, state
;
93 /* Replacing the vector of a dynamic state must be done atomically:
94 the old values must be copied into the new vector and the new
95 vector must be installed without someone modifying the old vector
96 concurrently. Since accessing a fluid should be lock-free, we
97 need to put all threads to sleep when replacing a vector.
98 However, when being single threaded, it is best not to do much.
99 Therefore, we allocate the new vectors before going single
103 new_vectors
= SCM_EOL
;
104 for (state
= all_dynamic_states
; !scm_is_null (state
);
105 state
= DYNAMIC_STATE_NEXT (state
))
106 new_vectors
= scm_cons (scm_c_make_vector (allocated_fluids_len
,
110 scm_i_thread_put_to_sleep ();
111 for (state
= all_dynamic_states
; !scm_is_null (state
);
112 state
= DYNAMIC_STATE_NEXT (state
))
114 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
115 SCM new_fluids
= SCM_CAR (new_vectors
);
116 size_t i
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
118 for (i
= 0; i
< old_len
; i
++)
119 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
120 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
121 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
122 new_vectors
= SCM_CDR (new_vectors
);
124 scm_i_thread_wake_up ();
127 /* This is called during GC, that is, while being single threaded.
128 See next_fluid_num for a discussion why it is safe to access
129 allocated_fluids here.
132 scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED
,
133 void *dummy2 SCM_UNUSED
,
134 void *dummy3 SCM_UNUSED
)
136 SCM
*statep
, *fluidp
;
138 /* Scan all fluids and deallocate the unmarked ones.
140 fluidp
= &all_fluids
;
141 while (!scm_is_null (*fluidp
))
143 if (!SCM_GC_MARK_P (*fluidp
))
145 allocated_fluids_num
-= 1;
146 allocated_fluids
[FLUID_NUM (*fluidp
)] = 0;
147 *fluidp
= FLUID_NEXT (*fluidp
);
150 fluidp
= FLUID_NEXT_LOC (*fluidp
);
153 /* Scan all dynamic states and remove the unmarked ones. The live
154 ones are updated for unallocated fluids.
156 statep
= &all_dynamic_states
;
157 while (!scm_is_null (*statep
))
159 if (!SCM_GC_MARK_P (*statep
))
160 *statep
= DYNAMIC_STATE_NEXT (*statep
);
163 SCM fluids
= DYNAMIC_STATE_FLUIDS (*statep
);
166 len
= SCM_SIMPLE_VECTOR_LENGTH (fluids
);
167 for (i
= 0; i
< len
&& i
< allocated_fluids_len
; i
++)
168 if (allocated_fluids
[i
] == 0)
169 SCM_SIMPLE_VECTOR_SET (fluids
, i
, SCM_BOOL_F
);
171 statep
= DYNAMIC_STATE_NEXT_LOC (*statep
);
179 fluid_free (SCM fluid
)
181 /* The real work is done in scan_dynamic_states_and_fluids. We can
182 not touch allocated_fluids etc here since a smob free routine can
183 be run at any time, in any thread.
189 fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
191 scm_puts ("#<fluid ", port
);
192 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
193 scm_putc ('>', port
);
202 scm_dynwind_begin (0);
203 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
205 if ((allocated_fluids_len
> 0) &&
206 (allocated_fluids_num
== allocated_fluids_len
))
208 /* All fluid numbers are in use. Run a GC to try to free some
214 if (allocated_fluids_num
< allocated_fluids_len
)
216 for (n
= 0; n
< allocated_fluids_len
; n
++)
217 if (allocated_fluids
[n
] == 0)
222 /* During the following call, the GC might run and elements of
223 allocated_fluids might bet set to zero. Also,
224 allocated_fluids and allocated_fluids_len are used to scan
225 all dynamic states during GC. Thus we need to make sure that
226 no GC can run while updating these two variables.
229 char *new_allocated_fluids
=
230 scm_malloc (allocated_fluids_len
+ FLUID_GROW
);
232 /* Copy over old values and initialize rest. GC can not run
233 during these two operations since there is no safe point in
236 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
237 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
238 n
= allocated_fluids_len
;
239 allocated_fluids
= new_allocated_fluids
;
240 allocated_fluids_len
+= FLUID_GROW
;
242 /* Now allocated_fluids and allocated_fluids_len are valid again
243 and we can allow GCs to occur.
245 resize_all_states ();
248 allocated_fluids_num
+= 1;
249 allocated_fluids
[n
] = 1;
255 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
257 "Return a newly created fluid.\n"
258 "Fluids are objects that can hold one\n"
259 "value per dynamic state. That is, modifications to this value are\n"
260 "only visible to code that executes with the same dynamic state as\n"
261 "the modifying code. When a new dynamic state is constructed, it\n"
262 "inherits the values from its parent. Because each thread normally executes\n"
263 "with its own dynamic state, you can use fluids for thread local storage.")
264 #define FUNC_NAME s_scm_make_fluid
268 SCM_NEWSMOB2 (fluid
, tc16_fluid
,
269 (scm_t_bits
) next_fluid_num (), SCM_UNPACK (SCM_EOL
));
271 /* The GC must not run until the fluid is properly entered into the
274 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
275 SET_FLUID_NEXT (fluid
, all_fluids
);
277 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
283 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
285 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
287 #define FUNC_NAME s_scm_fluid_p
289 return scm_from_bool (IS_FLUID (obj
));
294 scm_is_fluid (SCM obj
)
296 return IS_FLUID (obj
);
300 scm_i_fluid_num (SCM fluid
)
302 return FLUID_NUM (fluid
);
305 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
307 "Return the value associated with @var{fluid} in the current\n"
308 "dynamic root. If @var{fluid} has not been set, then return\n"
310 #define FUNC_NAME s_scm_fluid_ref
312 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
314 SCM_VALIDATE_FLUID (1, fluid
);
315 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
320 scm_i_fast_fluid_ref (size_t n
)
322 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
323 return SCM_SIMPLE_VECTOR_REF (fluids
, n
);
326 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
327 (SCM fluid
, SCM value
),
328 "Set the value associated with @var{fluid} in the current dynamic root.")
329 #define FUNC_NAME s_scm_fluid_set_x
331 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
333 SCM_VALIDATE_FLUID (1, fluid
);
334 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
335 return SCM_UNSPECIFIED
;
340 scm_i_fast_fluid_set_x (size_t n
, SCM value
)
342 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
343 SCM_SIMPLE_VECTOR_SET (fluids
, n
, value
);
347 swap_fluids (SCM data
)
349 SCM fluids
= SCM_CAR (data
), vals
= SCM_CDR (data
);
351 while (!SCM_NULL_OR_NIL_P (fluids
))
353 SCM fl
= SCM_CAR (fluids
);
354 SCM old_val
= scm_fluid_ref (fl
);
355 scm_fluid_set_x (fl
, SCM_CAR (vals
));
356 SCM_SETCAR (vals
, old_val
);
357 fluids
= SCM_CDR (fluids
);
358 vals
= SCM_CDR (vals
);
362 /* Swap the fluid values in reverse order. This is important when the
363 same fluid appears multiple times in the fluids list.
367 swap_fluids_reverse_aux (SCM fluids
, SCM vals
)
369 if (!SCM_NULL_OR_NIL_P (fluids
))
373 swap_fluids_reverse_aux (SCM_CDR (fluids
), SCM_CDR (vals
));
374 fl
= SCM_CAR (fluids
);
375 old_val
= scm_fluid_ref (fl
);
376 scm_fluid_set_x (fl
, SCM_CAR (vals
));
377 SCM_SETCAR (vals
, old_val
);
382 swap_fluids_reverse (SCM data
)
384 swap_fluids_reverse_aux (SCM_CAR (data
), SCM_CDR (data
));
388 apply_thunk (void *thunk
)
390 return scm_call_0 (SCM_PACK (thunk
));
393 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
394 (SCM fluids
, SCM values
, SCM thunk
),
395 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
396 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
397 "number of their values to be applied. Each substitution is done\n"
398 "one after another. @var{thunk} must be a procedure with no argument.")
399 #define FUNC_NAME s_scm_with_fluids
401 return scm_c_with_fluids (fluids
, values
,
402 apply_thunk
, (void *) SCM_UNPACK (thunk
));
407 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
408 #define FUNC_NAME "scm_c_with_fluids"
413 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
414 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
416 scm_out_of_range (s_scm_with_fluids
, values
);
419 return scm_c_with_fluid (SCM_CAR (fluids
), SCM_CAR (values
),
422 data
= scm_cons (fluids
, values
);
423 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
424 scm_dynwind_rewind_handler_with_scm (swap_fluids
, data
,
425 SCM_F_WIND_EXPLICITLY
);
426 scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse
, data
,
427 SCM_F_WIND_EXPLICITLY
);
434 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
435 (SCM fluid
, SCM value
, SCM thunk
),
436 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
437 "@var{thunk} must be a procedure with no argument.")
438 #define FUNC_NAME s_scm_with_fluid
440 return scm_c_with_fluid (fluid
, value
,
441 apply_thunk
, (void *) SCM_UNPACK (thunk
));
446 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
447 #define FUNC_NAME "scm_c_with_fluid"
451 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
452 scm_dynwind_fluid (fluid
, value
);
460 swap_fluid (SCM data
)
462 SCM f
= SCM_CAR (data
);
463 SCM t
= scm_fluid_ref (f
);
464 scm_fluid_set_x (f
, SCM_CDR (data
));
465 SCM_SETCDR (data
, t
);
469 scm_dynwind_fluid (SCM fluid
, SCM value
)
471 SCM data
= scm_cons (fluid
, value
);
472 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
473 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
477 scm_i_make_initial_dynamic_state ()
479 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
481 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
482 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
483 all_dynamic_states
= state
;
487 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
489 "Return a copy of the dynamic state object @var{parent}\n"
490 "or of the current dynamic state when @var{parent} is omitted.")
491 #define FUNC_NAME s_scm_make_dynamic_state
495 if (SCM_UNBNDP (parent
))
496 parent
= scm_current_dynamic_state ();
498 scm_assert_smob_type (tc16_dynamic_state
, parent
);
499 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
500 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
501 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
503 /* The GC must not run until the state is properly entered into the
506 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
507 SET_DYNAMIC_STATE_NEXT (state
, all_dynamic_states
);
508 all_dynamic_states
= state
;
509 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
515 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
517 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
518 "return @code{#f} otherwise")
519 #define FUNC_NAME s_scm_dynamic_state_p
521 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
526 scm_is_dynamic_state (SCM obj
)
528 return IS_DYNAMIC_STATE (obj
);
531 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
533 "Return the current dynamic state object.")
534 #define FUNC_NAME s_scm_current_dynamic_state
536 return SCM_I_CURRENT_THREAD
->dynamic_state
;
540 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
542 "Set the current dynamic state object to @var{state}\n"
543 "and return the previous current dynamic state object.")
544 #define FUNC_NAME s_scm_set_current_dynamic_state
546 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
547 SCM old
= t
->dynamic_state
;
548 scm_assert_smob_type (tc16_dynamic_state
, state
);
549 t
->dynamic_state
= state
;
555 swap_dynamic_state (SCM loc
)
557 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
561 scm_dynwind_current_dynamic_state (SCM state
)
563 SCM loc
= scm_cons (state
, SCM_EOL
);
564 scm_assert_smob_type (tc16_dynamic_state
, state
);
565 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
566 SCM_F_WIND_EXPLICITLY
);
567 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
568 SCM_F_WIND_EXPLICITLY
);
572 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
575 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
576 scm_dynwind_current_dynamic_state (state
);
577 result
= func (data
);
582 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
583 (SCM state
, SCM proc
),
584 "Call @var{proc} while @var{state} is the current dynamic\n"
586 #define FUNC_NAME s_scm_with_dynamic_state
589 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
590 scm_dynwind_current_dynamic_state (state
);
591 result
= scm_call_0 (proc
);
598 scm_fluids_prehistory ()
600 tc16_fluid
= scm_make_smob_type ("fluid", 0);
601 scm_set_smob_free (tc16_fluid
, fluid_free
);
602 scm_set_smob_print (tc16_fluid
, fluid_print
);
604 tc16_dynamic_state
= scm_make_smob_type ("dynamic-state", 0);
605 scm_set_smob_mark (tc16_dynamic_state
, scm_markcdr
);
607 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_dynamic_states_and_fluids
,
614 #include "libguile/fluids.x"