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
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))
87 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
89 grow_dynamic_state (SCM state
)
92 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
93 size_t i
, new_len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
96 new_len
= allocated_fluids_num
;
97 new_fluids
= scm_c_make_vector (new_len
, SCM_BOOL_F
);
99 scm_i_pthread_mutex_lock (&fluid_admin_mutex
);
100 if (new_len
!= allocated_fluids_num
)
102 /* We lost the race. */
103 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
107 assert (allocated_fluids_num
> old_len
);
109 for (i
= 0; i
< old_len
; i
++)
110 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
111 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
112 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
114 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
118 fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
120 scm_puts ("#<fluid ", port
);
121 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
122 scm_putc ('>', port
);
131 scm_dynwind_begin (0);
132 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
134 if ((allocated_fluids_len
> 0) &&
135 (allocated_fluids_num
== allocated_fluids_len
))
137 /* All fluid numbers are in use. Run a GC to try to free some
143 if (allocated_fluids_num
< allocated_fluids_len
)
145 for (n
= 0; n
< allocated_fluids_len
; n
++)
146 if (allocated_fluids
[n
] == 0)
151 /* Grow the vector of allocated fluids. */
152 /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
153 the GC; therefore, all fluids remain reachable for the entire
154 program lifetime. Hopefully this is not a problem in practice. */
155 char *prev_allocated_fluids
;
156 char *new_allocated_fluids
=
157 scm_malloc (allocated_fluids_len
+ FLUID_GROW
);
159 /* Copy over old values and initialize rest. GC can not run
160 during these two operations since there is no safe point in
163 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
164 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
165 n
= allocated_fluids_len
;
167 prev_allocated_fluids
= allocated_fluids
;
169 /* Update the vector of allocated fluids. Dynamic states will
170 eventually be lazily grown to accomodate the new value of
171 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
172 allocated_fluids
= new_allocated_fluids
;
173 allocated_fluids_len
+= FLUID_GROW
;
175 if (prev_allocated_fluids
!= NULL
)
176 free (prev_allocated_fluids
);
179 allocated_fluids_num
+= 1;
180 allocated_fluids
[n
] = 1;
186 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
188 "Return a newly created fluid.\n"
189 "Fluids are objects that can hold one\n"
190 "value per dynamic state. That is, modifications to this value are\n"
191 "only visible to code that executes with the same dynamic state as\n"
192 "the modifying code. When a new dynamic state is constructed, it\n"
193 "inherits the values from its parent. Because each thread normally executes\n"
194 "with its own dynamic state, you can use fluids for thread local storage.")
195 #define FUNC_NAME s_scm_make_fluid
199 SCM_NEWSMOB2 (fluid
, tc16_fluid
,
200 (scm_t_bits
) next_fluid_num (), SCM_UNPACK (SCM_EOL
));
206 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
208 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
210 #define FUNC_NAME s_scm_fluid_p
212 return scm_from_bool (IS_FLUID (obj
));
217 scm_is_fluid (SCM obj
)
219 return IS_FLUID (obj
);
224 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
226 "Return the value associated with @var{fluid} in the current\n"
227 "dynamic root. If @var{fluid} has not been set, then return\n"
229 #define FUNC_NAME s_scm_fluid_ref
231 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
233 SCM_VALIDATE_FLUID (1, fluid
);
235 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
237 /* We should only get there when the current thread's dynamic state
238 turns out to be too small compared to the set of currently allocated
240 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
242 /* Lazily grow the current thread's dynamic state. */
243 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
245 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
248 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
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 /* We should only get there when the current thread's dynamic state
264 turns out to be too small compared to the set of currently allocated
266 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
268 /* Lazily grow the current thread's dynamic state. */
269 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
271 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
274 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
275 return SCM_UNSPECIFIED
;
280 swap_fluids (SCM data
)
282 SCM fluids
= SCM_CAR (data
), vals
= SCM_CDR (data
);
284 while (!SCM_NULL_OR_NIL_P (fluids
))
286 SCM fl
= SCM_CAR (fluids
);
287 SCM old_val
= scm_fluid_ref (fl
);
288 scm_fluid_set_x (fl
, SCM_CAR (vals
));
289 SCM_SETCAR (vals
, old_val
);
290 fluids
= SCM_CDR (fluids
);
291 vals
= SCM_CDR (vals
);
295 /* Swap the fluid values in reverse order. This is important when the
296 same fluid appears multiple times in the fluids list.
300 swap_fluids_reverse_aux (SCM fluids
, SCM vals
)
302 if (!SCM_NULL_OR_NIL_P (fluids
))
306 swap_fluids_reverse_aux (SCM_CDR (fluids
), SCM_CDR (vals
));
307 fl
= SCM_CAR (fluids
);
308 old_val
= scm_fluid_ref (fl
);
309 scm_fluid_set_x (fl
, SCM_CAR (vals
));
310 SCM_SETCAR (vals
, old_val
);
315 swap_fluids_reverse (SCM data
)
317 swap_fluids_reverse_aux (SCM_CAR (data
), SCM_CDR (data
));
321 apply_thunk (void *thunk
)
323 return scm_call_0 (SCM_PACK (thunk
));
326 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
327 (SCM fluids
, SCM values
, SCM thunk
),
328 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
329 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
330 "number of their values to be applied. Each substitution is done\n"
331 "one after another. @var{thunk} must be a procedure with no argument.")
332 #define FUNC_NAME s_scm_with_fluids
334 return scm_c_with_fluids (fluids
, values
,
335 apply_thunk
, (void *) SCM_UNPACK (thunk
));
340 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
341 #define FUNC_NAME "scm_c_with_fluids"
346 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
347 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
349 scm_out_of_range (s_scm_with_fluids
, values
);
352 return scm_c_with_fluid (SCM_CAR (fluids
), SCM_CAR (values
),
355 data
= scm_cons (fluids
, values
);
356 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
357 scm_dynwind_rewind_handler_with_scm (swap_fluids
, data
,
358 SCM_F_WIND_EXPLICITLY
);
359 scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse
, data
,
360 SCM_F_WIND_EXPLICITLY
);
367 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
368 (SCM fluid
, SCM value
, SCM thunk
),
369 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
370 "@var{thunk} must be a procedure with no argument.")
371 #define FUNC_NAME s_scm_with_fluid
373 return scm_c_with_fluid (fluid
, value
,
374 apply_thunk
, (void *) SCM_UNPACK (thunk
));
379 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
380 #define FUNC_NAME "scm_c_with_fluid"
384 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
385 scm_dynwind_fluid (fluid
, value
);
393 swap_fluid (SCM data
)
395 SCM f
= SCM_CAR (data
);
396 SCM t
= scm_fluid_ref (f
);
397 scm_fluid_set_x (f
, SCM_CDR (data
));
398 SCM_SETCDR (data
, t
);
402 scm_dynwind_fluid (SCM fluid
, SCM value
)
404 SCM data
= scm_cons (fluid
, value
);
405 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
406 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
410 scm_i_make_initial_dynamic_state ()
412 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
414 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
415 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
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_smob_type (tc16_dynamic_state
, parent
);
431 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
432 SCM_NEWSMOB2 (state
, tc16_dynamic_state
,
433 SCM_UNPACK (fluids
), SCM_UNPACK (SCM_EOL
));
439 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
441 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
442 "return @code{#f} otherwise")
443 #define FUNC_NAME s_scm_dynamic_state_p
445 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
450 scm_is_dynamic_state (SCM obj
)
452 return IS_DYNAMIC_STATE (obj
);
455 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
457 "Return the current dynamic state object.")
458 #define FUNC_NAME s_scm_current_dynamic_state
460 return SCM_I_CURRENT_THREAD
->dynamic_state
;
464 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
466 "Set the current dynamic state object to @var{state}\n"
467 "and return the previous current dynamic state object.")
468 #define FUNC_NAME s_scm_set_current_dynamic_state
470 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
471 SCM old
= t
->dynamic_state
;
472 scm_assert_smob_type (tc16_dynamic_state
, state
);
473 t
->dynamic_state
= state
;
479 swap_dynamic_state (SCM loc
)
481 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
485 scm_dynwind_current_dynamic_state (SCM state
)
487 SCM loc
= scm_cons (state
, SCM_EOL
);
488 scm_assert_smob_type (tc16_dynamic_state
, state
);
489 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
490 SCM_F_WIND_EXPLICITLY
);
491 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
492 SCM_F_WIND_EXPLICITLY
);
496 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
499 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
500 scm_dynwind_current_dynamic_state (state
);
501 result
= func (data
);
506 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
507 (SCM state
, SCM proc
),
508 "Call @var{proc} while @var{state} is the current dynamic\n"
510 #define FUNC_NAME s_scm_with_dynamic_state
513 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
514 scm_dynwind_current_dynamic_state (state
);
515 result
= scm_call_0 (proc
);
522 scm_fluids_prehistory ()
524 tc16_fluid
= scm_make_smob_type ("fluid", 0);
525 scm_set_smob_print (tc16_fluid
, fluid_print
);
527 tc16_dynamic_state
= scm_make_smob_type ("dynamic-state", 0);
533 #include "libguile/fluids.x"