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
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/lang.h"
36 #include "libguile/validate.h"
40 /* A lot of the complexity below stems from the desire to reuse fluid
41 slots. Normally, fluids should be pretty global and long-lived
42 things, so that reusing their slots should not be overly critical,
43 but it is the right thing to do nevertheless. The code therefore
44 puts the burdon on allocating and collection fluids and keeps
45 accessing fluids lock free. This is achieved by manipulating the
46 global state of the fluid machinery mostly in single threaded
49 Reusing a fluid slot means that it must be reset to #f in all
50 dynamic states. We do this by maintaining a weak list of all
51 dynamic states, which is used after a GC to do the resetting.
53 Also, the fluid vectors in the dynamic states need to grow from
54 time to time when more fluids are created. We do this in a single
55 threaded section so that threads do not need to lock when accessing
56 a fluid in the normal way.
59 static scm_i_pthread_mutex_t fluid_admin_mutex
= SCM_I_PTHREAD_MUTEX_INITIALIZER
;
61 /* Protected by fluid_admin_mutex, but also accessed during GC. See
62 next_fluid_num for a discussion of this.
64 static size_t allocated_fluids_len
= 0;
65 static size_t allocated_fluids_num
= 0;
66 static char *allocated_fluids
= NULL
;
68 #define IS_FLUID(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
69 #define FLUID_NUM(x) ((size_t)SCM_CELL_WORD_1(x))
71 #define IS_DYNAMIC_STATE(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_dynamic_state)
72 #define DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
73 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y)))
77 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids. */
79 grow_dynamic_state (SCM state
)
82 SCM old_fluids
= DYNAMIC_STATE_FLUIDS (state
);
83 size_t i
, new_len
, old_len
= SCM_SIMPLE_VECTOR_LENGTH (old_fluids
);
86 new_len
= allocated_fluids_num
;
87 new_fluids
= scm_c_make_vector (new_len
, SCM_BOOL_F
);
89 scm_i_pthread_mutex_lock (&fluid_admin_mutex
);
90 if (new_len
!= allocated_fluids_num
)
92 /* We lost the race. */
93 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
97 assert (allocated_fluids_num
> old_len
);
99 for (i
= 0; i
< old_len
; i
++)
100 SCM_SIMPLE_VECTOR_SET (new_fluids
, i
,
101 SCM_SIMPLE_VECTOR_REF (old_fluids
, i
));
102 SET_DYNAMIC_STATE_FLUIDS (state
, new_fluids
);
104 scm_i_pthread_mutex_unlock (&fluid_admin_mutex
);
108 scm_i_fluid_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
110 scm_puts ("#<fluid ", port
);
111 scm_intprint ((int) FLUID_NUM (exp
), 10, port
);
112 scm_putc ('>', port
);
116 scm_i_dynamic_state_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
118 scm_puts ("#<dynamic-state ", port
);
119 scm_intprint (SCM_UNPACK (exp
), 16, port
);
120 scm_putc ('>', port
);
128 scm_dynwind_begin (0);
129 scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex
);
131 if ((allocated_fluids_len
> 0) &&
132 (allocated_fluids_num
== allocated_fluids_len
))
134 /* All fluid numbers are in use. Run a GC to try to free some
140 if (allocated_fluids_num
< allocated_fluids_len
)
142 for (n
= 0; n
< allocated_fluids_len
; n
++)
143 if (allocated_fluids
[n
] == 0)
148 /* Grow the vector of allocated fluids. */
149 /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
150 the GC; therefore, all fluids remain reachable for the entire
151 program lifetime. Hopefully this is not a problem in practice. */
152 char *new_allocated_fluids
=
153 scm_gc_malloc (allocated_fluids_len
+ FLUID_GROW
,
156 /* Copy over old values and initialize rest. GC can not run
157 during these two operations since there is no safe point in
160 memcpy (new_allocated_fluids
, allocated_fluids
, allocated_fluids_len
);
161 memset (new_allocated_fluids
+ allocated_fluids_len
, 0, FLUID_GROW
);
162 n
= allocated_fluids_len
;
164 /* Update the vector of allocated fluids. Dynamic states will
165 eventually be lazily grown to accomodate the new value of
166 ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */
167 allocated_fluids
= new_allocated_fluids
;
168 allocated_fluids_len
+= FLUID_GROW
;
171 allocated_fluids_num
+= 1;
172 allocated_fluids
[n
] = 1;
178 SCM_DEFINE (scm_make_fluid
, "make-fluid", 0, 0, 0,
180 "Return a newly created fluid.\n"
181 "Fluids are objects that can hold one\n"
182 "value per dynamic state. That is, modifications to this value are\n"
183 "only visible to code that executes with the same dynamic state as\n"
184 "the modifying code. When a new dynamic state is constructed, it\n"
185 "inherits the values from its parent. Because each thread normally executes\n"
186 "with its own dynamic state, you can use fluids for thread local storage.")
187 #define FUNC_NAME s_scm_make_fluid
189 return scm_cell (scm_tc7_fluid
, (scm_t_bits
) next_fluid_num ());
193 SCM_DEFINE (scm_fluid_p
, "fluid?", 1, 0, 0,
195 "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
197 #define FUNC_NAME s_scm_fluid_p
199 return scm_from_bool (IS_FLUID (obj
));
204 scm_is_fluid (SCM obj
)
206 return IS_FLUID (obj
);
211 SCM_DEFINE (scm_fluid_ref
, "fluid-ref", 1, 0, 0,
213 "Return the value associated with @var{fluid} in the current\n"
214 "dynamic root. If @var{fluid} has not been set, then return\n"
216 #define FUNC_NAME s_scm_fluid_ref
218 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
220 SCM_VALIDATE_FLUID (1, fluid
);
222 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
224 /* We should only get there when the current thread's dynamic state
225 turns out to be too small compared to the set of currently allocated
227 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
229 /* Lazily grow the current thread's dynamic state. */
230 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
232 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
235 return SCM_SIMPLE_VECTOR_REF (fluids
, FLUID_NUM (fluid
));
239 SCM_DEFINE (scm_fluid_set_x
, "fluid-set!", 2, 0, 0,
240 (SCM fluid
, SCM value
),
241 "Set the value associated with @var{fluid} in the current dynamic root.")
242 #define FUNC_NAME s_scm_fluid_set_x
244 SCM fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
246 SCM_VALIDATE_FLUID (1, fluid
);
248 if (SCM_UNLIKELY (FLUID_NUM (fluid
) >= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
250 /* We should only get there when the current thread's dynamic state
251 turns out to be too small compared to the set of currently allocated
253 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
255 /* Lazily grow the current thread's dynamic state. */
256 grow_dynamic_state (SCM_I_CURRENT_THREAD
->dynamic_state
);
258 fluids
= DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD
->dynamic_state
);
261 SCM_SIMPLE_VECTOR_SET (fluids
, FLUID_NUM (fluid
), value
);
262 return SCM_UNSPECIFIED
;
267 apply_thunk (void *thunk
)
269 return scm_call_0 (SCM_PACK (thunk
));
273 scm_i_make_with_fluids (size_t n
, SCM
*fluids
, SCM
*vals
)
277 /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
278 but N will usually be small, so perhaps that's OK. */
283 for (i
= 0; i
< j
; i
++)
284 if (fluids
[i
] == fluids
[j
])
286 vals
[i
] = vals
[j
]; /* later bindings win */
292 ret
= scm_words (scm_tc7_with_fluids
| (n
<< 8), 1 + n
*2);
293 SCM_SET_CELL_WORD_1 (ret
, n
);
297 if (SCM_UNLIKELY (!IS_FLUID (fluids
[n
])))
298 scm_wrong_type_arg ("with-fluids", 0, fluids
[n
]);
299 SCM_SET_CELL_OBJECT (ret
, 1 + n
* 2, fluids
[n
]);
300 SCM_SET_CELL_OBJECT (ret
, 2 + n
* 2, vals
[n
]);
307 scm_i_swap_with_fluids (SCM wf
, SCM dynstate
)
312 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
314 /* We could cache the max in the with-fluids, but that would take more mem,
315 and we're touching all the fluids anyway, so this per-swap traversal should
317 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
319 size_t num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
320 max
= (max
> num
) ? max
: num
;
323 if (SCM_UNLIKELY (max
>= SCM_SIMPLE_VECTOR_LENGTH (fluids
)))
325 /* We should only get there when the current thread's dynamic state turns
326 out to be too small compared to the set of currently allocated
328 assert (SCM_SIMPLE_VECTOR_LENGTH (fluids
) < allocated_fluids_num
);
330 /* Lazily grow the current thread's dynamic state. */
331 grow_dynamic_state (dynstate
);
333 fluids
= DYNAMIC_STATE_FLUIDS (dynstate
);
336 /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
337 for (i
= 0; i
< SCM_WITH_FLUIDS_LEN (wf
); i
++)
342 fluid_num
= FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf
, i
));
343 x
= SCM_SIMPLE_VECTOR_REF (fluids
, fluid_num
);
344 SCM_SIMPLE_VECTOR_SET (fluids
, fluid_num
,
345 SCM_WITH_FLUIDS_NTH_VAL (wf
, i
));
346 SCM_WITH_FLUIDS_SET_NTH_VAL (wf
, i
, x
);
350 SCM_DEFINE (scm_with_fluids
, "with-fluids*", 3, 0, 0,
351 (SCM fluids
, SCM values
, SCM thunk
),
352 "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
353 "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
354 "number of their values to be applied. Each substitution is done\n"
355 "one after another. @var{thunk} must be a procedure with no argument.")
356 #define FUNC_NAME s_scm_with_fluids
358 return scm_c_with_fluids (fluids
, values
,
359 apply_thunk
, (void *) SCM_UNPACK (thunk
));
364 scm_c_with_fluids (SCM fluids
, SCM values
, SCM (*cproc
) (), void *cdata
)
365 #define FUNC_NAME "scm_c_with_fluids"
369 SCM
*fluidsv
, *valuesv
;
371 SCM_VALIDATE_LIST_COPYLEN (1, fluids
, flen
);
372 SCM_VALIDATE_LIST_COPYLEN (2, values
, vlen
);
374 scm_out_of_range (s_scm_with_fluids
, values
);
376 if (SCM_UNLIKELY (flen
== 0))
377 return cproc (cdata
);
379 fluidsv
= alloca (sizeof(SCM
)*flen
);
380 valuesv
= alloca (sizeof(SCM
)*flen
);
382 for (i
= 0; i
< flen
; i
++)
384 fluidsv
[i
] = SCM_CAR (fluids
);
385 fluids
= SCM_CDR (fluids
);
386 valuesv
[i
] = SCM_CAR (values
);
387 values
= SCM_CDR (values
);
390 wf
= scm_i_make_with_fluids (flen
, fluidsv
, valuesv
);
391 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
392 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
394 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
395 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
401 SCM_DEFINE (scm_with_fluid
, "with-fluid*", 3, 0, 0,
402 (SCM fluid
, SCM value
, SCM thunk
),
403 "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
404 "@var{thunk} must be a procedure with no argument.")
405 #define FUNC_NAME s_scm_with_fluid
407 return scm_c_with_fluid (fluid
, value
,
408 apply_thunk
, (void *) SCM_UNPACK (thunk
));
413 scm_c_with_fluid (SCM fluid
, SCM value
, SCM (*cproc
) (), void *cdata
)
414 #define FUNC_NAME "scm_c_with_fluid"
418 wf
= scm_i_make_with_fluids (1, &fluid
, &value
);
419 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
420 scm_i_set_dynwinds (scm_cons (wf
, scm_i_dynwinds ()));
422 scm_i_swap_with_fluids (wf
, SCM_I_CURRENT_THREAD
->dynamic_state
);
423 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
430 swap_fluid (SCM data
)
432 SCM f
= SCM_CAR (data
);
433 SCM t
= scm_fluid_ref (f
);
434 scm_fluid_set_x (f
, SCM_CDR (data
));
435 SCM_SETCDR (data
, t
);
439 scm_dynwind_fluid (SCM fluid
, SCM value
)
441 SCM data
= scm_cons (fluid
, value
);
442 scm_dynwind_rewind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
443 scm_dynwind_unwind_handler_with_scm (swap_fluid
, data
, SCM_F_WIND_EXPLICITLY
);
447 scm_i_make_initial_dynamic_state ()
449 SCM fluids
= scm_c_make_vector (allocated_fluids_len
, SCM_BOOL_F
);
450 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
453 SCM_DEFINE (scm_make_dynamic_state
, "make-dynamic-state", 0, 1, 0,
455 "Return a copy of the dynamic state object @var{parent}\n"
456 "or of the current dynamic state when @var{parent} is omitted.")
457 #define FUNC_NAME s_scm_make_dynamic_state
461 if (SCM_UNBNDP (parent
))
462 parent
= scm_current_dynamic_state ();
464 SCM_ASSERT (IS_DYNAMIC_STATE (parent
), parent
, SCM_ARG1
, FUNC_NAME
);
465 fluids
= scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent
));
466 return scm_cell (scm_tc7_dynamic_state
, SCM_UNPACK (fluids
));
470 SCM_DEFINE (scm_dynamic_state_p
, "dynamic-state?", 1, 0, 0,
472 "Return @code{#t} if @var{obj} is a dynamic state object;\n"
473 "return @code{#f} otherwise")
474 #define FUNC_NAME s_scm_dynamic_state_p
476 return scm_from_bool (IS_DYNAMIC_STATE (obj
));
481 scm_is_dynamic_state (SCM obj
)
483 return IS_DYNAMIC_STATE (obj
);
486 SCM_DEFINE (scm_current_dynamic_state
, "current-dynamic-state", 0, 0, 0,
488 "Return the current dynamic state object.")
489 #define FUNC_NAME s_scm_current_dynamic_state
491 return SCM_I_CURRENT_THREAD
->dynamic_state
;
495 SCM_DEFINE (scm_set_current_dynamic_state
, "set-current-dynamic-state", 1,0,0,
497 "Set the current dynamic state object to @var{state}\n"
498 "and return the previous current dynamic state object.")
499 #define FUNC_NAME s_scm_set_current_dynamic_state
501 scm_i_thread
*t
= SCM_I_CURRENT_THREAD
;
502 SCM old
= t
->dynamic_state
;
503 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, FUNC_NAME
);
504 t
->dynamic_state
= state
;
510 swap_dynamic_state (SCM loc
)
512 SCM_SETCAR (loc
, scm_set_current_dynamic_state (SCM_CAR (loc
)));
516 scm_dynwind_current_dynamic_state (SCM state
)
518 SCM loc
= scm_cons (state
, SCM_EOL
);
519 SCM_ASSERT (IS_DYNAMIC_STATE (state
), state
, SCM_ARG1
, NULL
);
520 scm_dynwind_rewind_handler_with_scm (swap_dynamic_state
, loc
,
521 SCM_F_WIND_EXPLICITLY
);
522 scm_dynwind_unwind_handler_with_scm (swap_dynamic_state
, loc
,
523 SCM_F_WIND_EXPLICITLY
);
527 scm_c_with_dynamic_state (SCM state
, void *(*func
)(void *), void *data
)
530 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
531 scm_dynwind_current_dynamic_state (state
);
532 result
= func (data
);
537 SCM_DEFINE (scm_with_dynamic_state
, "with-dynamic-state", 2, 0, 0,
538 (SCM state
, SCM proc
),
539 "Call @var{proc} while @var{state} is the current dynamic\n"
541 #define FUNC_NAME s_scm_with_dynamic_state
544 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE
);
545 scm_dynwind_current_dynamic_state (state
);
546 result
= scm_call_0 (proc
);
556 #include "libguile/fluids.x"