1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011 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/validate.h"
36 #include "libguile/bdw-gc.h"
38 /* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */
39 #define FLUID_GROW 128
41 /* Vector of allocated fluids indexed by fluid numbers. Access is protected by
43 static void **allocated_fluids
= NULL
;
44 static size_t allocated_fluids_len
= 0;
46 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
48 #define IS_FLUID(x) SCM_FLUID_P (x)
49 #define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
51 #define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x)
52 #define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x)
53 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
57 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may
58 be more than necessary since ALLOCATED_FLUIDS is sparse and the current
59 thread may not access all the fluids anyway. Memory usage could be improved
60 by using a 2-level array as is done in glibc for pthread keys (TODO). */
62 grow_dynamic_state (SCM state
)
65 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
66 size_t i
, len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
68 /* Assume the assignment below is atomic. */
69 len
= allocated_fluids_len
;
71 new_fluids
= scm_c_make_vector (len
, SCM_BOOL_F
);
73 for (i
= 0; i
< old_len
; i
++)
74 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
75 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
76 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
80 scm_i_fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
82 scm_puts_unlocked ("#<fluid ", port
);
83 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
84 scm_putc_unlocked ('>', port
);
88 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
90 scm_puts_unlocked ("#<dynamic-state ", port
);
91 scm_intprint (SCM_UNPACK (exp
), 16, port
);
92 scm_putc_unlocked ('>', port
);
96 scm_i_with_fluids_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
98 scm_puts_unlocked ("#<with-fluids ", port
);
99 scm_intprint (SCM_UNPACK (exp
), 16, port
);
100 scm_putc_unlocked ('>', port
);
104 /* Return a new fluid. */
111 /* Fluids are pointerless cells: the first word is the type tag; the second
112 word is the fluid number. */
113 fluid
= SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_cell
), "fluid"));
114 SCM_SET_CELL_TYPE (fluid
, scm_tc7_fluid
);
116 scm_dynwind_begin (0);
117 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
119 for (trial
= 0; trial
< 2; trial
++)
121 /* Look for a free fluid number. */
122 for (n
= 0; n
< allocated_fluids_len
; n
++)
123 /* TODO: Use `__sync_bool_compare_and_swap' where available. */
124 if (allocated_fluids
[n
] == NULL
)
127 if (trial
== 0 && n
>= allocated_fluids_len
)
128 /* All fluid numbers are in use. Run a GC and retry. Explicitly
129 running the GC is costly and bad-style. We only do this because
130 dynamic state fluid vectors would grow unreasonably if fluid numbers
135 if (n
>= allocated_fluids_len
)
137 /* Grow the vector of allocated fluids. */
138 void **new_allocated_fluids
=
139 scm_gc_malloc_pointerless ((allocated_fluids_len
+ FLUID_GROW
)
140 * sizeof (*allocated_fluids
),
143 /* Copy over old values and initialize rest. GC can not run
144 during these two operations since there is no safe point in
146 memcpy (new_allocated_fluids
, allocated_fluids
,
147 allocated_fluids_len
* sizeof (*allocated_fluids
));
148 memset (new_allocated_fluids
+ allocated_fluids_len
, 0,
149 FLUID_GROW
* sizeof (*allocated_fluids
));
150 n
= allocated_fluids_len
;
152 /* Update the vector of allocated fluids. Dynamic states will
153 eventually be lazily grown to accomodate the new value of
154 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
155 allocated_fluids
= new_allocated_fluids
;
156 allocated_fluids_len
+= FLUID_GROW
;
159 allocated_fluids
[n
] = SCM_UNPACK_POINTER (fluid
);
160 SCM_SET_CELL_WORD_1 (fluid
, (scm_t_bits
) n
);
162 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
163 SCM_HEAP_OBJECT_BASE (fluid
));
167 /* Now null out values. We could (and probably should) do this when
168 the fluid is collected instead of now. */
169 scm_i_reset_fluid (n
, SCM_BOOL_F
);
174 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
176 "Return a newly created fluid.\n"
177 "Fluids are objects that can hold one\n"
178 "value per dynamic state. That is, modifications to this value are\n"
179 "only visible to code that executes with the same dynamic state as\n"
180 "the modifying code. When a new dynamic state is constructed, it\n"
181 "inherits the values from its parent. Because each thread normally executes\n"
182 "with its own dynamic state, you can use fluids for thread local storage.")
183 #define FUNC_NAME s_scm_make_fluid
189 SCM_DEFINE (scm_make_unbound_fluid
, "make-unbound-fluid", 0, 0, 0,
191 "Make a fluid that is initially unbound.")
192 #define FUNC_NAME s_scm_make_unbound_fluid
194 SCM f
= new_fluid ();
195 scm_fluid_set_x (f
, SCM_UNDEFINED
);
200 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
202 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
204 #define FUNC_NAME s_scm_fluid_p
206 return scm_from_bool (IS_FLUID (obj
));
211 scm_is_fluid (SCM obj
)
213 return IS_FLUID (obj
);
216 /* Does not check type of `fluid'! */
218 fluid_ref (SCM fluid
)
220 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
222 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
224 /* Lazily grow the current thread's dynamic state. */
225 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
227 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
230 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
233 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
235 "Return the value associated with @var{fluid} in the current\n"
236 "dynamic root. If @var{fluid} has not been set, then return\n"
238 #define FUNC_NAME s_scm_fluid_ref
241 SCM_VALIDATE_FLUID (1, fluid
);
242 val
= fluid_ref (fluid
);
243 if (SCM_UNBNDP (val
))
244 SCM_MISC_ERROR ("unbound fluid: ~S",
250 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
251 (SCM fluid
, SCM value
),
252 "Set the value associated with @var{fluid} in the current dynamic root.")
253 #define FUNC_NAME s_scm_fluid_set_x
255 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
257 SCM_VALIDATE_FLUID (1, fluid
);
259 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
261 /* Lazily grow the current thread's dynamic state. */
262 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
264 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
267 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
268 return SCM_UNSPECIFIED
;
272 SCM_DEFINE (scm_fluid_unset_x
, "fluid-unset!", 1, 0, 0,
274 "Unset the value associated with @var{fluid}.")
275 #define FUNC_NAME s_scm_fluid_unset_x
277 return scm_fluid_set_x (fluid
, SCM_UNDEFINED
);
281 SCM_DEFINE (scm_fluid_bound_p
, "fluid-bound?", 1, 0, 0,
283 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
284 "Throw an error if @var{fluid} is not a fluid.")
285 #define FUNC_NAME s_scm_fluid_bound_p
288 SCM_VALIDATE_FLUID (1, fluid
);
289 val
= fluid_ref (fluid
);
290 return scm_from_bool (! (SCM_UNBNDP (val
)));
295 apply_thunk (void *thunk
)
297 return scm_call_0 (SCM_PACK (thunk
));
301 scm_i_make_with_fluids (size_t n
, SCM
*fluids
, SCM
*vals
)
305 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
306 but N will usually be small, so perhaps that's OK. */
311 for (i
= 0; i
< j
; i
++)
312 if (scm_is_eq (fluids
[i
], fluids
[j
]))
314 vals
[i
] = vals
[j
]; /* later bindings win */
320 ret
= scm_words (scm_tc7_with_fluids
| (n
<< 8), 1 + n
*2);
321 SCM_SET_CELL_WORD_1 (ret
, n
);
325 if (SCM_UNLIKELY (!IS_FLUID (fluids
[n
])))
326 scm_wrong_type_arg ("with-fluids", 0, fluids
[n
]);
327 SCM_SET_CELL_OBJECT (ret
, 1 + n
* 2, fluids
[n
]);
328 SCM_SET_CELL_OBJECT (ret
, 2 + n
* 2, vals
[n
]);
335 scm_i_swap_with_fluids (SCM wf
, SCM dynstate
)
340 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
342 /* We could cache the max in the with-fluids, but that would take more mem,
343 and we're touching all the fluids anyway, so this per-swap traversal should
345 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
347 size_t num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
348 max
= (max
> num
) ? max
: num
;
351 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
353 /* Lazily grow the current thread's dynamic state. */
354 grow_dynamic_state (dynstate
);
356 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
359 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
360 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
365 fluid_num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
366 x
= SCM_SIMPLE_VECTOR_REF (fluids
, fluid_num
);
367 SCM_SIMPLE_VECTOR_SET (fluids
, fluid_num
,
368 SCM_WITH_FLUIDS_NTH_VAL (wf
, i
));
369 SCM_WITH_FLUIDS_SET_NTH_VAL (wf
, i
, x
);
373 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
374 (SCM fluids
, SCM values
, SCM thunk
),
375 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
376 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
377 "number of their values to be applied. Each substitution is done\n"
378 "one after another. @var{thunk} must be a procedure with no argument.")
379 #define FUNC_NAME s_scm_with_fluids
381 return scm_c_with_fluids (fluids
, values
,
382 apply_thunk
, (void *) SCM_UNPACK (thunk
));
387 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
388 #define FUNC_NAME "scm_c_with_fluids"
392 SCM
*fluidsv
, *valuesv
;
394 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
395 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
397 scm_out_of_range (s_scm_with_fluids
, values
);
399 if (SCM_UNLIKELY (flen
== 0))
400 return cproc (cdata
);
402 fluidsv
= alloca (sizeof(SCM
)*flen
);
403 valuesv
= alloca (sizeof(SCM
)*flen
);
405 for (i
= 0; i
< flen
; i
++)
407 fluidsv
[i
] = SCM_CAR (fluids
);
408 fluids
= SCM_CDR (fluids
);
409 valuesv
[i
] = SCM_CAR (values
);
410 values
= SCM_CDR (values
);
413 wf
= scm_i_make_with_fluids (flen
, fluidsv
, valuesv
);
414 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
415 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
417 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
418 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
424 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
425 (SCM fluid
, SCM value
, SCM thunk
),
426 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
427 "@var{thunk} must be a procedure with no argument.")
428 #define FUNC_NAME s_scm_with_fluid
430 return scm_c_with_fluid (fluid
, value
,
431 apply_thunk
, (void *) SCM_UNPACK (thunk
));
436 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
437 #define FUNC_NAME "scm_c_with_fluid"
441 wf
= scm_i_make_with_fluids (1, &fluid
, &value
);
442 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
443 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
445 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
446 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
453 swap_fluid (SCM data
)
455 SCM f
= SCM_CAR (data
);
456 SCM t
= fluid_ref (f
);
457 scm_fluid_set_x (f
, SCM_CDR (data
));
458 SCM_SETCDR (data
, t
);
462 scm_dynwind_fluid (SCM fluid
, SCM value
)
464 SCM data
= scm_cons (fluid
, value
);
465 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
466 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
470 scm_i_make_initial_dynamic_state ()
472 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
473 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
476 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
478 "Return a copy of the dynamic state object @var{parent}\n"
479 "or of the current dynamic state when @var{parent} is omitted.")
480 #define FUNC_NAME s_scm_make_dynamic_state
484 if (SCM_UNBNDP (parent
))
485 parent
= scm_current_dynamic_state ();
487 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
488 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
489 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
493 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
495 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
496 "return @code{#f} otherwise")
497 #define FUNC_NAME s_scm_dynamic_state_p
499 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
504 scm_is_dynamic_state (SCM obj
)
506 return IS_DYNAMIC_STATE (obj
);
509 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
511 "Return the current dynamic state object.")
512 #define FUNC_NAME s_scm_current_dynamic_state
514 return SCM_I_CURRENT_THREAD
->dynamic_state
;
518 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
520 "Set the current dynamic state object to @var{state}\n"
521 "and return the previous current dynamic state object.")
522 #define FUNC_NAME s_scm_set_current_dynamic_state
524 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
525 SCM old
= t
->dynamic_state
;
526 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
527 t
->dynamic_state
= state
;
533 swap_dynamic_state (SCM loc
)
535 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
539 scm_dynwind_current_dynamic_state (SCM state
)
541 SCM loc
= scm_cons (state
, SCM_EOL
);
542 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
543 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
544 SCM_F_WIND_EXPLICITLY
);
545 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
546 SCM_F_WIND_EXPLICITLY
);
550 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
553 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
554 scm_dynwind_current_dynamic_state (state
);
555 result
= func (data
);
560 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
561 (SCM state
, SCM proc
),
562 "Call @var{proc} while @var{state} is the current dynamic\n"
564 #define FUNC_NAME s_scm_with_dynamic_state
567 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
568 scm_dynwind_current_dynamic_state (state
);
569 result
= scm_call_0 (proc
);
579 #include "libguile/fluids.x"