libguile/fluids.c

   1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   2  *
   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.
   7  *
   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.
  12  *
  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
  16  * 02110-1301 USA
  17  */
  18
  19 #ifdef HAVE_CONFIG_H
  20 # include <config.h>
  21 #endif
  22
  23 #include <stdio.h>
  24 #include <string.h>
  25
  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/lang.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_I_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_BOOL_F);
  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 ("#<fluid ", port);
  83   scm_intprint ((int) FLUID_NUM (exp), 10, port);
  84   scm_putc ('>', 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 ("#<dynamic-state ", port);
  91   scm_intprint (SCM_UNPACK (exp), 16, port);
  92   scm_putc ('>', port);
  93 }
  94
  95 void
  96 scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
  97 {
  98   scm_puts ("#<with-fluids ", port);
  99   scm_intprint (SCM_UNPACK (exp), 16, port);
 100   scm_putc ('>', port);
 101 }
 102
 103 \f
 104 /* Return a new fluid.  */
 105 static SCM
 106 new_fluid ()
 107 {
 108   SCM fluid;
 109   size_t trial, n;
 110
 111   /* Fluids are pointerless cells: the first word is the type tag; the second
 112      word is the fluid number.  */
 113   fluid = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_cell), "fluid"));
 114   SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid);
 115
 116   scm_dynwind_begin (0);
 117   scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex);
 118
 119   for (trial = 0; trial < 2; trial++)
 120     {
 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)
 125           break;
 126
 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
 131            weren't reused.  */
 132         scm_i_gc ("fluids");
 133     }
 134
 135   if (n >= allocated_fluids_len)
 136     {
 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),
 141                                    "allocated fluids");
 142
 143       /* Copy over old values and initialize rest.  GC can not run
 144          during these two operations since there is no safe point in
 145          them.  */
 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;
 151
 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;
 157     }
 158
 159   allocated_fluids[n] = SCM2PTR (fluid);
 160   SCM_SET_CELL_WORD_1 (fluid, (scm_t_bits) n);
 161
 162   GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
 163                                          SCM2PTR (fluid));
 164
 165   scm_dynwind_end ();
 166   return fluid;
 167 }
 168
 169 SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
 170             (),
 171             "Return a newly created fluid.\n"
 172             "Fluids are objects that can hold one\n"
 173             "value per dynamic state.  That is, modifications to this value are\n"
 174             "only visible to code that executes with the same dynamic state as\n"
 175             "the modifying code.  When a new dynamic state is constructed, it\n"
 176             "inherits the values from its parent.  Because each thread normally executes\n"
 177             "with its own dynamic state, you can use fluids for thread local storage.")
 178 #define FUNC_NAME s_scm_make_fluid
 179 {
 180   return new_fluid ();
 181 }
 182 #undef FUNC_NAME
 183
 184 SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
 185             (SCM obj),
 186             "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
 187             "@code{#f}.")
 188 #define FUNC_NAME s_scm_fluid_p
 189 {
 190   return scm_from_bool (IS_FLUID (obj));
 191 }
 192 #undef FUNC_NAME
 193
 194 int
 195 scm_is_fluid (SCM obj)
 196 {
 197   return IS_FLUID (obj);
 198 }
 199
 200
 201
 202 SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 203             (SCM fluid),
 204             "Return the value associated with @var{fluid} in the current\n"
 205             "dynamic root.  If @var{fluid} has not been set, then return\n"
 206             "@code{#f}.")
 207 #define FUNC_NAME s_scm_fluid_ref
 208 {
 209   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 210
 211   SCM_VALIDATE_FLUID (1, fluid);
 212
 213   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 214     {
 215       /* Lazily grow the current thread's dynamic state.  */
 216       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 217
 218       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 219     }
 220
 221   return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
 222 }
 223 #undef FUNC_NAME
 224
 225 SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 226             (SCM fluid, SCM value),
 227             "Set the value associated with @var{fluid} in the current dynamic root.")
 228 #define FUNC_NAME s_scm_fluid_set_x
 229 {
 230   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 231
 232   SCM_VALIDATE_FLUID (1, fluid);
 233
 234   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 235     {
 236       /* Lazily grow the current thread's dynamic state.  */
 237       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 238
 239       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 240     }
 241
 242   SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
 243   return SCM_UNSPECIFIED;
 244 }
 245 #undef FUNC_NAME
 246
 247 static SCM
 248 apply_thunk (void *thunk)
 249 {
 250   return scm_call_0 (SCM_PACK (thunk));
 251 }
 252
 253 SCM
 254 scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
 255 {
 256   SCM ret;
 257
 258   /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
 259      but N will usually be small, so perhaps that's OK. */
 260   {
 261     size_t i, j = n;
 262
 263     while (j--)
 264       for (i = 0; i < j; i++)
 265         if (fluids[i] == fluids[j])
 266           {
 267             vals[i] = vals[j]; /* later bindings win */
 268             n--;
 269             break;
 270           }
 271   }
 272
 273   ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
 274   SCM_SET_CELL_WORD_1 (ret, n);
 275
 276   while (n--)
 277     {
 278       if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
 279         scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
 280       SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
 281       SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
 282     }
 283
 284   return ret;
 285 }
 286
 287 void
 288 scm_i_swap_with_fluids (SCM wf, SCM dynstate)
 289 {
 290   SCM fluids;
 291   size_t i, max = 0;
 292
 293   fluids = DYNAMIC_STATE_FLUIDS (dynstate);
 294
 295   /* We could cache the max in the with-fluids, but that would take more mem,
 296      and we're touching all the fluids anyway, so this per-swap traversal should
 297      be OK. */
 298   for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
 299     {
 300       size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
 301       max = (max > num) ? max : num;
 302     }
 303
 304   if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 305     {
 306       /* Lazily grow the current thread's dynamic state.  */
 307       grow_dynamic_state (dynstate);
 308
 309       fluids = DYNAMIC_STATE_FLUIDS (dynstate);
 310     }
 311
 312   /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
 313   for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
 314     {
 315       size_t fluid_num;
 316       SCM x;
 317
 318       fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
 319       x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
 320       SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
 321                              SCM_WITH_FLUIDS_NTH_VAL (wf, i));
 322       SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
 323     }
 324 }
 325
 326 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
 327             (SCM fluids, SCM values, SCM thunk),
 328             "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
 329             "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
 330             "number of their values to be applied.  Each substitution is done\n"
 331             "one after another.  @var{thunk} must be a procedure with no argument.")
 332 #define FUNC_NAME s_scm_with_fluids
 333 {
 334   return scm_c_with_fluids (fluids, values,
 335                             apply_thunk, (void *) SCM_UNPACK (thunk));
 336 }
 337 #undef FUNC_NAME
 338
 339 SCM
 340 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 341 #define FUNC_NAME "scm_c_with_fluids"
 342 {
 343   SCM wf, ans;
 344   long flen, vlen, i;
 345   SCM *fluidsv, *valuesv;
 346
 347   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
 348   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
 349   if (flen != vlen)
 350     scm_out_of_range (s_scm_with_fluids, values);
 351
 352   if (SCM_UNLIKELY (flen == 0))
 353     return cproc (cdata);
 354
 355   fluidsv = alloca (sizeof(SCM)*flen);
 356   valuesv = alloca (sizeof(SCM)*flen);
 357
 358   for (i = 0; i < flen; i++)
 359     {
 360       fluidsv[i] = SCM_CAR (fluids);
 361       fluids = SCM_CDR (fluids);
 362       valuesv[i] = SCM_CAR (values);
 363       values = SCM_CDR (values);
 364     }
 365
 366   wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
 367   scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
 368   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
 369   ans = cproc (cdata);
 370   scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
 371   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
 372
 373   return ans;
 374 }
 375 #undef FUNC_NAME
 376
 377 SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
 378             (SCM fluid, SCM value, SCM thunk),
 379             "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
 380             "@var{thunk} must be a procedure with no argument.")
 381 #define FUNC_NAME s_scm_with_fluid
 382 {
 383   return scm_c_with_fluid (fluid, value,
 384                            apply_thunk, (void *) SCM_UNPACK (thunk));
 385 }
 386 #undef FUNC_NAME
 387
 388 SCM
 389 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 390 #define FUNC_NAME "scm_c_with_fluid"
 391 {
 392   SCM ans, wf;
 393
 394   wf = scm_i_make_with_fluids (1, &fluid, &value);
 395   scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
 396   scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
 397   ans = cproc (cdata);
 398   scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
 399   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
 400
 401   return ans;
 402 }
 403 #undef FUNC_NAME
 404
 405 static void
 406 swap_fluid (SCM data)
 407 {
 408   SCM f = SCM_CAR (data);
 409   SCM t = scm_fluid_ref (f);
 410   scm_fluid_set_x (f, SCM_CDR (data));
 411   SCM_SETCDR (data, t);
 412 }
 413
 414 void
 415 scm_dynwind_fluid (SCM fluid, SCM value)
 416 {
 417   SCM data = scm_cons (fluid, value);
 418   scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 419   scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 420 }
 421
 422 SCM
 423 scm_i_make_initial_dynamic_state ()
 424 {
 425   SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
 426   return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
 427 }
 428
 429 SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
 430             (SCM parent),
 431             "Return a copy of the dynamic state object @var{parent}\n"
 432             "or of the current dynamic state when @var{parent} is omitted.")
 433 #define FUNC_NAME s_scm_make_dynamic_state
 434 {
 435   SCM fluids;
 436
 437   if (SCM_UNBNDP (parent))
 438     parent = scm_current_dynamic_state ();
 439
 440   SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME);
 441   fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
 442   return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids));
 443 }
 444 #undef FUNC_NAME
 445
 446 SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
 447             (SCM obj),
 448             "Return @code{#t} if @var{obj} is a dynamic state object;\n"
 449             "return @code{#f} otherwise")
 450 #define FUNC_NAME s_scm_dynamic_state_p
 451 {
 452   return scm_from_bool (IS_DYNAMIC_STATE (obj));
 453 }
 454 #undef FUNC_NAME
 455
 456 int
 457 scm_is_dynamic_state (SCM obj)
 458 {
 459   return IS_DYNAMIC_STATE (obj);
 460 }
 461
 462 SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
 463             (),
 464             "Return the current dynamic state object.")
 465 #define FUNC_NAME s_scm_current_dynamic_state
 466 {
 467   return SCM_I_CURRENT_THREAD->dynamic_state;
 468 }
 469 #undef FUNC_NAME
 470
 471 SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
 472             (SCM state),
 473             "Set the current dynamic state object to @var{state}\n"
 474             "and return the previous current dynamic state object.")
 475 #define FUNC_NAME s_scm_set_current_dynamic_state
 476 {
 477   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 478   SCM old = t->dynamic_state;
 479   SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME);
 480   t->dynamic_state = state;
 481   return old;
 482 }
 483 #undef FUNC_NAME
 484
 485 static void
 486 swap_dynamic_state (SCM loc)
 487 {
 488   SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
 489 }
 490
 491 void
 492 scm_dynwind_current_dynamic_state (SCM state)
 493 {
 494   SCM loc = scm_cons (state, SCM_EOL);
 495   SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL);
 496   scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
 497                                      SCM_F_WIND_EXPLICITLY);
 498   scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
 499                                      SCM_F_WIND_EXPLICITLY);
 500 }
 501
 502 void *
 503 scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
 504 {
 505   void *result;
 506   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 507   scm_dynwind_current_dynamic_state (state);
 508   result = func (data);
 509   scm_dynwind_end ();
 510   return result;
 511 }
 512
 513 SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
 514             (SCM state, SCM proc),
 515             "Call @var{proc} while @var{state} is the current dynamic\n"
 516             "state object.")
 517 #define FUNC_NAME s_scm_with_dynamic_state
 518 {
 519   SCM result;
 520   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 521   scm_dynwind_current_dynamic_state (state);
 522   result = scm_call_0 (proc);
 523   scm_dynwind_end ();
 524   return result;
 525 }
 526 #undef FUNC_NAME
 527
 528
 529 void
 530 scm_init_fluids ()
 531 {
 532 #include "libguile/fluids.x"
 533 }
 534
 535 /*
 536   Local Variables:
 537   c-file-style: "gnu"
 538   End:
 539 */