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
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_UNDEFINED
);
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 ("#<fluid ", port
);
83 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
88 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
90 scm_puts ("#<dynamic-state ", port
);
91 scm_intprint (SCM_UNPACK (exp
), 16, port
);
96 scm_i_with_fluids_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
98 scm_puts ("#<with-fluids ", port
);
99 scm_intprint (SCM_UNPACK (exp
), 16, port
);
100 scm_putc ('>', port
);
104 /* Return a new fluid. */
111 /* Fluids hold the type tag and the fluid number in the first word,
112 and the default value in the second word. */
113 fluid
= scm_cell (scm_tc7_fluid
, SCM_UNPACK (init
));
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
] = SCM2PTR (fluid
);
160 SCM_SET_CELL_WORD_0 (fluid
, (scm_tc7_fluid
| (n
<< 8)));
162 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
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
);
175 scm_make_fluid (void)
177 return new_fluid (SCM_BOOL_F
);
180 SCM_DEFINE (scm_make_fluid_with_default
, "make-fluid", 0, 1, 0,
182 "Return a newly created fluid, whose initial value is @var{dflt},\n"
183 "or @code{#f} if @var{dflt} is not given.\n"
184 "Fluids are objects that can hold one\n"
185 "value per dynamic state. That is, modifications to this value are\n"
186 "only visible to code that executes with the same dynamic state as\n"
187 "the modifying code. When a new dynamic state is constructed, it\n"
188 "inherits the values from its parent. Because each thread normally executes\n"
189 "with its own dynamic state, you can use fluids for thread local storage.")
190 #define FUNC_NAME s_scm_make_fluid_with_default
192 return new_fluid (SCM_UNBNDP (dflt
) ? SCM_BOOL_F
: dflt
);
196 SCM_DEFINE (scm_make_unbound_fluid
, "make-unbound-fluid", 0, 0, 0,
198 "Make a fluid that is initially unbound.")
199 #define FUNC_NAME s_scm_make_unbound_fluid
201 return new_fluid (SCM_UNDEFINED
);
205 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
207 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
209 #define FUNC_NAME s_scm_fluid_p
211 return scm_from_bool (IS_FLUID (obj
));
216 scm_is_fluid (SCM obj
)
218 return IS_FLUID (obj
);
221 /* Does not check type of `fluid'! */
223 fluid_ref (SCM fluid
)
226 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
228 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
230 /* Lazily grow the current thread's dynamic state. */
231 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
233 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
236 ret
= SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
237 if (SCM_UNBNDP (ret
))
238 return SCM_I_FLUID_DEFAULT (fluid
);
243 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
245 "Return the value associated with @var{fluid} in the current\n"
246 "dynamic root. If @var{fluid} has not been set, then return\n"
248 #define FUNC_NAME s_scm_fluid_ref
251 SCM_VALIDATE_FLUID (1, fluid
);
252 val
= fluid_ref (fluid
);
253 if (SCM_UNBNDP (val
))
254 SCM_MISC_ERROR ("unbound fluid: ~S",
260 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
261 (SCM fluid
, SCM value
),
262 "Set the value associated with @var{fluid} in the current dynamic root.")
263 #define FUNC_NAME s_scm_fluid_set_x
265 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
267 SCM_VALIDATE_FLUID (1, fluid
);
269 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
271 /* Lazily grow the current thread's dynamic state. */
272 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
274 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
277 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
278 return SCM_UNSPECIFIED
;
282 SCM_DEFINE (scm_fluid_unset_x
, "fluid-unset!", 1, 0, 0,
284 "Unset the value associated with @var{fluid}.")
285 #define FUNC_NAME s_scm_fluid_unset_x
287 /* FIXME: really unset the default value, too? The current test
288 suite demands it, but I would prefer not to. */
289 SCM_SET_CELL_OBJECT_1 (fluid
, SCM_UNDEFINED
);
290 return scm_fluid_set_x (fluid
, SCM_UNDEFINED
);
294 SCM_DEFINE (scm_fluid_bound_p
, "fluid-bound?", 1, 0, 0,
296 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
297 "Throw an error if @var{fluid} is not a fluid.")
298 #define FUNC_NAME s_scm_fluid_bound_p
301 SCM_VALIDATE_FLUID (1, fluid
);
302 val
= fluid_ref (fluid
);
303 return scm_from_bool (! (SCM_UNBNDP (val
)));
308 apply_thunk (void *thunk
)
310 return scm_call_0 (SCM_PACK (thunk
));
314 scm_i_make_with_fluids (size_t n
, SCM
*fluids
, SCM
*vals
)
318 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
319 but N will usually be small, so perhaps that's OK. */
324 for (i
= 0; i
< j
; i
++)
325 if (scm_is_eq (fluids
[i
], fluids
[j
]))
327 vals
[i
] = vals
[j
]; /* later bindings win */
333 ret
= scm_words (scm_tc7_with_fluids
| (n
<< 8), 1 + n
*2);
334 SCM_SET_CELL_WORD_1 (ret
, n
);
338 if (SCM_UNLIKELY (!IS_FLUID (fluids
[n
])))
339 scm_wrong_type_arg ("with-fluids", 0, fluids
[n
]);
340 SCM_SET_CELL_OBJECT (ret
, 1 + n
* 2, fluids
[n
]);
341 SCM_SET_CELL_OBJECT (ret
, 2 + n
* 2, vals
[n
]);
348 scm_i_swap_with_fluids (SCM wf
, SCM dynstate
)
353 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
355 /* We could cache the max in the with-fluids, but that would take more mem,
356 and we're touching all the fluids anyway, so this per-swap traversal should
358 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
360 size_t num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
361 max
= (max
> num
) ? max
: num
;
364 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
366 /* Lazily grow the current thread's dynamic state. */
367 grow_dynamic_state (dynstate
);
369 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
372 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
373 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
378 fluid_num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
379 x
= SCM_SIMPLE_VECTOR_REF (fluids
, fluid_num
);
380 SCM_SIMPLE_VECTOR_SET (fluids
, fluid_num
,
381 SCM_WITH_FLUIDS_NTH_VAL (wf
, i
));
382 SCM_WITH_FLUIDS_SET_NTH_VAL (wf
, i
, x
);
386 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
387 (SCM fluids
, SCM values
, SCM thunk
),
388 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
389 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
390 "number of their values to be applied. Each substitution is done\n"
391 "one after another. @var{thunk} must be a procedure with no argument.")
392 #define FUNC_NAME s_scm_with_fluids
394 return scm_c_with_fluids (fluids
, values
,
395 apply_thunk
, (void *) SCM_UNPACK (thunk
));
400 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
401 #define FUNC_NAME "scm_c_with_fluids"
405 SCM
*fluidsv
, *valuesv
;
407 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
408 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
410 scm_out_of_range (s_scm_with_fluids
, values
);
412 if (SCM_UNLIKELY (flen
== 0))
413 return cproc (cdata
);
415 fluidsv
= alloca (sizeof(SCM
)*flen
);
416 valuesv
= alloca (sizeof(SCM
)*flen
);
418 for (i
= 0; i
< flen
; i
++)
420 fluidsv
[i
] = SCM_CAR (fluids
);
421 fluids
= SCM_CDR (fluids
);
422 valuesv
[i
] = SCM_CAR (values
);
423 values
= SCM_CDR (values
);
426 wf
= scm_i_make_with_fluids (flen
, fluidsv
, valuesv
);
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 ()));
437 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
438 (SCM fluid
, SCM value
, SCM thunk
),
439 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
440 "@var{thunk} must be a procedure with no argument.")
441 #define FUNC_NAME s_scm_with_fluid
443 return scm_c_with_fluid (fluid
, value
,
444 apply_thunk
, (void *) SCM_UNPACK (thunk
));
449 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
450 #define FUNC_NAME "scm_c_with_fluid"
454 wf
= scm_i_make_with_fluids (1, &fluid
, &value
);
455 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
456 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
458 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
459 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
466 swap_fluid (SCM data
)
468 SCM f
= SCM_CAR (data
);
469 SCM t
= fluid_ref (f
);
470 scm_fluid_set_x (f
, SCM_CDR (data
));
471 SCM_SETCDR (data
, t
);
475 scm_dynwind_fluid (SCM fluid
, SCM value
)
477 SCM data
= scm_cons (fluid
, value
);
478 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
479 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
483 scm_i_make_initial_dynamic_state ()
485 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
486 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
489 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
491 "Return a copy of the dynamic state object @var{parent}\n"
492 "or of the current dynamic state when @var{parent} is omitted.")
493 #define FUNC_NAME s_scm_make_dynamic_state
497 if (SCM_UNBNDP (parent
))
498 parent
= scm_current_dynamic_state ();
500 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
501 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
502 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
506 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
508 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
509 "return @code{#f} otherwise")
510 #define FUNC_NAME s_scm_dynamic_state_p
512 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
517 scm_is_dynamic_state (SCM obj
)
519 return IS_DYNAMIC_STATE (obj
);
522 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
524 "Return the current dynamic state object.")
525 #define FUNC_NAME s_scm_current_dynamic_state
527 return SCM_I_CURRENT_THREAD
->dynamic_state
;
531 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
533 "Set the current dynamic state object to @var{state}\n"
534 "and return the previous current dynamic state object.")
535 #define FUNC_NAME s_scm_set_current_dynamic_state
537 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
538 SCM old
= t
->dynamic_state
;
539 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
540 t
->dynamic_state
= state
;
546 swap_dynamic_state (SCM loc
)
548 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
552 scm_dynwind_current_dynamic_state (SCM state
)
554 SCM loc
= scm_cons (state
, SCM_EOL
);
555 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
556 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
557 SCM_F_WIND_EXPLICITLY
);
558 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
559 SCM_F_WIND_EXPLICITLY
);
563 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
566 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
567 scm_dynwind_current_dynamic_state (state
);
568 result
= func (data
);
573 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
574 (SCM state
, SCM proc
),
575 "Call @var{proc} while @var{state} is the current dynamic\n"
577 #define FUNC_NAME s_scm_with_dynamic_state
580 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
581 scm_dynwind_current_dynamic_state (state
);
582 result
= scm_call_0 (proc
);
592 #include "libguile/fluids.x"