1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 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
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/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 #define IS_FLUID(x) SCM_I_FLUID_P (x)
69 #define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
71 #define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x)
72 #define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x)
73 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
77 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
79 grow_dynamic_state (SCM state
)
82 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
83 size_t i
, new_len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
86 new_len
= allocated_fluids_num
;
87 new_fluids
= scm_c_make_vector (new_len
, SCM_BOOL_F
);
89 scm_i_pthread_mutex_lock (&fluid_admin_mutex
);
90 if (new_len
!= allocated_fluids_num
)
92 /* We lost the race. */
93 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
97 assert (allocated_fluids_num
> old_len
);
99 for (i
= 0; i
< old_len
; i
++)
100 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
101 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
102 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
104 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
108 scm_i_fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
110 scm_puts ("#<fluid ", port
);
111 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
112 scm_putc ('>', port
);
116 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
118 scm_puts ("#<dynamic-state ", port
);
119 scm_intprint (SCM_UNPACK (exp
), 16, port
);
120 scm_putc ('>', port
);
124 scm_i_with_fluids_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
126 scm_puts ("#<with-fluids ", port
);
127 scm_intprint (SCM_UNPACK (exp
), 16, port
);
128 scm_putc ('>', port
);
136 scm_dynwind_begin (0);
137 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
139 if ((allocated_fluids_len
> 0) &&
140 (allocated_fluids_num
== allocated_fluids_len
))
142 /* All fluid numbers are in use. Run a GC to try to free some
148 if (allocated_fluids_num
< allocated_fluids_len
)
150 for (n
= 0; n
< allocated_fluids_len
; n
++)
151 if (allocated_fluids
[n
] == 0)
156 /* Grow the vector of allocated fluids. */
157 /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
158 the GC; therefore, all fluids remain reachable for the entire
159 program lifetime. Hopefully this is not a problem in practice. */
160 char *new_allocated_fluids
=
161 scm_gc_malloc (allocated_fluids_len
+ FLUID_GROW
,
164 /* Copy over old values and initialize rest. GC can not run
165 during these two operations since there is no safe point in
168 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
169 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
170 n
= allocated_fluids_len
;
172 /* Update the vector of allocated fluids. Dynamic states will
173 eventually be lazily grown to accomodate the new value of
174 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
175 allocated_fluids
= new_allocated_fluids
;
176 allocated_fluids_len
+= FLUID_GROW
;
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
197 return scm_cell (scm_tc7_fluid
, (scm_t_bits
) next_fluid_num ());
201 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
203 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
205 #define FUNC_NAME s_scm_fluid_p
207 return scm_from_bool (IS_FLUID (obj
));
212 scm_is_fluid (SCM obj
)
214 return IS_FLUID (obj
);
219 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
221 "Return the value associated with @var{fluid} in the current\n"
222 "dynamic root. If @var{fluid} has not been set, then return\n"
224 #define FUNC_NAME s_scm_fluid_ref
226 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
228 SCM_VALIDATE_FLUID (1, fluid
);
230 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
232 /* We should only get there when the current thread's dynamic state
233 turns out to be too small compared to the set of currently allocated
235 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
237 /* Lazily grow the current thread's dynamic state. */
238 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
240 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
243 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
247 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
248 (SCM fluid
, SCM value
),
249 "Set the value associated with @var{fluid} in the current dynamic root.")
250 #define FUNC_NAME s_scm_fluid_set_x
252 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
254 SCM_VALIDATE_FLUID (1, fluid
);
256 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
258 /* We should only get there when the current thread's dynamic state
259 turns out to be too small compared to the set of currently allocated
261 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
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
;
275 apply_thunk (void *thunk
)
277 return scm_call_0 (SCM_PACK (thunk
));
281 scm_i_make_with_fluids (size_t n
, SCM
*fluids
, SCM
*vals
)
285 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
286 but N will usually be small, so perhaps that's OK. */
291 for (i
= 0; i
< j
; i
++)
292 if (fluids
[i
] == fluids
[j
])
294 vals
[i
] = vals
[j
]; /* later bindings win */
300 ret
= scm_words (scm_tc7_with_fluids
| (n
<< 8), 1 + n
*2);
301 SCM_SET_CELL_WORD_1 (ret
, n
);
305 if (SCM_UNLIKELY (!IS_FLUID (fluids
[n
])))
306 scm_wrong_type_arg ("with-fluids", 0, fluids
[n
]);
307 SCM_SET_CELL_OBJECT (ret
, 1 + n
* 2, fluids
[n
]);
308 SCM_SET_CELL_OBJECT (ret
, 2 + n
* 2, vals
[n
]);
315 scm_i_swap_with_fluids (SCM wf
, SCM dynstate
)
320 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
322 /* We could cache the max in the with-fluids, but that would take more mem,
323 and we're touching all the fluids anyway, so this per-swap traversal should
325 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
327 size_t num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
328 max
= (max
> num
) ? max
: num
;
331 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
333 /* We should only get there when the current thread's dynamic state turns
334 out to be too small compared to the set of currently allocated
336 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
338 /* Lazily grow the current thread's dynamic state. */
339 grow_dynamic_state (dynstate
);
341 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
344 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
345 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
350 fluid_num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
351 x
= SCM_SIMPLE_VECTOR_REF (fluids
, fluid_num
);
352 SCM_SIMPLE_VECTOR_SET (fluids
, fluid_num
,
353 SCM_WITH_FLUIDS_NTH_VAL (wf
, i
));
354 SCM_WITH_FLUIDS_SET_NTH_VAL (wf
, i
, x
);
358 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
359 (SCM fluids
, SCM values
, SCM thunk
),
360 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
361 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
362 "number of their values to be applied. Each substitution is done\n"
363 "one after another. @var{thunk} must be a procedure with no argument.")
364 #define FUNC_NAME s_scm_with_fluids
366 return scm_c_with_fluids (fluids
, values
,
367 apply_thunk
, (void *) SCM_UNPACK (thunk
));
372 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
373 #define FUNC_NAME "scm_c_with_fluids"
377 SCM
*fluidsv
, *valuesv
;
379 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
380 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
382 scm_out_of_range (s_scm_with_fluids
, values
);
384 if (SCM_UNLIKELY (flen
== 0))
385 return cproc (cdata
);
387 fluidsv
= alloca (sizeof(SCM
)*flen
);
388 valuesv
= alloca (sizeof(SCM
)*flen
);
390 for (i
= 0; i
< flen
; i
++)
392 fluidsv
[i
] = SCM_CAR (fluids
);
393 fluids
= SCM_CDR (fluids
);
394 valuesv
[i
] = SCM_CAR (values
);
395 values
= SCM_CDR (values
);
398 wf
= scm_i_make_with_fluids (flen
, fluidsv
, valuesv
);
399 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
400 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
402 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
403 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
409 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
410 (SCM fluid
, SCM value
, SCM thunk
),
411 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
412 "@var{thunk} must be a procedure with no argument.")
413 #define FUNC_NAME s_scm_with_fluid
415 return scm_c_with_fluid (fluid
, value
,
416 apply_thunk
, (void *) SCM_UNPACK (thunk
));
421 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
422 #define FUNC_NAME "scm_c_with_fluid"
426 wf
= scm_i_make_with_fluids (1, &fluid
, &value
);
427 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
428 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
430 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
431 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
438 swap_fluid (SCM data
)
440 SCM f
= SCM_CAR (data
);
441 SCM t
= scm_fluid_ref (f
);
442 scm_fluid_set_x (f
, SCM_CDR (data
));
443 SCM_SETCDR (data
, t
);
447 scm_dynwind_fluid (SCM fluid
, SCM value
)
449 SCM data
= scm_cons (fluid
, value
);
450 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
451 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
455 scm_i_make_initial_dynamic_state ()
457 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
458 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
461 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
463 "Return a copy of the dynamic state object @var{parent}\n"
464 "or of the current dynamic state when @var{parent} is omitted.")
465 #define FUNC_NAME s_scm_make_dynamic_state
469 if (SCM_UNBNDP (parent
))
470 parent
= scm_current_dynamic_state ();
472 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
473 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
474 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
478 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
480 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
481 "return @code{#f} otherwise")
482 #define FUNC_NAME s_scm_dynamic_state_p
484 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
489 scm_is_dynamic_state (SCM obj
)
491 return IS_DYNAMIC_STATE (obj
);
494 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
496 "Return the current dynamic state object.")
497 #define FUNC_NAME s_scm_current_dynamic_state
499 return SCM_I_CURRENT_THREAD
->dynamic_state
;
503 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
505 "Set the current dynamic state object to @var{state}\n"
506 "and return the previous current dynamic state object.")
507 #define FUNC_NAME s_scm_set_current_dynamic_state
509 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
510 SCM old
= t
->dynamic_state
;
511 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
512 t
->dynamic_state
= state
;
518 swap_dynamic_state (SCM loc
)
520 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
524 scm_dynwind_current_dynamic_state (SCM state
)
526 SCM loc
= scm_cons (state
, SCM_EOL
);
527 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
528 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
529 SCM_F_WIND_EXPLICITLY
);
530 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
531 SCM_F_WIND_EXPLICITLY
);
535 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
538 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
539 scm_dynwind_current_dynamic_state (state
);
540 result
= func (data
);
545 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
546 (SCM state
, SCM proc
),
547 "Call @var{proc} while @var{state} is the current dynamic\n"
549 #define FUNC_NAME s_scm_with_dynamic_state
552 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
553 scm_dynwind_current_dynamic_state (state
);
554 result
= scm_call_0 (proc
);
564 #include "libguile/fluids.x"