1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 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_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_UNDEFINED
);
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_unlocked ("#<fluid ", port
);
82 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
83 scm_putc_unlocked ('>', port
);
87 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
89 scm_puts_unlocked ("#<dynamic-state ", port
);
90 scm_intprint (SCM_UNPACK (exp
), 16, port
);
91 scm_putc_unlocked ('>', port
);
95 /* Return a new fluid. */
102 /* Fluids hold the type tag and the fluid number in the first word,
103 and the default value in the second word. */
104 fluid
= scm_cell (scm_tc7_fluid
, SCM_UNPACK (init
));
105 SCM_SET_CELL_TYPE (fluid
, scm_tc7_fluid
);
107 scm_dynwind_begin (0);
108 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
110 for (trial
= 0; trial
< 2; trial
++)
112 /* Look for a free fluid number. */
113 for (n
= 0; n
< allocated_fluids_len
; n
++)
114 /* TODO: Use `__sync_bool_compare_and_swap' where available. */
115 if (allocated_fluids
[n
] == NULL
)
118 if (trial
== 0 && n
>= allocated_fluids_len
)
119 /* All fluid numbers are in use. Run a GC and retry. Explicitly
120 running the GC is costly and bad-style. We only do this because
121 dynamic state fluid vectors would grow unreasonably if fluid numbers
126 if (n
>= allocated_fluids_len
)
128 /* Grow the vector of allocated fluids. */
129 void **new_allocated_fluids
=
130 scm_gc_malloc_pointerless ((allocated_fluids_len
+ FLUID_GROW
)
131 * sizeof (*allocated_fluids
),
134 /* Copy over old values and initialize rest. GC can not run
135 during these two operations since there is no safe point in
137 memcpy (new_allocated_fluids
, allocated_fluids
,
138 allocated_fluids_len
* sizeof (*allocated_fluids
));
139 memset (new_allocated_fluids
+ allocated_fluids_len
, 0,
140 FLUID_GROW
* sizeof (*allocated_fluids
));
141 n
= allocated_fluids_len
;
143 /* Update the vector of allocated fluids. Dynamic states will
144 eventually be lazily grown to accomodate the new value of
145 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
146 allocated_fluids
= new_allocated_fluids
;
147 allocated_fluids_len
+= FLUID_GROW
;
150 allocated_fluids
[n
] = SCM_UNPACK_POINTER (fluid
);
151 SCM_SET_CELL_WORD_0 (fluid
, (scm_tc7_fluid
| (n
<< 8)));
153 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
158 /* Now null out values. We could (and probably should) do this when
159 the fluid is collected instead of now. */
160 scm_i_reset_fluid (n
);
166 scm_make_fluid (void)
168 return new_fluid (SCM_BOOL_F
);
171 SCM_DEFINE (scm_make_fluid_with_default
, "make-fluid", 0, 1, 0,
173 "Return a newly created fluid, whose initial value is @var{dflt},\n"
174 "or @code{#f} if @var{dflt} is not given.\n"
175 "Fluids are objects that can hold one\n"
176 "value per dynamic state. That is, modifications to this value are\n"
177 "only visible to code that executes with the same dynamic state as\n"
178 "the modifying code. When a new dynamic state is constructed, it\n"
179 "inherits the values from its parent. Because each thread normally executes\n"
180 "with its own dynamic state, you can use fluids for thread local storage.")
181 #define FUNC_NAME s_scm_make_fluid_with_default
183 return new_fluid (SCM_UNBNDP (dflt
) ? SCM_BOOL_F
: dflt
);
187 SCM_DEFINE (scm_make_unbound_fluid
, "make-unbound-fluid", 0, 0, 0,
189 "Make a fluid that is initially unbound.")
190 #define FUNC_NAME s_scm_make_unbound_fluid
192 return new_fluid (SCM_UNDEFINED
);
196 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
198 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
200 #define FUNC_NAME s_scm_fluid_p
202 return scm_from_bool (IS_FLUID (obj
));
207 scm_is_fluid (SCM obj
)
209 return IS_FLUID (obj
);
212 /* Does not check type of `fluid'! */
214 fluid_ref (SCM fluid
)
217 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
219 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
221 /* Lazily grow the current thread's dynamic state. */
222 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
224 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
227 ret
= SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
228 if (SCM_UNBNDP (ret
))
229 return SCM_I_FLUID_DEFAULT (fluid
);
234 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
236 "Return the value associated with @var{fluid} in the current\n"
237 "dynamic root. If @var{fluid} has not been set, then return\n"
239 #define FUNC_NAME s_scm_fluid_ref
242 SCM_VALIDATE_FLUID (1, fluid
);
243 val
= fluid_ref (fluid
);
244 if (SCM_UNBNDP (val
))
245 SCM_MISC_ERROR ("unbound fluid: ~S",
251 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
252 (SCM fluid
, SCM value
),
253 "Set the value associated with @var{fluid} in the current dynamic root.")
254 #define FUNC_NAME s_scm_fluid_set_x
256 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
258 SCM_VALIDATE_FLUID (1, fluid
);
260 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
262 /* Lazily grow the current thread's dynamic state. */
263 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
265 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
268 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
269 return SCM_UNSPECIFIED
;
273 SCM_DEFINE (scm_fluid_unset_x
, "fluid-unset!", 1, 0, 0,
275 "Unset the value associated with @var{fluid}.")
276 #define FUNC_NAME s_scm_fluid_unset_x
278 /* FIXME: really unset the default value, too? The current test
279 suite demands it, but I would prefer not to. */
280 SCM_SET_CELL_OBJECT_1 (fluid
, SCM_UNDEFINED
);
281 return scm_fluid_set_x (fluid
, SCM_UNDEFINED
);
285 SCM_DEFINE (scm_fluid_bound_p
, "fluid-bound?", 1, 0, 0,
287 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
288 "Throw an error if @var{fluid} is not a fluid.")
289 #define FUNC_NAME s_scm_fluid_bound_p
292 SCM_VALIDATE_FLUID (1, fluid
);
293 val
= fluid_ref (fluid
);
294 return scm_from_bool (! (SCM_UNBNDP (val
)));
299 apply_thunk (void *thunk
)
301 return scm_call_0 (SCM_PACK (thunk
));
305 scm_prepare_fluids (size_t n
, SCM
*fluids
, SCM
*values
)
309 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
310 but N will usually be small, so perhaps that's OK. */
315 if (SCM_UNLIKELY (!IS_FLUID (fluids
[j
])))
316 scm_wrong_type_arg ("with-fluids", 0, fluids
[j
]);
318 for (i
= 0; i
< j
; i
++)
319 if (scm_is_eq (fluids
[i
], fluids
[j
]))
321 values
[i
] = values
[j
]; /* later bindings win */
331 scm_swap_fluids (size_t n
, SCM
*fluids
, SCM
*values
, SCM dynstate
)
336 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
338 /* We could cache the max in the with-fluids, but that would take more mem,
339 and we're touching all the fluids anyway, so this per-swap traversal should
341 for (i
= 0; i
< n
; i
++)
343 size_t num
= FLUID_NUM (fluids
[i
]);
344 max
= (max
> num
) ? max
: num
;
347 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector
)))
349 /* Lazily grow the current thread's dynamic state. */
350 grow_dynamic_state (dynstate
);
352 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
355 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
356 for (i
= 0; i
< n
; i
++)
361 fluid_num
= FLUID_NUM (fluids
[i
]);
362 x
= SCM_SIMPLE_VECTOR_REF (fluid_vector
, fluid_num
);
363 SCM_SIMPLE_VECTOR_SET (fluid_vector
, fluid_num
, values
[i
]);
368 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
369 (SCM fluids
, SCM values
, SCM thunk
),
370 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
371 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
372 "number of their values to be applied. Each substitution is done\n"
373 "one after another. @var{thunk} must be a procedure with no argument.")
374 #define FUNC_NAME s_scm_with_fluids
376 return scm_c_with_fluids (fluids
, values
,
377 apply_thunk
, (void *) SCM_UNPACK (thunk
));
382 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
383 #define FUNC_NAME "scm_c_with_fluids"
387 SCM
*fluidsv
, *valuesv
;
388 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
390 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
391 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
393 scm_out_of_range (s_scm_with_fluids
, values
);
395 if (SCM_UNLIKELY (flen
== 0))
396 return cproc (cdata
);
398 fluidsv
= alloca (sizeof(SCM
)*flen
);
399 valuesv
= alloca (sizeof(SCM
)*flen
);
401 for (i
= 0; i
< flen
; i
++)
403 fluidsv
[i
] = SCM_CAR (fluids
);
404 fluids
= SCM_CDR (fluids
);
405 valuesv
[i
] = SCM_CAR (values
);
406 values
= SCM_CDR (values
);
409 scm_dynstack_push_fluids (&thread
->dynstack
, flen
, fluidsv
, valuesv
,
410 thread
->dynamic_state
);
412 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
418 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
419 (SCM fluid
, SCM value
, SCM thunk
),
420 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
421 "@var{thunk} must be a procedure with no argument.")
422 #define FUNC_NAME s_scm_with_fluid
424 return scm_c_with_fluid (fluid
, value
,
425 apply_thunk
, (void *) SCM_UNPACK (thunk
));
430 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
431 #define FUNC_NAME "scm_c_with_fluid"
434 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
436 scm_dynstack_push_fluids (&thread
->dynstack
, 1, &fluid
, &value
,
437 thread
->dynamic_state
);
439 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
446 swap_fluid (SCM data
)
448 SCM f
= SCM_CAR (data
);
449 SCM t
= fluid_ref (f
);
450 scm_fluid_set_x (f
, SCM_CDR (data
));
451 SCM_SETCDR (data
, t
);
455 scm_dynwind_fluid (SCM fluid
, SCM value
)
457 SCM data
= scm_cons (fluid
, value
);
458 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
459 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
463 scm_i_make_initial_dynamic_state ()
465 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
466 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
469 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
471 "Return a copy of the dynamic state object @var{parent}\n"
472 "or of the current dynamic state when @var{parent} is omitted.")
473 #define FUNC_NAME s_scm_make_dynamic_state
477 if (SCM_UNBNDP (parent
))
478 parent
= scm_current_dynamic_state ();
480 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
481 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
482 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
486 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
488 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
489 "return @code{#f} otherwise")
490 #define FUNC_NAME s_scm_dynamic_state_p
492 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
497 scm_is_dynamic_state (SCM obj
)
499 return IS_DYNAMIC_STATE (obj
);
502 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
504 "Return the current dynamic state object.")
505 #define FUNC_NAME s_scm_current_dynamic_state
507 return SCM_I_CURRENT_THREAD
->dynamic_state
;
511 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
513 "Set the current dynamic state object to @var{state}\n"
514 "and return the previous current dynamic state object.")
515 #define FUNC_NAME s_scm_set_current_dynamic_state
517 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
518 SCM old
= t
->dynamic_state
;
519 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
520 t
->dynamic_state
= state
;
526 swap_dynamic_state (SCM loc
)
528 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
532 scm_dynwind_current_dynamic_state (SCM state
)
534 SCM loc
= scm_cons (state
, SCM_EOL
);
535 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
536 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
537 SCM_F_WIND_EXPLICITLY
);
538 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
539 SCM_F_WIND_EXPLICITLY
);
543 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
546 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
547 scm_dynwind_current_dynamic_state (state
);
548 result
= func (data
);
553 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
554 (SCM state
, SCM proc
),
555 "Call @var{proc} while @var{state} is the current dynamic\n"
557 #define FUNC_NAME s_scm_with_dynamic_state
560 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
561 scm_dynwind_current_dynamic_state (state
);
562 result
= scm_call_0 (proc
);
572 #include "libguile/fluids.x"