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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
26 #include "libguile/_scm.h"
27 #include "libguile/print.h"
28 #include "libguile/smob.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/lang.h"
36 #include "libguile/validate.h"
40 /* A lot of the complexity below stems from the desire to reuse fluid
41 slots. Normally, fluids should be pretty global and long-lived
42 things, so that reusing their slots should not be overly critical,
43 but it is the right thing to do nevertheless. The code therefore
44 puts the burdon on allocating and collection fluids and keeps
45 accessing fluids lock free. This is achieved by manipulating the
46 global state of the fluid machinery mostly in single threaded
49 Reusing a fluid slot means that it must be reset to #f in all
50 dynamic states. We do this by maintaining a weak list of all
51 dynamic states, which is used after a GC to do the resetting.
53 Also, the fluid vectors in the dynamic states need to grow from
54 time to time when more fluids are created. We do this in a single
55 threaded section so that threads do not need to lock when accessing
56 a fluid in the normal way.
59 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
61 /* Protected by fluid_admin_mutex, but also accessed during GC. See
62 next_fluid_num for a discussion of this.
64 static size_t allocated_fluids_len
= 0;
65 static size_t allocated_fluids_num
= 0;
66 static char *allocated_fluids
= NULL
;
68 static scm_t_bits tc16_fluid
;
70 #define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
71 #define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
72 #define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
73 #define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
74 #define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
76 static scm_t_bits tc16_dynamic_state
;
78 #define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
79 #define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
80 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
81 #define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
82 #define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
83 #define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
85 /* Weak lists of all dynamic states and all fluids.
87 static SCM all_dynamic_states
= SCM_EOL
;
88 static SCM all_fluids
= SCM_EOL
;
90 /* Make sure that all states have the right size. This must be called
91 while fluid_admin_mutex is held.
96 SCM new_vectors
, state
;
98 /* Replacing the vector of a dynamic state must be done atomically:
99 the old values must be copied into the new vector and the new
100 vector must be installed without someone modifying the old vector
101 concurrently. Since accessing a fluid should be lock-free, we
102 need to put all threads to sleep when replacing a vector.
103 However, when being single threaded, it is best not to do much.
104 Therefore, we allocate the new vectors before going single
108 new_vectors
= SCM_EOL
;
109 for (state
= all_dynamic_states
; !scm_is_null (state
);
110 state
= DYNAMIC_STATE_NEXT (state
))
111 new_vectors
= scm_cons (scm_c_make_vector (allocated_fluids_len
,
115 scm_i_thread_put_to_sleep ();
116 for (state
= all_dynamic_states
; !scm_is_null (state
);
117 state
= DYNAMIC_STATE_NEXT (state
))
119 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
120 SCM new_fluids
= SCM_CAR (new_vectors
);
121 size_t i
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
123 for (i
= 0; i
< old_len
; i
++)
124 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
125 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
126 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
127 new_vectors
= SCM_CDR (new_vectors
);
129 scm_i_thread_wake_up ();
132 /* This is called during GC, that is, while being single threaded.
133 See next_fluid_num for a discussion why it is safe to access
134 allocated_fluids here.
137 scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED
,
138 void *dummy2 SCM_UNUSED
,
139 void *dummy3 SCM_UNUSED
)
141 SCM
*statep
, *fluidp
;
143 /* Scan all fluids and deallocate the unmarked ones.
145 fluidp
= &all_fluids
;
146 while (!scm_is_null (*fluidp
))
148 if (!SCM_GC_MARK_P (*fluidp
))
150 allocated_fluids_num
-= 1;
151 allocated_fluids
[FLUID_NUM (*fluidp
)] = 0;
152 *fluidp
= FLUID_NEXT (*fluidp
);
155 fluidp
= FLUID_NEXT_LOC (*fluidp
);
158 /* Scan all dynamic states and remove the unmarked ones. The live
159 ones are updated for unallocated fluids.
161 statep
= &all_dynamic_states
;
162 while (!scm_is_null (*statep
))
164 if (!SCM_GC_MARK_P (*statep
))
165 *statep
= DYNAMIC_STATE_NEXT (*statep
);
168 SCM fluids
= DYNAMIC_STATE_FLUIDS (*statep
);
171 len
= SCM_SIMPLE_VECTOR_LENGTH (fluids
);
172 for (i
= 0; i
< len
&& i
< allocated_fluids_len
; i
++)
173 if (allocated_fluids
[i
] == 0)
174 SCM_SIMPLE_VECTOR_SET (fluids
, i
, SCM_BOOL_F
);
176 statep
= DYNAMIC_STATE_NEXT_LOC (*statep
);
184 fluid_free (SCM fluid
)
186 /* The real work is done in scan_dynamic_states_and_fluids. We can
187 not touch allocated_fluids etc here since a smob free routine can
188 be run at any time, in any thread.
194 fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
196 scm_puts ("#<fluid ", port
);
197 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
198 scm_putc ('>', port
);
207 scm_dynwind_begin (0);
208 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
210 if ((allocated_fluids_len
> 0) &&
211 (allocated_fluids_num
== allocated_fluids_len
))
213 /* All fluid numbers are in use. Run a GC to try to free some
219 if (allocated_fluids_num
< allocated_fluids_len
)
221 for (n
= 0; n
< allocated_fluids_len
; n
++)
222 if (allocated_fluids
[n
] == 0)
227 /* During the following call, the GC might run and elements of
228 allocated_fluids might bet set to zero. Also,
229 allocated_fluids and allocated_fluids_len are used to scan
230 all dynamic states during GC. Thus we need to make sure that
231 no GC can run while updating these two variables.
234 char *prev_allocated_fluids
;
235 char *new_allocated_fluids
=
236 scm_malloc (allocated_fluids_len
+ FLUID_GROW
);
238 /* Copy over old values and initialize rest. GC can not run
239 during these two operations since there is no safe point in
242 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
243 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
244 n
= allocated_fluids_len
;
246 prev_allocated_fluids
= allocated_fluids
;
247 allocated_fluids
= new_allocated_fluids
;
248 allocated_fluids_len
+= FLUID_GROW
;
250 if (prev_allocated_fluids
!= NULL
)
251 free (prev_allocated_fluids
);
253 /* Now allocated_fluids and allocated_fluids_len are valid again
254 and we can allow GCs to occur.
256 resize_all_states ();
259 allocated_fluids_num
+= 1;
260 allocated_fluids
[n
] = 1;
266 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
268 "Return a newly created fluid.\n"
269 "Fluids are objects that can hold one\n"
270 "value per dynamic state. That is, modifications to this value are\n"
271 "only visible to code that executes with the same dynamic state as\n"
272 "the modifying code. When a new dynamic state is constructed, it\n"
273 "inherits the values from its parent. Because each thread normally executes\n"
274 "with its own dynamic state, you can use fluids for thread local storage.")
275 #define FUNC_NAME s_scm_make_fluid
279 SCM_NEWSMOB2 (fluid
, tc16_fluid
,
280 (scm_t_bits
) next_fluid_num (), SCM_UNPACK (SCM_EOL
));
282 /* The GC must not run until the fluid is properly entered into the
285 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
286 SET_FLUID_NEXT (fluid
, all_fluids
);
288 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
294 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
296 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
298 #define FUNC_NAME s_scm_fluid_p
300 return scm_from_bool (IS_FLUID (obj
));
305 scm_is_fluid (SCM obj
)
307 return IS_FLUID (obj
);
311 scm_i_fluid_num (SCM fluid
)
313 return FLUID_NUM (fluid
);
316 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
318 "Return the value associated with @var{fluid} in the current\n"
319 "dynamic root. If @var{fluid} has not been set, then return\n"
321 #define FUNC_NAME s_scm_fluid_ref
323 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
325 SCM_VALIDATE_FLUID (1, fluid
);
326 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
331 scm_i_fast_fluid_ref (size_t n
)
333 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
334 return SCM_SIMPLE_VECTOR_REF (fluids
, n
);
337 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
338 (SCM fluid
, SCM value
),
339 "Set the value associated with @var{fluid} in the current dynamic root.")
340 #define FUNC_NAME s_scm_fluid_set_x
342 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
344 SCM_VALIDATE_FLUID (1, fluid
);
345 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
346 return SCM_UNSPECIFIED
;
351 scm_i_fast_fluid_set_x (size_t n
, SCM value
)
353 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
354 SCM_SIMPLE_VECTOR_SET (fluids
, n
, value
);
358 swap_fluids (SCM data
)
360 SCM fluids
= SCM_CAR (data
), vals
= SCM_CDR (data
);
362 while (!SCM_NULL_OR_NIL_P (fluids
))
364 SCM fl
= SCM_CAR (fluids
);
365 SCM old_val
= scm_fluid_ref (fl
);
366 scm_fluid_set_x (fl
, SCM_CAR (vals
));
367 SCM_SETCAR (vals
, old_val
);
368 fluids
= SCM_CDR (fluids
);
369 vals
= SCM_CDR (vals
);
373 /* Swap the fluid values in reverse order. This is important when the
374 same fluid appears multiple times in the fluids list.
378 swap_fluids_reverse_aux (SCM fluids
, SCM vals
)
380 if (!SCM_NULL_OR_NIL_P (fluids
))
384 swap_fluids_reverse_aux (SCM_CDR (fluids
), SCM_CDR (vals
));
385 fl
= SCM_CAR (fluids
);
386 old_val
= scm_fluid_ref (fl
);
387 scm_fluid_set_x (fl
, SCM_CAR (vals
));
388 SCM_SETCAR (vals
, old_val
);
393 swap_fluids_reverse (SCM data
)
395 swap_fluids_reverse_aux (SCM_CAR (data
), SCM_CDR (data
));
399 apply_thunk (void *thunk
)
401 return scm_call_0 (SCM_PACK (thunk
));
404 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
405 (SCM fluids
, SCM values
, SCM thunk
),
406 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
407 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
408 "number of their values to be applied. Each substitution is done\n"
409 "one after another. @var{thunk} must be a procedure with no argument.")
410 #define FUNC_NAME s_scm_with_fluids
412 return scm_c_with_fluids (fluids
, values
,
413 apply_thunk
, (void *) SCM_UNPACK (thunk
));
418 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
419 #define FUNC_NAME "scm_c_with_fluids"
424 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
425 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
427 scm_out_of_range (s_scm_with_fluids
, values
);
430 return scm_c_with_fluid (SCM_CAR (fluids
), SCM_CAR (values
),
433 data
= scm_cons (fluids
, values
);
434 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
435 scm_dynwind_rewind_handler_with_scm (swap_fluids
, data
,
436 SCM_F_WIND_EXPLICITLY
);
437 scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse
, data
,
438 SCM_F_WIND_EXPLICITLY
);
445 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
446 (SCM fluid
, SCM value
, SCM thunk
),
447 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
448 "@var{thunk} must be a procedure with no argument.")
449 #define FUNC_NAME s_scm_with_fluid
451 return scm_c_with_fluid (fluid
, value
,
452 apply_thunk
, (void *) SCM_UNPACK (thunk
));
457 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
458 #define FUNC_NAME "scm_c_with_fluid"
462 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
463 scm_dynwind_fluid (fluid
, value
);
471 swap_fluid (SCM data
)
473 SCM f
= SCM_CAR (data
);
474 SCM t
= scm_fluid_ref (f
);
475 scm_fluid_set_x (f
, SCM_CDR (data
));
476 SCM_SETCDR (data
, t
);
480 scm_dynwind_fluid (SCM fluid
, SCM value
)
482 SCM data
= scm_cons (fluid
, value
);
483 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
484 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
488 scm_i_make_initial_dynamic_state ()
490 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
492 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
493 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
494 all_dynamic_states
= state
;
498 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
500 "Return a copy of the dynamic state object @var{parent}\n"
501 "or of the current dynamic state when @var{parent} is omitted.")
502 #define FUNC_NAME s_scm_make_dynamic_state
506 if (SCM_UNBNDP (parent
))
507 parent
= scm_current_dynamic_state ();
509 scm_assert_smob_type (tc16_dynamic_state
, parent
);
510 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
511 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
512 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
514 /* The GC must not run until the state is properly entered into the
517 scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex
);
518 SET_DYNAMIC_STATE_NEXT (state
, all_dynamic_states
);
519 all_dynamic_states
= state
;
520 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
526 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
528 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
529 "return @code{#f} otherwise")
530 #define FUNC_NAME s_scm_dynamic_state_p
532 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
537 scm_is_dynamic_state (SCM obj
)
539 return IS_DYNAMIC_STATE (obj
);
542 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
544 "Return the current dynamic state object.")
545 #define FUNC_NAME s_scm_current_dynamic_state
547 return SCM_I_CURRENT_THREAD
->dynamic_state
;
551 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
553 "Set the current dynamic state object to @var{state}\n"
554 "and return the previous current dynamic state object.")
555 #define FUNC_NAME s_scm_set_current_dynamic_state
557 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
558 SCM old
= t
->dynamic_state
;
559 scm_assert_smob_type (tc16_dynamic_state
, state
);
560 t
->dynamic_state
= state
;
566 swap_dynamic_state (SCM loc
)
568 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
572 scm_dynwind_current_dynamic_state (SCM state
)
574 SCM loc
= scm_cons (state
, SCM_EOL
);
575 scm_assert_smob_type (tc16_dynamic_state
, state
);
576 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
577 SCM_F_WIND_EXPLICITLY
);
578 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
579 SCM_F_WIND_EXPLICITLY
);
583 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
586 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
587 scm_dynwind_current_dynamic_state (state
);
588 result
= func (data
);
593 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
594 (SCM state
, SCM proc
),
595 "Call @var{proc} while @var{state} is the current dynamic\n"
597 #define FUNC_NAME s_scm_with_dynamic_state
600 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
601 scm_dynwind_current_dynamic_state (state
);
602 result
= scm_call_0 (proc
);
609 scm_fluids_prehistory ()
611 tc16_fluid
= scm_make_smob_type ("fluid", 0);
612 scm_set_smob_free (tc16_fluid
, fluid_free
);
613 scm_set_smob_print (tc16_fluid
, fluid_print
);
615 tc16_dynamic_state
= scm_make_smob_type ("dynamic-state", 0);
616 scm_set_smob_mark (tc16_dynamic_state
, scm_markcdr
);
618 scm_c_hook_add (&scm_after_sweep_c_hook
, scan_dynamic_states_and_fluids
,
625 #include "libguile/fluids.x"