libguile/fluids.c

   1 /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 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 #include <assert.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/print.h"
  29 #include "libguile/smob.h"
  30 #include "libguile/dynwind.h"
  31 #include "libguile/fluids.h"
  32 #include "libguile/alist.h"
  33 #include "libguile/eval.h"
  34 #include "libguile/ports.h"
  35 #include "libguile/deprecation.h"
  36 #include "libguile/lang.h"
  37 #include "libguile/validate.h"
  38
  39 #define FLUID_GROW 20
  40
  41 /* A lot of the complexity below stems from the desire to reuse fluid
  42    slots.  Normally, fluids should be pretty global and long-lived
  43    things, so that reusing their slots should not be overly critical,
  44    but it is the right thing to do nevertheless.  The code therefore
  45    puts the burdon on allocating and collection fluids and keeps
  46    accessing fluids lock free.  This is achieved by manipulating the
  47    global state of the fluid machinery mostly in single threaded
  48    sections.
  49
  50    Reusing a fluid slot means that it must be reset to #f in all
  51    dynamic states.  We do this by maintaining a weak list of all
  52    dynamic states, which is used after a GC to do the resetting.
  53
  54    Also, the fluid vectors in the dynamic states need to grow from
  55    time to time when more fluids are created.  We do this in a single
  56    threaded section so that threads do not need to lock when accessing
  57    a fluid in the normal way.
  58 */
  59
  60 static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
  61
  62 /* Protected by fluid_admin_mutex, but also accessed during GC.  See
  63    next_fluid_num for a discussion of this.
  64  */
  65 static size_t allocated_fluids_len = 0;
  66 static size_t allocated_fluids_num = 0;
  67 static char *allocated_fluids = NULL;
  68
  69 static scm_t_bits tc16_fluid;
  70
  71 #define IS_FLUID(x)         SCM_SMOB_PREDICATE(tc16_fluid, (x))
  72 #define FLUID_NUM(x)        ((size_t)SCM_SMOB_DATA(x))
  73 #define FLUID_NEXT(x)       SCM_SMOB_OBJECT_2(x)
  74 #define FLUID_NEXT_LOC(x)       SCM_SMOB_OBJECT_2_LOC(x)
  75 #define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
  76
  77 static scm_t_bits tc16_dynamic_state;
  78
  79 #define IS_DYNAMIC_STATE(x)        SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
  80 #define DYNAMIC_STATE_FLUIDS(x)        SCM_SMOB_OBJECT(x)
  81 #define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
  82 #define DYNAMIC_STATE_NEXT(x)          SCM_SMOB_OBJECT_2(x)
  83 #define DYNAMIC_STATE_NEXT_LOC(x)          SCM_SMOB_OBJECT_2_LOC(x)
  84 #define SET_DYNAMIC_STATE_NEXT(x, y)   SCM_SET_SMOB_OBJECT_2((x), (y))
  85
  86
  87 \f
  88 /* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_NUM fluids.  */
  89 static void
  90 grow_dynamic_state (SCM state)
  91 {
  92   SCM new_fluids;
  93   SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
  94   size_t i, new_len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
  95
  96  retry:
  97   new_len = allocated_fluids_num;
  98   new_fluids = scm_c_make_vector (new_len, SCM_BOOL_F);
  99
 100   scm_i_pthread_mutex_lock (&fluid_admin_mutex);
 101   if (new_len != allocated_fluids_num)
 102     {
 103       /* We lost the race.  */
 104       scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
 105       goto retry;
 106     }
 107
 108   assert (allocated_fluids_num > old_len);
 109
 110   for (i = 0; i < old_len; i++)
 111     SCM_SIMPLE_VECTOR_SET (new_fluids, i,
 112                            SCM_SIMPLE_VECTOR_REF (old_fluids, i));
 113   SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
 114
 115   scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
 116 }
 117
 118 static int
 119 fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 120 {
 121   scm_puts ("#<fluid ", port);
 122   scm_intprint ((int) FLUID_NUM (exp), 10, port);
 123   scm_putc ('>', port);
 124   return 1;
 125 }
 126
 127 static size_t
 128 next_fluid_num ()
 129 {
 130   size_t n;
 131
 132   scm_dynwind_begin (0);
 133   scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex);
 134
 135   if ((allocated_fluids_len > 0) &&
 136       (allocated_fluids_num == allocated_fluids_len))
 137     {
 138       /* All fluid numbers are in use.  Run a GC to try to free some
 139          up.
 140       */
 141       scm_gc ();
 142     }
 143
 144   if (allocated_fluids_num < allocated_fluids_len)
 145     {
 146       for (n = 0; n < allocated_fluids_len; n++)
 147         if (allocated_fluids[n] == 0)
 148           break;
 149     }
 150   else
 151     {
 152       /* Grow the vector of allocated fluids.  */
 153       /* FIXME: Since we use `scm_malloc ()', ALLOCATED_FLUIDS is scanned by
 154          the GC; therefore, all fluids remain reachable for the entire
 155          program lifetime.  Hopefully this is not a problem in practice.  */
 156       char *new_allocated_fluids =
 157         scm_gc_malloc (allocated_fluids_len + FLUID_GROW,
 158                        "allocated fluids");
 159
 160       /* Copy over old values and initialize rest.  GC can not run
 161          during these two operations since there is no safe point in
 162          them.
 163       */
 164       memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
 165       memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
 166       n = allocated_fluids_len;
 167
 168       /* Update the vector of allocated fluids.  Dynamic states will
 169          eventually be lazily grown to accomodate the new value of
 170          ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'.  */
 171       allocated_fluids = new_allocated_fluids;
 172       allocated_fluids_len += FLUID_GROW;
 173     }
 174
 175   allocated_fluids_num += 1;
 176   allocated_fluids[n] = 1;
 177
 178   scm_dynwind_end ();
 179   return n;
 180 }
 181
 182 SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
 183             (),
 184             "Return a newly created fluid.\n"
 185             "Fluids are objects that can hold one\n"
 186             "value per dynamic state.  That is, modifications to this value are\n"
 187             "only visible to code that executes with the same dynamic state as\n"
 188             "the modifying code.  When a new dynamic state is constructed, it\n"
 189             "inherits the values from its parent.  Because each thread normally executes\n"
 190             "with its own dynamic state, you can use fluids for thread local storage.")
 191 #define FUNC_NAME s_scm_make_fluid
 192 {
 193   SCM fluid;
 194
 195   SCM_NEWSMOB2 (fluid, tc16_fluid,
 196                 (scm_t_bits) next_fluid_num (), SCM_UNPACK (SCM_EOL));
 197
 198   return fluid;
 199 }
 200 #undef FUNC_NAME
 201
 202 SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
 203             (SCM obj),
 204             "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
 205             "@code{#f}.")
 206 #define FUNC_NAME s_scm_fluid_p
 207 {
 208   return scm_from_bool (IS_FLUID (obj));
 209 }
 210 #undef FUNC_NAME
 211
 212 int
 213 scm_is_fluid (SCM obj)
 214 {
 215   return IS_FLUID (obj);
 216 }
 217
 218
 219
 220 SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
 221             (SCM fluid),
 222             "Return the value associated with @var{fluid} in the current\n"
 223             "dynamic root.  If @var{fluid} has not been set, then return\n"
 224             "@code{#f}.")
 225 #define FUNC_NAME s_scm_fluid_ref
 226 {
 227   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 228
 229   SCM_VALIDATE_FLUID (1, fluid);
 230
 231   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 232     {
 233       /* We should only get there when the current thread's dynamic state
 234          turns out to be too small compared to the set of currently allocated
 235          fluids.  */
 236       assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
 237
 238       /* Lazily grow the current thread's dynamic state.  */
 239       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 240
 241       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 242     }
 243
 244   return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
 245 }
 246 #undef FUNC_NAME
 247
 248 SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
 249             (SCM fluid, SCM value),
 250             "Set the value associated with @var{fluid} in the current dynamic root.")
 251 #define FUNC_NAME s_scm_fluid_set_x
 252 {
 253   SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 254
 255   SCM_VALIDATE_FLUID (1, fluid);
 256
 257   if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
 258     {
 259       /* We should only get there when the current thread's dynamic state
 260          turns out to be too small compared to the set of currently allocated
 261          fluids.  */
 262       assert (SCM_SIMPLE_VECTOR_LENGTH (fluids) < allocated_fluids_num);
 263
 264       /* Lazily grow the current thread's dynamic state.  */
 265       grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state);
 266
 267       fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
 268     }
 269
 270   SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
 271   return SCM_UNSPECIFIED;
 272 }
 273 #undef FUNC_NAME
 274
 275 static void
 276 swap_fluids (SCM data)
 277 {
 278   SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
 279
 280   while (!SCM_NULL_OR_NIL_P (fluids))
 281     {
 282       SCM fl = SCM_CAR (fluids);
 283       SCM old_val = scm_fluid_ref (fl);
 284       scm_fluid_set_x (fl, SCM_CAR (vals));
 285       SCM_SETCAR (vals, old_val);
 286       fluids = SCM_CDR (fluids);
 287       vals = SCM_CDR (vals);
 288     }
 289 }
 290
 291 /* Swap the fluid values in reverse order.  This is important when the
 292    same fluid appears multiple times in the fluids list.
 293 */
 294
 295 static void
 296 swap_fluids_reverse_aux (SCM fluids, SCM vals)
 297 {
 298   if (!SCM_NULL_OR_NIL_P (fluids))
 299     {
 300       SCM fl, old_val;
 301
 302       swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
 303       fl = SCM_CAR (fluids);
 304       old_val = scm_fluid_ref (fl);
 305       scm_fluid_set_x (fl, SCM_CAR (vals));
 306       SCM_SETCAR (vals, old_val);
 307     }
 308 }
 309
 310 static void
 311 swap_fluids_reverse (SCM data)
 312 {
 313   swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
 314 }
 315
 316 static SCM
 317 apply_thunk (void *thunk)
 318 {
 319   return scm_call_0 (SCM_PACK (thunk));
 320 }
 321
 322 SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
 323             (SCM fluids, SCM values, SCM thunk),
 324             "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
 325             "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
 326             "number of their values to be applied.  Each substitution is done\n"
 327             "one after another.  @var{thunk} must be a procedure with no argument.")
 328 #define FUNC_NAME s_scm_with_fluids
 329 {
 330   return scm_c_with_fluids (fluids, values,
 331                             apply_thunk, (void *) SCM_UNPACK (thunk));
 332 }
 333 #undef FUNC_NAME
 334
 335 SCM
 336 scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 337 #define FUNC_NAME "scm_c_with_fluids"
 338 {
 339   SCM ans, data;
 340   long flen, vlen;
 341
 342   SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
 343   SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
 344   if (flen != vlen)
 345     scm_out_of_range (s_scm_with_fluids, values);
 346
 347   if (flen == 1)
 348     return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
 349                              cproc, cdata);
 350
 351   data = scm_cons (fluids, values);
 352   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 353   scm_dynwind_rewind_handler_with_scm (swap_fluids, data,
 354                                      SCM_F_WIND_EXPLICITLY);
 355   scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse, data,
 356                                      SCM_F_WIND_EXPLICITLY);
 357   ans = cproc (cdata);
 358   scm_dynwind_end ();
 359   return ans;
 360 }
 361 #undef FUNC_NAME
 362
 363 SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
 364             (SCM fluid, SCM value, SCM thunk),
 365             "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
 366             "@var{thunk} must be a procedure with no argument.")
 367 #define FUNC_NAME s_scm_with_fluid
 368 {
 369   return scm_c_with_fluid (fluid, value,
 370                            apply_thunk, (void *) SCM_UNPACK (thunk));
 371 }
 372 #undef FUNC_NAME
 373
 374 SCM
 375 scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
 376 #define FUNC_NAME "scm_c_with_fluid"
 377 {
 378   SCM ans;
 379
 380   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 381   scm_dynwind_fluid (fluid, value);
 382   ans = cproc (cdata);
 383   scm_dynwind_end ();
 384   return ans;
 385 }
 386 #undef FUNC_NAME
 387
 388 static void
 389 swap_fluid (SCM data)
 390 {
 391   SCM f = SCM_CAR (data);
 392   SCM t = scm_fluid_ref (f);
 393   scm_fluid_set_x (f, SCM_CDR (data));
 394   SCM_SETCDR (data, t);
 395 }
 396
 397 void
 398 scm_dynwind_fluid (SCM fluid, SCM value)
 399 {
 400   SCM data = scm_cons (fluid, value);
 401   scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 402   scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
 403 }
 404
 405 SCM
 406 scm_i_make_initial_dynamic_state ()
 407 {
 408   SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
 409   SCM state;
 410   SCM_NEWSMOB2 (state, tc16_dynamic_state,
 411                 SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
 412   return state;
 413 }
 414
 415 SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
 416             (SCM parent),
 417             "Return a copy of the dynamic state object @var{parent}\n"
 418             "or of the current dynamic state when @var{parent} is omitted.")
 419 #define FUNC_NAME s_scm_make_dynamic_state
 420 {
 421   SCM fluids, state;
 422
 423   if (SCM_UNBNDP (parent))
 424     parent = scm_current_dynamic_state ();
 425
 426   scm_assert_smob_type (tc16_dynamic_state, parent);
 427   fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
 428   SCM_NEWSMOB2 (state, tc16_dynamic_state,
 429                 SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
 430
 431   return state;
 432 }
 433 #undef FUNC_NAME
 434
 435 SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
 436             (SCM obj),
 437             "Return @code{#t} if @var{obj} is a dynamic state object;\n"
 438             "return @code{#f} otherwise")
 439 #define FUNC_NAME s_scm_dynamic_state_p
 440 {
 441   return scm_from_bool (IS_DYNAMIC_STATE (obj));
 442 }
 443 #undef FUNC_NAME
 444
 445 int
 446 scm_is_dynamic_state (SCM obj)
 447 {
 448   return IS_DYNAMIC_STATE (obj);
 449 }
 450
 451 SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
 452             (),
 453             "Return the current dynamic state object.")
 454 #define FUNC_NAME s_scm_current_dynamic_state
 455 {
 456   return SCM_I_CURRENT_THREAD->dynamic_state;
 457 }
 458 #undef FUNC_NAME
 459
 460 SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
 461             (SCM state),
 462             "Set the current dynamic state object to @var{state}\n"
 463             "and return the previous current dynamic state object.")
 464 #define FUNC_NAME s_scm_set_current_dynamic_state
 465 {
 466   scm_i_thread *t = SCM_I_CURRENT_THREAD;
 467   SCM old = t->dynamic_state;
 468   scm_assert_smob_type (tc16_dynamic_state, state);
 469   t->dynamic_state = state;
 470   return old;
 471 }
 472 #undef FUNC_NAME
 473
 474 static void
 475 swap_dynamic_state (SCM loc)
 476 {
 477   SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
 478 }
 479
 480 void
 481 scm_dynwind_current_dynamic_state (SCM state)
 482 {
 483   SCM loc = scm_cons (state, SCM_EOL);
 484   scm_assert_smob_type (tc16_dynamic_state, state);
 485   scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
 486                                      SCM_F_WIND_EXPLICITLY);
 487   scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
 488                                      SCM_F_WIND_EXPLICITLY);
 489 }
 490
 491 void *
 492 scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
 493 {
 494   void *result;
 495   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 496   scm_dynwind_current_dynamic_state (state);
 497   result = func (data);
 498   scm_dynwind_end ();
 499   return result;
 500 }
 501
 502 SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
 503             (SCM state, SCM proc),
 504             "Call @var{proc} while @var{state} is the current dynamic\n"
 505             "state object.")
 506 #define FUNC_NAME s_scm_with_dynamic_state
 507 {
 508   SCM result;
 509   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 510   scm_dynwind_current_dynamic_state (state);
 511   result = scm_call_0 (proc);
 512   scm_dynwind_end ();
 513   return result;
 514 }
 515 #undef FUNC_NAME
 516
 517 void
 518 scm_fluids_prehistory ()
 519 {
 520   tc16_fluid = scm_make_smob_type ("fluid", 0);
 521   scm_set_smob_print (tc16_fluid, fluid_print);
 522
 523   tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0);
 524 }
 525
 526 void
 527 scm_init_fluids ()
 528 {
 529 #include "libguile/fluids.x"
 530 }
 531
 532 /*
 533   Local Variables:
 534   c-file-style: "gnu"
 535   End:
 536 */