libguile/fluids.c

   1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010,
   2  *    2011, 2012, 2013 Free Software Foundation, Inc.
   3  *
   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.
   8  *
   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.
  13  *
  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
  17  * 02110-1301 USA
  18  */
  19
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <string.h>
  26
  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"
  37
  38 /* Number of additional slots to allocate when ALLOCATED_FLUIDS is full.  */
  39 #define FLUID_GROW 128
  40
  41 /* Vector of allocated fluids indexed by fluid numbers.  Access is protected by
  42    FLUID_ADMIN_MUTEX.  */
  43 static void **allocated_fluids = NULL;
  44 static size_t allocated_fluids_len = 0;
  45
  46 static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  47
  48 #define IS_FLUID(x)         SCM_FLUID_P (x)
  49 #define FLUID_NUM(x)        SCM_I_FLUID_NUM (x)
  50
  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)))
  54
  55
  56 \f
  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).  */
  61 static void
  62 grow_dynamic_state (SCM state)
  63 {
  64   SCM new_fluids;
  65   SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
  66   size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
  67
  68   /* Assume the assignment below is atomic.  */
  69   len = allocated_fluids_len;
  70
  71   new_fluids = scm_c_make_vector (len, SCM_UNDEFINED);
  72
  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);
  77 }
  78
  79 void
  80 scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  81 {
  82   scm_puts_unlocked ("#<fluid ", port);
  83   scm_intprint ((int) FLUID_NUM (exp), 10, port);
  84   scm_putc_unlocked ('>', port);
  85 }
  86
  87 void
  88 scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  89 {
  90   scm_puts_unlocked ("#<dynamic-state ", port);
  91   scm_intprint (SCM_UNPACK (exp), 16, port);
  92   scm_putc_unlocked ('>', port);
  93 }
  94
  95 \f
  96 /* Return a new fluid.  */
  97 static SCM
  98 new_fluid (SCM init)
  99 {
 100   SCM fluid;
 101   size_t trial, n;
 102
 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);
 107
 108   scm_dynwind_begin (0);
 109   scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex);
 110
 111   for (trial = 0; trial < 2; trial++)
 112     {
 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)
 117           break;
 118
 119       if (trial == 0 && n >= allocated_fluids_len && 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
 123            weren't reused.  */
 124         scm_i_gc ("fluids");
 125     }
 126
 127   if (n >= allocated_fluids_len)
 128     {
 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),
 133                                    "allocated fluids");
 134
 135       /* Copy over old values and initialize rest.  GC can not run
 136          during these two operations since there is no safe point in
 137          them.  */
 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;
 143
 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;
 149     }
 150
 151   allocated_fluids[n] = SCM_UNPACK_POINTER (fluid);
 152   SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8)));
 153
 154   GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
 155                                          SCM2PTR (fluid));
 156
 157   scm_dynwind_end ();
 158
 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);
 162
 163   return fluid;
 164 }
 165
 166 SCM
 167 scm_make_fluid (void)
 168 {
 169   return new_fluid (SCM_BOOL_F);
 170 }
 171
 172 SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0,
 173             (SCM dflt),
 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
 183 {
 184   return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt);
 185 }
 186 #undef FUNC_NAME
 187
 188 SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0,
 189             (),
 190             "Make a fluid that is initially unbound.")
 191 #define FUNC_NAME s_scm_make_unbound_fluid
 192 {
 193   return new_fluid (SCM_UNDEFINED);
 194 }
 195 #undef FUNC_NAME
 196
 197 SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
 198             (SCM obj),
 199             "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
 200             "@code{#f}.")
 201 #define FUNC_NAME s_scm_fluid_p
 202 {
 203   return scm_from_bool (IS_FLUID (obj));
 204 }
 205 #undef FUNC_NAME
 206
 207 int
 208 scm_is_fluid (SCM obj)
 209 {
 210   return IS_FLUID (obj);
 211 }
 212
 213 /* Does not check type of `fluid'! */
 214 static SCM
 215 fluid_ref (SCM fluid)
 216 {
 217   SCM ret;
 218   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 219
 220   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 221     {
 222       /* Lazily grow the current thread's dynamic state.  */
 223       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 224
 225       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 226     }
 227
 228   ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
 229   if (SCM_UNBNDP (ret))
 230     return SCM_I_FLUID_DEFAULT (fluid);
 231   else
 232     return ret;
 233 }
 234
 235 SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 236             (SCM fluid),
 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"
 239             "@code{#f}.")
 240 #define FUNC_NAME s_scm_fluid_ref
 241 {
 242   SCM val;
 243   SCM_VALIDATE_FLUID (1, fluid);
 244   val = fluid_ref (fluid);
 245   if (SCM_UNBNDP (val))
 246     SCM_MISC_ERROR ("unbound fluid: ~S",
 247                     scm_list_1 (fluid));
 248   return val;
 249 }
 250 #undef FUNC_NAME
 251
 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
 256 {
 257   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 258
 259   SCM_VALIDATE_FLUID (1, fluid);
 260
 261   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 262     {
 263       /* Lazily grow the current thread's dynamic state.  */
 264       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 265
 266       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 267     }
 268
 269   SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
 270   return SCM_UNSPECIFIED;
 271 }
 272 #undef FUNC_NAME
 273
 274 SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0,
 275             (SCM fluid),
 276             "Unset the value associated with @var{fluid}.")
 277 #define FUNC_NAME s_scm_fluid_unset_x
 278 {
 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);
 283 }
 284 #undef FUNC_NAME
 285
 286 SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0,
 287             (SCM fluid),
 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
 291 {
 292   SCM val;
 293   SCM_VALIDATE_FLUID (1, fluid);
 294   val = fluid_ref (fluid);
 295   return scm_from_bool (! (SCM_UNBNDP (val)));
 296 }
 297 #undef FUNC_NAME
 298
 299 static SCM
 300 apply_thunk (void *thunk)
 301 {
 302   return scm_call_0 (SCM_PACK (thunk));
 303 }
 304
 305 void
 306 scm_swap_fluid (SCM fluid, SCM value_box, SCM dynstate)
 307 {
 308   SCM fluid_vector, tmp;
 309   size_t fluid_num;
 310
 311   fluid_num = FLUID_NUM (fluid);
 312
 313   fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
 314
 315   if (SCM_UNLIKELY (fluid_num >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
 316     {
 317       /* Lazily grow the current thread's dynamic state.  */
 318       grow_dynamic_state (dynstate);
 319
 320       fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
 321     }
 322
 323   tmp = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
 324   SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, SCM_VARIABLE_REF (value_box));
 325   SCM_VARIABLE_SET (value_box, tmp);
 326 }
 327
 328 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
 329             (SCM fluids, SCM values, SCM thunk),
 330             "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
 331             "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
 332             "number of their values to be applied.  Each substitution is done\n"
 333             "one after another.  @var{thunk} must be a procedure with no argument.")
 334 #define FUNC_NAME s_scm_with_fluids
 335 {
 336   return scm_c_with_fluids (fluids, values,
 337                             apply_thunk, (void *) SCM_UNPACK (thunk));
 338 }
 339 #undef FUNC_NAME
 340
 341 SCM
 342 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 343 #define FUNC_NAME "scm_c_with_fluids"
 344 {
 345   SCM ans;
 346   long flen, vlen, i;
 347   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 348
 349   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
 350   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
 351   if (flen != vlen)
 352     scm_out_of_range (s_scm_with_fluids, values);
 353
 354   for (i = 0; i < flen; i++)
 355     {
 356       scm_dynstack_push_fluid (&thread->dynstack,
 357                                SCM_CAR (fluids), SCM_CAR (values),
 358                                thread->dynamic_state);
 359       fluids = SCM_CDR (fluids);
 360       values = SCM_CDR (values);
 361     }
 362
 363   ans = cproc (cdata);
 364
 365   for (i = 0; i < flen; i++)
 366     scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
 367
 368   return ans;
 369 }
 370 #undef FUNC_NAME
 371
 372 SCM
 373 scm_with_fluid (SCM fluid, SCM value, SCM thunk)
 374 {
 375   return scm_c_with_fluid (fluid, value,
 376                            apply_thunk, (void *) SCM_UNPACK (thunk));
 377 }
 378
 379 SCM
 380 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 381 #define FUNC_NAME "scm_c_with_fluid"
 382 {
 383   SCM ans;
 384   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
 385
 386   scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
 387                            thread->dynamic_state);
 388   ans = cproc (cdata);
 389   scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
 390
 391   return ans;
 392 }
 393 #undef FUNC_NAME
 394
 395 static void
 396 swap_fluid (SCM data)
 397 {
 398   SCM f = SCM_CAR (data);
 399   SCM t = fluid_ref (f);
 400   scm_fluid_set_x (f, SCM_CDR (data));
 401   SCM_SETCDR (data, t);
 402 }
 403
 404 void
 405 scm_dynwind_fluid (SCM fluid, SCM value)
 406 {
 407   SCM data = scm_cons (fluid, value);
 408   scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 409   scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 410 }
 411
 412 SCM
 413 scm_i_make_initial_dynamic_state ()
 414 {
 415   SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
 416   return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
 417 }
 418
 419 SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
 420             (SCM parent),
 421             "Return a copy of the dynamic state object @var{parent}\n"
 422             "or of the current dynamic state when @var{parent} is omitted.")
 423 #define FUNC_NAME s_scm_make_dynamic_state
 424 {
 425   SCM fluids;
 426
 427   if (SCM_UNBNDP (parent))
 428     parent = scm_current_dynamic_state ();
 429
 430   SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME);
 431   fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
 432   return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
 433 }
 434 #undef FUNC_NAME
 435
 436 SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
 437             (SCM obj),
 438             "Return @code{#t} if @var{obj} is a dynamic state object;\n"
 439             "return @code{#f} otherwise")
 440 #define FUNC_NAME s_scm_dynamic_state_p
 441 {
 442   return scm_from_bool (IS_DYNAMIC_STATE (obj));
 443 }
 444 #undef FUNC_NAME
 445
 446 int
 447 scm_is_dynamic_state (SCM obj)
 448 {
 449   return IS_DYNAMIC_STATE (obj);
 450 }
 451
 452 SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
 453             (),
 454             "Return the current dynamic state object.")
 455 #define FUNC_NAME s_scm_current_dynamic_state
 456 {
 457   return SCM_I_CURRENT_THREAD->dynamic_state;
 458 }
 459 #undef FUNC_NAME
 460
 461 SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
 462             (SCM state),
 463             "Set the current dynamic state object to @var{state}\n"
 464             "and return the previous current dynamic state object.")
 465 #define FUNC_NAME s_scm_set_current_dynamic_state
 466 {
 467   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 468   SCM old = t->dynamic_state;
 469   SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME);
 470   t->dynamic_state = state;
 471   return old;
 472 }
 473 #undef FUNC_NAME
 474
 475 static void
 476 swap_dynamic_state (SCM loc)
 477 {
 478   SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
 479 }
 480
 481 void
 482 scm_dynwind_current_dynamic_state (SCM state)
 483 {
 484   SCM loc = scm_cons (state, SCM_EOL);
 485   SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL);
 486   scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
 487                                      SCM_F_WIND_EXPLICITLY);
 488   scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
 489                                      SCM_F_WIND_EXPLICITLY);
 490 }
 491
 492 void *
 493 scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
 494 {
 495   void *result;
 496   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 497   scm_dynwind_current_dynamic_state (state);
 498   result = func (data);
 499   scm_dynwind_end ();
 500   return result;
 501 }
 502
 503 SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
 504             (SCM state, SCM proc),
 505             "Call @var{proc} while @var{state} is the current dynamic\n"
 506             "state object.")
 507 #define FUNC_NAME s_scm_with_dynamic_state
 508 {
 509   SCM result;
 510   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 511   scm_dynwind_current_dynamic_state (state);
 512   result = scm_call_0 (proc);
 513   scm_dynwind_end ();
 514   return result;
 515 }
 516 #undef FUNC_NAME
 517
 518
 519 void
 520 scm_init_fluids ()
 521 {
 522 #include "libguile/fluids.x"
 523 }
 524
 525 /*
 526   Local Variables:
 527   c-file-style: "gnu"
 528   End:
 529 */