1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
2 * 2011, 2012, 2013 Free Software Foundation, Inc.
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * 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_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 /* Return a new fluid. */
103 /* Fluids hold the type tag and the fluid number in the first word,
104 and the default value in the second word. */
105 fluid
= scm_cell (scm_tc7_fluid
, SCM_UNPACK (init
));
106 SCM_SET_CELL_TYPE (fluid
, scm_tc7_fluid
);
108 scm_dynwind_begin (0);
109 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
111 for (trial
= 0; trial
< 2; trial
++)
113 /* Look for a free fluid number. */
114 for (n
= 0; n
< allocated_fluids_len
; n
++)
115 /* TODO: Use `__sync_bool_compare_and_swap' where available. */
116 if (allocated_fluids
[n
] == NULL
)
119 if (trial
== 0 && n
>= allocated_fluids_len
)
120 /* All fluid numbers are in use. Run a GC and retry. Explicitly
121 running the GC is costly and bad-style. We only do this because
122 dynamic state fluid vectors would grow unreasonably if fluid numbers
127 if (n
>= allocated_fluids_len
)
129 /* Grow the vector of allocated fluids. */
130 void **new_allocated_fluids
=
131 scm_gc_malloc_pointerless ((allocated_fluids_len
+ FLUID_GROW
)
132 * sizeof (*allocated_fluids
),
135 /* Copy over old values and initialize rest. GC can not run
136 during these two operations since there is no safe point in
138 memcpy (new_allocated_fluids
, allocated_fluids
,
139 allocated_fluids_len
* sizeof (*allocated_fluids
));
140 memset (new_allocated_fluids
+ allocated_fluids_len
, 0,
141 FLUID_GROW
* sizeof (*allocated_fluids
));
142 n
= allocated_fluids_len
;
144 /* Update the vector of allocated fluids. Dynamic states will
145 eventually be lazily grown to accomodate the new value of
146 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
147 allocated_fluids
= new_allocated_fluids
;
148 allocated_fluids_len
+= FLUID_GROW
;
151 allocated_fluids
[n
] = SCM_UNPACK_POINTER (fluid
);
152 SCM_SET_CELL_WORD_0 (fluid
, (scm_tc7_fluid
| (n
<< 8)));
154 GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids
[n
],
159 /* Now null out values. We could (and probably should) do this when
160 the fluid is collected instead of now. */
161 scm_i_reset_fluid (n
);
167 scm_make_fluid (void)
169 return new_fluid (SCM_BOOL_F
);
172 SCM_DEFINE (scm_make_fluid_with_default
, "make-fluid", 0, 1, 0,
174 "Return a newly created fluid, whose initial value is @var{dflt},\n"
175 "or @code{#f} if @var{dflt} is not given.\n"
176 "Fluids are objects that can hold one\n"
177 "value per dynamic state. That is, modifications to this value are\n"
178 "only visible to code that executes with the same dynamic state as\n"
179 "the modifying code. When a new dynamic state is constructed, it\n"
180 "inherits the values from its parent. Because each thread normally executes\n"
181 "with its own dynamic state, you can use fluids for thread local storage.")
182 #define FUNC_NAME s_scm_make_fluid_with_default
184 return new_fluid (SCM_UNBNDP (dflt
) ? SCM_BOOL_F
: dflt
);
188 SCM_DEFINE (scm_make_unbound_fluid
, "make-unbound-fluid", 0, 0, 0,
190 "Make a fluid that is initially unbound.")
191 #define FUNC_NAME s_scm_make_unbound_fluid
193 return new_fluid (SCM_UNDEFINED
);
197 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
199 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
201 #define FUNC_NAME s_scm_fluid_p
203 return scm_from_bool (IS_FLUID (obj
));
208 scm_is_fluid (SCM obj
)
210 return IS_FLUID (obj
);
213 /* Does not check type of `fluid'! */
215 fluid_ref (SCM fluid
)
218 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
220 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
222 /* Lazily grow the current thread's dynamic state. */
223 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
225 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
228 ret
= SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
229 if (SCM_UNBNDP (ret
))
230 return SCM_I_FLUID_DEFAULT (fluid
);
235 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
237 "Return the value associated with @var{fluid} in the current\n"
238 "dynamic root. If @var{fluid} has not been set, then return\n"
240 #define FUNC_NAME s_scm_fluid_ref
243 SCM_VALIDATE_FLUID (1, fluid
);
244 val
= fluid_ref (fluid
);
245 if (SCM_UNBNDP (val
))
246 SCM_MISC_ERROR ("unbound fluid: ~S",
252 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
253 (SCM fluid
, SCM value
),
254 "Set the value associated with @var{fluid} in the current dynamic root.")
255 #define FUNC_NAME s_scm_fluid_set_x
257 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
259 SCM_VALIDATE_FLUID (1, fluid
);
261 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
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
;
274 SCM_DEFINE (scm_fluid_unset_x
, "fluid-unset!", 1, 0, 0,
276 "Unset the value associated with @var{fluid}.")
277 #define FUNC_NAME s_scm_fluid_unset_x
279 /* FIXME: really unset the default value, too? The current test
280 suite demands it, but I would prefer not to. */
281 SCM_SET_CELL_OBJECT_1 (fluid
, SCM_UNDEFINED
);
282 return scm_fluid_set_x (fluid
, SCM_UNDEFINED
);
286 SCM_DEFINE (scm_fluid_bound_p
, "fluid-bound?", 1, 0, 0,
288 "Return @code{#t} iff @var{fluid} is bound to a value.\n"
289 "Throw an error if @var{fluid} is not a fluid.")
290 #define FUNC_NAME s_scm_fluid_bound_p
293 SCM_VALIDATE_FLUID (1, fluid
);
294 val
= fluid_ref (fluid
);
295 return scm_from_bool (! (SCM_UNBNDP (val
)));
300 apply_thunk (void *thunk
)
302 return scm_call_0 (SCM_PACK (thunk
));
306 scm_prepare_fluids (size_t n
, SCM
*fluids
, SCM
*values
)
310 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
311 but N will usually be small, so perhaps that's OK. */
316 if (SCM_UNLIKELY (!IS_FLUID (fluids
[j
])))
317 scm_wrong_type_arg ("with-fluids", 0, fluids
[j
]);
320 if (scm_is_eq (fluids
[i
], fluids
[j
]))
322 values
[i
] = values
[j
]; /* later bindings win */
324 fluids
[j
] = fluids
[n
];
325 values
[j
] = values
[n
];
334 scm_swap_fluids (size_t n
, SCM
*fluids
, SCM
*values
, SCM dynstate
)
339 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
341 /* We could cache the max in the with-fluids, but that would take more mem,
342 and we're touching all the fluids anyway, so this per-swap traversal should
344 for (i
= 0; i
< n
; i
++)
346 size_t num
= FLUID_NUM (fluids
[i
]);
347 max
= (max
> num
) ? max
: num
;
350 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector
)))
352 /* Lazily grow the current thread's dynamic state. */
353 grow_dynamic_state (dynstate
);
355 fluid_vector
= DYNAMIC_STATE_FLUIDS (dynstate
);
358 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
359 for (i
= 0; i
< n
; i
++)
364 fluid_num
= FLUID_NUM (fluids
[i
]);
365 x
= SCM_SIMPLE_VECTOR_REF (fluid_vector
, fluid_num
);
366 SCM_SIMPLE_VECTOR_SET (fluid_vector
, fluid_num
, values
[i
]);
371 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
372 (SCM fluids
, SCM values
, SCM thunk
),
373 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
374 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
375 "number of their values to be applied. Each substitution is done\n"
376 "one after another. @var{thunk} must be a procedure with no argument.")
377 #define FUNC_NAME s_scm_with_fluids
379 return scm_c_with_fluids (fluids
, values
,
380 apply_thunk
, (void *) SCM_UNPACK (thunk
));
385 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
386 #define FUNC_NAME "scm_c_with_fluids"
390 SCM
*fluidsv
, *valuesv
;
391 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
393 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
394 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
396 scm_out_of_range (s_scm_with_fluids
, values
);
398 if (SCM_UNLIKELY (flen
== 0))
399 return cproc (cdata
);
401 fluidsv
= alloca (sizeof(SCM
)*flen
);
402 valuesv
= alloca (sizeof(SCM
)*flen
);
404 for (i
= 0; i
< flen
; i
++)
406 fluidsv
[i
] = SCM_CAR (fluids
);
407 fluids
= SCM_CDR (fluids
);
408 valuesv
[i
] = SCM_CAR (values
);
409 values
= SCM_CDR (values
);
412 scm_dynstack_push_fluids (&thread
->dynstack
, flen
, fluidsv
, valuesv
,
413 thread
->dynamic_state
);
415 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
421 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
422 (SCM fluid
, SCM value
, SCM thunk
),
423 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
424 "@var{thunk} must be a procedure with no argument.")
425 #define FUNC_NAME s_scm_with_fluid
427 return scm_c_with_fluid (fluid
, value
,
428 apply_thunk
, (void *) SCM_UNPACK (thunk
));
433 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
434 #define FUNC_NAME "scm_c_with_fluid"
437 scm_i_thread
*thread
= SCM_I_CURRENT_THREAD
;
439 scm_dynstack_push_fluids (&thread
->dynstack
, 1, &fluid
, &value
,
440 thread
->dynamic_state
);
442 scm_dynstack_unwind_fluids (&thread
->dynstack
, thread
->dynamic_state
);
449 swap_fluid (SCM data
)
451 SCM f
= SCM_CAR (data
);
452 SCM t
= fluid_ref (f
);
453 scm_fluid_set_x (f
, SCM_CDR (data
));
454 SCM_SETCDR (data
, t
);
458 scm_dynwind_fluid (SCM fluid
, SCM value
)
460 SCM data
= scm_cons (fluid
, value
);
461 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
462 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
466 scm_i_make_initial_dynamic_state ()
468 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
469 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
472 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
474 "Return a copy of the dynamic state object @var{parent}\n"
475 "or of the current dynamic state when @var{parent} is omitted.")
476 #define FUNC_NAME s_scm_make_dynamic_state
480 if (SCM_UNBNDP (parent
))
481 parent
= scm_current_dynamic_state ();
483 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
484 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
485 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
489 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
491 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
492 "return @code{#f} otherwise")
493 #define FUNC_NAME s_scm_dynamic_state_p
495 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
500 scm_is_dynamic_state (SCM obj
)
502 return IS_DYNAMIC_STATE (obj
);
505 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
507 "Return the current dynamic state object.")
508 #define FUNC_NAME s_scm_current_dynamic_state
510 return SCM_I_CURRENT_THREAD
->dynamic_state
;
514 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
516 "Set the current dynamic state object to @var{state}\n"
517 "and return the previous current dynamic state object.")
518 #define FUNC_NAME s_scm_set_current_dynamic_state
520 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
521 SCM old
= t
->dynamic_state
;
522 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
523 t
->dynamic_state
= state
;
529 swap_dynamic_state (SCM loc
)
531 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
535 scm_dynwind_current_dynamic_state (SCM state
)
537 SCM loc
= scm_cons (state
, SCM_EOL
);
538 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
539 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
540 SCM_F_WIND_EXPLICITLY
);
541 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
542 SCM_F_WIND_EXPLICITLY
);
546 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
549 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
550 scm_dynwind_current_dynamic_state (state
);
551 result
= func (data
);
556 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
557 (SCM state
, SCM proc
),
558 "Call @var{proc} while @var{state} is the current dynamic\n"
560 #define FUNC_NAME s_scm_with_dynamic_state
563 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
564 scm_dynwind_current_dynamic_state (state
);
565 result
= scm_call_0 (proc
);
575 #include "libguile/fluids.x"