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
26 #include "libguile/_scm.h"
27 #include "libguile/print.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/validate.h"
35 #include "libguile/bdw-gc.h"
37 /* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */
38 #define FLUID_GROW 128
40 /* Vector of allocated fluids indexed by fluid numbers. Access is protected by
42 static void **allocated_fluids
= NULL
;
43 static size_t allocated_fluids_len
= 0;
45 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
47 #define IS_FLUID(x) SCM_I_FLUID_P (x)
48 #define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
50 #define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x)
51 #define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x)
52 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
56 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may
57 be more than necessary since ALLOCATED_FLUIDS is sparse and the current
58 thread may not access all the fluids anyway. Memory usage could be improved
59 by using a 2-level array as is done in glibc for pthread keys (TODO). */
61 grow_dynamic_state (SCM state
)
64 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
65 size_t i
, len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
67 /* Assume the assignment below is atomic. */
68 len
= allocated_fluids_len
;
70 new_fluids
= scm_c_make_vector (len
, SCM_BOOL_F
);
72 for (i
= 0; i
< old_len
; i
++)
73 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
74 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
75 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
79 scm_i_fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
81 scm_puts ("#<fluid ", port
);
82 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
87 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
89 scm_puts ("#<dynamic-state ", port
);
90 scm_intprint (SCM_UNPACK (exp
), 16, port
);
95 scm_i_with_fluids_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
97 scm_puts ("#<with-fluids ", port
);
98 scm_intprint (SCM_UNPACK (exp
), 16, port
);
103 /* Return a new fluid. */
110 /* Fluids are pointerless cells: the first word is the type tag; the second
111 word is the fluid number. */
112 fluid
= PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_cell
), "fluid"));
113 SCM_SET_CELL_TYPE (fluid
, scm_tc7_fluid
);
115 scm_dynwind_begin (0);
116 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
118 for (trial
= 0; trial
< 2; trial
++)
120 /* Look for a free fluid number. */
121 for (n
= 0; n
< allocated_fluids_len
; n
++)
122 /* TODO: Use `__sync_bool_compare_and_swap' where available. */
123 if (allocated_fluids
[n
] == NULL
)
126 if (trial
== 0 && n
>= allocated_fluids_len
)
127 /* All fluid numbers are in use. Run a GC and retry. Explicitly
128 running the GC is costly and bad-style. We only do this because
129 dynamic state fluid vectors would grow unreasonably if fluid numbers
134 if (n
>= allocated_fluids_len
)
136 /* Grow the vector of allocated fluids. */
137 void **new_allocated_fluids
=
138 scm_gc_malloc_pointerless ((allocated_fluids_len
+ FLUID_GROW
)
139 * sizeof (*allocated_fluids
),
142 /* Copy over old values and initialize rest. GC can not run
143 during these two operations since there is no safe point in
145 memcpy (new_allocated_fluids
, allocated_fluids
,
146 allocated_fluids_len
* sizeof (*allocated_fluids
));
147 memset (new_allocated_fluids
+ allocated_fluids_len
, 0,
148 FLUID_GROW
* sizeof (*allocated_fluids
));
149 n
= allocated_fluids_len
;
151 /* Update the vector of allocated fluids. Dynamic states will
152 eventually be lazily grown to accomodate the new value of
153 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
154 allocated_fluids
= new_allocated_fluids
;
155 allocated_fluids_len
+= FLUID_GROW
;
158 allocated_fluids
[n
] = SCM2PTR (fluid
);
159 SCM_SET_CELL_WORD_1 (fluid
, (scm_t_bits
) n
);
161 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
168 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
170 "Return a newly created fluid.\n"
171 "Fluids are objects that can hold one\n"
172 "value per dynamic state. That is, modifications to this value are\n"
173 "only visible to code that executes with the same dynamic state as\n"
174 "the modifying code. When a new dynamic state is constructed, it\n"
175 "inherits the values from its parent. Because each thread normally executes\n"
176 "with its own dynamic state, you can use fluids for thread local storage.")
177 #define FUNC_NAME s_scm_make_fluid
183 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
185 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
187 #define FUNC_NAME s_scm_fluid_p
189 return scm_from_bool (IS_FLUID (obj
));
194 scm_is_fluid (SCM obj
)
196 return IS_FLUID (obj
);
201 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
203 "Return the value associated with @var{fluid} in the current\n"
204 "dynamic root. If @var{fluid} has not been set, then return\n"
206 #define FUNC_NAME s_scm_fluid_ref
208 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
210 SCM_VALIDATE_FLUID (1, fluid
);
212 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
214 /* Lazily grow the current thread's dynamic state. */
215 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
217 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
220 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
224 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
225 (SCM fluid
, SCM value
),
226 "Set the value associated with @var{fluid} in the current dynamic root.")
227 #define FUNC_NAME s_scm_fluid_set_x
229 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
231 SCM_VALIDATE_FLUID (1, fluid
);
233 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
235 /* Lazily grow the current thread's dynamic state. */
236 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
238 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
241 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
242 return SCM_UNSPECIFIED
;
247 apply_thunk (void *thunk
)
249 return scm_call_0 (SCM_PACK (thunk
));
253 scm_i_make_with_fluids (size_t n
, SCM
*fluids
, SCM
*vals
)
257 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
258 but N will usually be small, so perhaps that's OK. */
263 for (i
= 0; i
< j
; i
++)
264 if (fluids
[i
] == fluids
[j
])
266 vals
[i
] = vals
[j
]; /* later bindings win */
272 ret
= scm_words (scm_tc7_with_fluids
| (n
<< 8), 1 + n
*2);
273 SCM_SET_CELL_WORD_1 (ret
, n
);
277 if (SCM_UNLIKELY (!IS_FLUID (fluids
[n
])))
278 scm_wrong_type_arg ("with-fluids", 0, fluids
[n
]);
279 SCM_SET_CELL_OBJECT (ret
, 1 + n
* 2, fluids
[n
]);
280 SCM_SET_CELL_OBJECT (ret
, 2 + n
* 2, vals
[n
]);
287 scm_i_swap_with_fluids (SCM wf
, SCM dynstate
)
292 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
294 /* We could cache the max in the with-fluids, but that would take more mem,
295 and we're touching all the fluids anyway, so this per-swap traversal should
297 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
299 size_t num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
300 max
= (max
> num
) ? max
: num
;
303 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
305 /* Lazily grow the current thread's dynamic state. */
306 grow_dynamic_state (dynstate
);
308 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
311 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
312 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
317 fluid_num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
318 x
= SCM_SIMPLE_VECTOR_REF (fluids
, fluid_num
);
319 SCM_SIMPLE_VECTOR_SET (fluids
, fluid_num
,
320 SCM_WITH_FLUIDS_NTH_VAL (wf
, i
));
321 SCM_WITH_FLUIDS_SET_NTH_VAL (wf
, i
, x
);
325 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
326 (SCM fluids
, SCM values
, SCM thunk
),
327 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
328 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
329 "number of their values to be applied. Each substitution is done\n"
330 "one after another. @var{thunk} must be a procedure with no argument.")
331 #define FUNC_NAME s_scm_with_fluids
333 return scm_c_with_fluids (fluids
, values
,
334 apply_thunk
, (void *) SCM_UNPACK (thunk
));
339 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
340 #define FUNC_NAME "scm_c_with_fluids"
344 SCM
*fluidsv
, *valuesv
;
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
);
351 if (SCM_UNLIKELY (flen
== 0))
352 return cproc (cdata
);
354 fluidsv
= alloca (sizeof(SCM
)*flen
);
355 valuesv
= alloca (sizeof(SCM
)*flen
);
357 for (i
= 0; i
< flen
; i
++)
359 fluidsv
[i
] = SCM_CAR (fluids
);
360 fluids
= SCM_CDR (fluids
);
361 valuesv
[i
] = SCM_CAR (values
);
362 values
= SCM_CDR (values
);
365 wf
= scm_i_make_with_fluids (flen
, fluidsv
, valuesv
);
366 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
367 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
369 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
370 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
376 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
377 (SCM fluid
, SCM value
, SCM thunk
),
378 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
379 "@var{thunk} must be a procedure with no argument.")
380 #define FUNC_NAME s_scm_with_fluid
382 return scm_c_with_fluid (fluid
, value
,
383 apply_thunk
, (void *) SCM_UNPACK (thunk
));
388 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
389 #define FUNC_NAME "scm_c_with_fluid"
393 wf
= scm_i_make_with_fluids (1, &fluid
, &value
);
394 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
395 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
397 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
398 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
405 swap_fluid (SCM data
)
407 SCM f
= SCM_CAR (data
);
408 SCM t
= scm_fluid_ref (f
);
409 scm_fluid_set_x (f
, SCM_CDR (data
));
410 SCM_SETCDR (data
, t
);
414 scm_dynwind_fluid (SCM fluid
, SCM value
)
416 SCM data
= scm_cons (fluid
, value
);
417 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
418 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
422 scm_i_make_initial_dynamic_state ()
424 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
425 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
428 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
430 "Return a copy of the dynamic state object @var{parent}\n"
431 "or of the current dynamic state when @var{parent} is omitted.")
432 #define FUNC_NAME s_scm_make_dynamic_state
436 if (SCM_UNBNDP (parent
))
437 parent
= scm_current_dynamic_state ();
439 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
440 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
441 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
445 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
447 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
448 "return @code{#f} otherwise")
449 #define FUNC_NAME s_scm_dynamic_state_p
451 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
456 scm_is_dynamic_state (SCM obj
)
458 return IS_DYNAMIC_STATE (obj
);
461 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
463 "Return the current dynamic state object.")
464 #define FUNC_NAME s_scm_current_dynamic_state
466 return SCM_I_CURRENT_THREAD
->dynamic_state
;
470 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
472 "Set the current dynamic state object to @var{state}\n"
473 "and return the previous current dynamic state object.")
474 #define FUNC_NAME s_scm_set_current_dynamic_state
476 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
477 SCM old
= t
->dynamic_state
;
478 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
479 t
->dynamic_state
= state
;
485 swap_dynamic_state (SCM loc
)
487 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
491 scm_dynwind_current_dynamic_state (SCM state
)
493 SCM loc
= scm_cons (state
, SCM_EOL
);
494 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
495 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
496 SCM_F_WIND_EXPLICITLY
);
497 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
498 SCM_F_WIND_EXPLICITLY
);
502 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
505 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
506 scm_dynwind_current_dynamic_state (state
);
507 result
= func (data
);
512 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
513 (SCM state
, SCM proc
),
514 "Call @var{proc} while @var{state} is the current dynamic\n"
516 #define FUNC_NAME s_scm_with_dynamic_state
519 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
520 scm_dynwind_current_dynamic_state (state
);
521 result
= scm_call_0 (proc
);
531 #include "libguile/fluids.x"