1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008 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
25 #include "libguile/_scm.h"
26 #include "libguile/print.h"
27 #include "libguile/smob.h"
28 #include "libguile/dynwind.h"
29 #include "libguile/fluids.h"
30 #include "libguile/alist.h"
31 #include "libguile/eval.h"
32 #include "libguile/ports.h"
33 #include "libguile/deprecation.h"
34 #include "libguile/lang.h"
35 #include "libguile/validate.h"
39 /* A lot of the complexity below stems from the desire to reuse fluid
40 slots. Normally, fluids should be pretty global and long-lived
41 things, so that reusing their slots should not be overly critical,
42 but it is the right thing to do nevertheless. The code therefore
43 puts the burdon on allocating and collection fluids and keeps
44 accessing fluids lock free. This is achieved by manipulating the
45 global state of the fluid machinery mostly in single threaded
48 Reusing a fluid slot means that it must be reset to #f in all
49 dynamic states. We do this by maintaining a weak list of all
50 dynamic states, which is used after a GC to do the resetting.
52 Also, the fluid vectors in the dynamic states need to grow from
53 time to time when more fluids are created. We do this in a single
54 threaded section so that threads do not need to lock when accessing
55 a fluid in the normal way.
58 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
60 /* Protected by fluid_admin_mutex, but also accessed during GC. See
61 next_fluid_num for a discussion of this.
63 static size_t allocated_fluids_len
= 0;
64 static size_t allocated_fluids_num
= 0;
65 static char *allocated_fluids
= NULL
;
67 static scm_t_bits tc16_fluid
;
69 #define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
70 #define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
71 #define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
72 #define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
73 #define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
75 static scm_t_bits tc16_dynamic_state
;
77 #define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
78 #define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
79 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
80 #define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
81 #define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
82 #define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
84 /* Weak lists of all dynamic states and all fluids.
86 static SCM all_dynamic_states
= SCM_EOL
;
87 static SCM all_fluids
= SCM_EOL
;
89 /* Make sure that all states have the right size. This must be called
90 while fluid_admin_mutex is held.
95 SCM new_vectors
, state
;
97 /* Replacing the vector of a dynamic state must be done atomically:
98 the old values must be copied into the new vector and the new
99 vector must be installed without someone modifying the old vector
100 concurrently. Since accessing a fluid should be lock-free, we
101 need to put all threads to sleep when replacing a vector.
102 However, when being single threaded, it is best not to do much.
103 Therefore, we allocate the new vectors before going single
107 new_vectors
= SCM_EOL
;
108 for (state
= all_dynamic_states
; !scm_is_null (state
);
109 state
= DYNAMIC_STATE_NEXT (state
))
110 new_vectors
= scm_cons (scm_c_make_vector (allocated_fluids_len
,
114 scm_i_thread_put_to_sleep ();
115 for (state
= all_dynamic_states
; !scm_is_null (state
);
116 state
= DYNAMIC_STATE_NEXT (state
))
118 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
119 SCM new_fluids
= SCM_CAR (new_vectors
);
120 size_t i
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
122 for (i
= 0; i
< old_len
; i
++)
123 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
124 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
125 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
126 new_vectors
= SCM_CDR (new_vectors
);
128 scm_i_thread_wake_up ();
131 /* This is called during GC, that is, while being single threaded.
132 See next_fluid_num for a discussion why it is safe to access
133 allocated_fluids here.
136 scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED
,
137 void *dummy2 SCM_UNUSED
,
138 void *dummy3 SCM_UNUSED
)
140 SCM
*statep
, *fluidp
;
142 /* Scan all fluids and deallocate the unmarked ones.
144 fluidp
= &all_fluids
;
145 while (!scm_is_null (*fluidp
))
147 if (!SCM_GC_MARK_P (*fluidp
))
149 allocated_fluids_num
-= 1;
150 allocated_fluids
[FLUID_NUM (*fluidp
)] = 0;
151 *fluidp
= FLUID_NEXT (*fluidp
);
154 fluidp
= FLUID_NEXT_LOC (*fluidp
);
157 /* Scan all dynamic states and remove the unmarked ones. The live
158 ones are updated for unallocated fluids.
160 statep
= &all_dynamic_states
;
161 while (!scm_is_null (*statep
))
163 if (!SCM_GC_MARK_P (*statep
))
164 *statep
= DYNAMIC_STATE_NEXT (*statep
);
167 SCM fluids
= DYNAMIC_STATE_FLUIDS (*statep
);
170 len
= SCM_SIMPLE_VECTOR_LENGTH (fluids
);
171 for (i
= 0; i
< len
&& i
< allocated_fluids_len
; i
++)
172 if (allocated_fluids
[i
] == 0)
173 SCM_SIMPLE_VECTOR_SET (fluids
, i
, SCM_BOOL_F
);
175 statep
= DYNAMIC_STATE_NEXT_LOC (*statep
);
183 fluid_free (SCM fluid
)
185 /* The real work is done in scan_dynamic_states_and_fluids. We can
186 not touch allocated_fluids etc here since a smob free routine can
187 be run at any time, in any thread.
193 fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
195 scm_puts ("#<fluid ", port
);
196 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
197 scm_putc ('>', port
);
206 scm_dynwind_begin (0);
207 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
209 if ((allocated_fluids_len
> 0) &&
210 (allocated_fluids_num
== allocated_fluids_len
))
212 /* All fluid numbers are in use. Run a GC to try to free some
218 if (allocated_fluids_num
< allocated_fluids_len
)
220 for (n
= 0; n
< allocated_fluids_len
; n
++)
221 if (allocated_fluids
[n
] == 0)
226 /* During the following call, the GC might run and elements of
227 allocated_fluids might bet set to zero. Also,
228 allocated_fluids and allocated_fluids_len are used to scan
229 all dynamic states during GC. Thus we need to make sure that
230 no GC can run while updating these two variables.
233 char *prev_allocated_fluids
;
234 char *new_allocated_fluids
=
235 scm_malloc (allocated_fluids_len
+ FLUID_GROW
);
237 /* Copy over old values and initialize rest. GC can not run
238 during these two operations since there is no safe point in
241 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
242 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
243 n
= allocated_fluids_len
;
245 prev_allocated_fluids
= allocated_fluids
;
246 allocated_fluids
= new_allocated_fluids
;
247 allocated_fluids_len
+= FLUID_GROW
;
249 if (prev_allocated_fluids
!= NULL
)
250 free (prev_allocated_fluids
);
252 /* Now allocated_fluids and allocated_fluids_len are valid again
253 and we can allow GCs to occur.
255 resize_all_states ();
258 allocated_fluids_num
+= 1;
259 allocated_fluids
[n
] = 1;
265 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
267 "Return a newly created fluid.\n"
268 "Fluids are objects that can hold one\n"
269 "value per dynamic state. That is, modifications to this value are\n"
270 "only visible to code that executes with the same dynamic state as\n"
271 "the modifying code. When a new dynamic state is constructed, it\n"
272 "inherits the values from its parent. Because each thread normally executes\n"
273 "with its own dynamic state, you can use fluids for thread local storage.")
274 #define FUNC_NAME s_scm_make_fluid
278 SCM_NEWSMOB2 (fluid
, tc16_fluid
,
279 (scm_t_bits
) next_fluid_num (), SCM_UNPACK (SCM_EOL
));
281 /* The GC must not run until the fluid is properly entered into the
284 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
285 SET_FLUID_NEXT (fluid
, all_fluids
);
287 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
293 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
295 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
297 #define FUNC_NAME s_scm_fluid_p
299 return scm_from_bool (IS_FLUID (obj
));
304 scm_is_fluid (SCM obj
)
306 return IS_FLUID (obj
);
310 scm_i_fluid_num (SCM fluid
)
312 return FLUID_NUM (fluid
);
315 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
317 "Return the value associated with @var{fluid} in the current\n"
318 "dynamic root. If @var{fluid} has not been set, then return\n"
320 #define FUNC_NAME s_scm_fluid_ref
322 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
324 SCM_VALIDATE_FLUID (1, fluid
);
325 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
330 scm_i_fast_fluid_ref (size_t n
)
332 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
333 return SCM_SIMPLE_VECTOR_REF (fluids
, n
);
336 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
337 (SCM fluid
, SCM value
),
338 "Set the value associated with @var{fluid} in the current dynamic root.")
339 #define FUNC_NAME s_scm_fluid_set_x
341 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
343 SCM_VALIDATE_FLUID (1, fluid
);
344 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
345 return SCM_UNSPECIFIED
;
350 scm_i_fast_fluid_set_x (size_t n
, SCM value
)
352 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
353 SCM_SIMPLE_VECTOR_SET (fluids
, n
, value
);
357 swap_fluids (SCM data
)
359 SCM fluids
= SCM_CAR (data
), vals
= SCM_CDR (data
);
361 while (!SCM_NULL_OR_NIL_P (fluids
))
363 SCM fl
= SCM_CAR (fluids
);
364 SCM old_val
= scm_fluid_ref (fl
);
365 scm_fluid_set_x (fl
, SCM_CAR (vals
));
366 SCM_SETCAR (vals
, old_val
);
367 fluids
= SCM_CDR (fluids
);
368 vals
= SCM_CDR (vals
);
372 /* Swap the fluid values in reverse order. This is important when the
373 same fluid appears multiple times in the fluids list.
377 swap_fluids_reverse_aux (SCM fluids
, SCM vals
)
379 if (!SCM_NULL_OR_NIL_P (fluids
))
383 swap_fluids_reverse_aux (SCM_CDR (fluids
), SCM_CDR (vals
));
384 fl
= SCM_CAR (fluids
);
385 old_val
= scm_fluid_ref (fl
);
386 scm_fluid_set_x (fl
, SCM_CAR (vals
));
387 SCM_SETCAR (vals
, old_val
);
392 swap_fluids_reverse (SCM data
)
394 swap_fluids_reverse_aux (SCM_CAR (data
), SCM_CDR (data
));
398 apply_thunk (void *thunk
)
400 return scm_call_0 (SCM_PACK (thunk
));
403 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
404 (SCM fluids
, SCM values
, SCM thunk
),
405 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
406 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
407 "number of their values to be applied. Each substitution is done\n"
408 "one after another. @var{thunk} must be a procedure with no argument.")
409 #define FUNC_NAME s_scm_with_fluids
411 return scm_c_with_fluids (fluids
, values
,
412 apply_thunk
, (void *) SCM_UNPACK (thunk
));
417 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
418 #define FUNC_NAME "scm_c_with_fluids"
423 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
424 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
426 scm_out_of_range (s_scm_with_fluids
, values
);
429 return scm_c_with_fluid (SCM_CAR (fluids
), SCM_CAR (values
),
432 data
= scm_cons (fluids
, values
);
433 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
434 scm_dynwind_rewind_handler_with_scm (swap_fluids
, data
,
435 SCM_F_WIND_EXPLICITLY
);
436 scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse
, data
,
437 SCM_F_WIND_EXPLICITLY
);
444 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
445 (SCM fluid
, SCM value
, SCM thunk
),
446 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
447 "@var{thunk} must be a procedure with no argument.")
448 #define FUNC_NAME s_scm_with_fluid
450 return scm_c_with_fluid (fluid
, value
,
451 apply_thunk
, (void *) SCM_UNPACK (thunk
));
456 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
457 #define FUNC_NAME "scm_c_with_fluid"
461 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
462 scm_dynwind_fluid (fluid
, value
);
470 swap_fluid (SCM data
)
472 SCM f
= SCM_CAR (data
);
473 SCM t
= scm_fluid_ref (f
);
474 scm_fluid_set_x (f
, SCM_CDR (data
));
475 SCM_SETCDR (data
, t
);
479 scm_dynwind_fluid (SCM fluid
, SCM value
)
481 SCM data
= scm_cons (fluid
, value
);
482 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
483 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
487 scm_i_make_initial_dynamic_state ()
489 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
491 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
492 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
493 all_dynamic_states
= state
;
497 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
499 "Return a copy of the dynamic state object @var{parent}\n"
500 "or of the current dynamic state when @var{parent} is omitted.")
501 #define FUNC_NAME s_scm_make_dynamic_state
505 if (SCM_UNBNDP (parent
))
506 parent
= scm_current_dynamic_state ();
508 scm_assert_smob_type (tc16_dynamic_state
, parent
);
509 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
510 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
511 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
513 /* The GC must not run until the state is properly entered into the
516 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
517 SET_DYNAMIC_STATE_NEXT (state
, all_dynamic_states
);
518 all_dynamic_states
= state
;
519 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
525 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
527 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
528 "return @code{#f} otherwise")
529 #define FUNC_NAME s_scm_dynamic_state_p
531 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
536 scm_is_dynamic_state (SCM obj
)
538 return IS_DYNAMIC_STATE (obj
);
541 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
543 "Return the current dynamic state object.")
544 #define FUNC_NAME s_scm_current_dynamic_state
546 return SCM_I_CURRENT_THREAD
->dynamic_state
;
550 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
552 "Set the current dynamic state object to @var{state}\n"
553 "and return the previous current dynamic state object.")
554 #define FUNC_NAME s_scm_set_current_dynamic_state
556 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
557 SCM old
= t
->dynamic_state
;
558 scm_assert_smob_type (tc16_dynamic_state
, state
);
559 t
->dynamic_state
= state
;
565 swap_dynamic_state (SCM loc
)
567 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
571 scm_dynwind_current_dynamic_state (SCM state
)
573 SCM loc
= scm_cons (state
, SCM_EOL
);
574 scm_assert_smob_type (tc16_dynamic_state
, state
);
575 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
576 SCM_F_WIND_EXPLICITLY
);
577 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
578 SCM_F_WIND_EXPLICITLY
);
582 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
585 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
586 scm_dynwind_current_dynamic_state (state
);
587 result
= func (data
);
592 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
593 (SCM state
, SCM proc
),
594 "Call @var{proc} while @var{state} is the current dynamic\n"
596 #define FUNC_NAME s_scm_with_dynamic_state
599 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
600 scm_dynwind_current_dynamic_state (state
);
601 result
= scm_call_0 (proc
);
608 scm_fluids_prehistory ()
610 tc16_fluid
= scm_make_smob_type ("fluid", 0);
611 scm_set_smob_free (tc16_fluid
, fluid_free
);
612 scm_set_smob_print (tc16_fluid
, fluid_print
);
614 tc16_dynamic_state
= scm_make_smob_type ("dynamic-state", 0);
615 scm_set_smob_mark (tc16_dynamic_state
, scm_markcdr
);
617 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_dynamic_states_and_fluids
,
624 #include "libguile/fluids.x"