libguile/coop-threads.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  16  */
  17
  18
  19 \f
  20
  21 #include "libguile/_scm.h"
  22 #include "libguile/validate.h"
  23 #include "libguile/coop-threads.h"
  24 #include "libguile/root.h"
  25
  26 /* A counter of the current number of threads */
  27 size_t scm_thread_count = 0;
  28
  29 /* This is included rather than compiled separately in order
  30    to simplify the configuration mechanism. */
  31 #include "libguile/coop.c"
  32
  33 /* A count-down counter used to determine when to switch
  34    contexts */
  35 size_t scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
  36
  37 coop_m scm_critical_section_mutex;
  38
  39 static SCM all_threads;
  40
  41 void
  42 scm_threads_init (SCM_STACKITEM *i)
  43 {
  44   coop_init();
  45
  46   scm_tc16_thread = scm_make_smob_type ("thread", 0);
  47   scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (coop_m));
  48   scm_tc16_condvar = scm_make_smob_type ("condition-variable",
  49                                          sizeof (coop_c));
  50
  51   scm_thread_count = 1;
  52
  53 #ifndef GUILE_PTHREAD_COMPAT
  54   coop_global_main.sto = i;
  55 #endif
  56   coop_global_main.base = i;
  57   coop_global_curr = &coop_global_main;
  58   coop_all_qput (&coop_global_allq, coop_global_curr);
  59
  60   coop_mutex_init (&scm_critical_section_mutex);
  61
  62   coop_global_main.data = 0; /* Initialized in init.c */
  63
  64   coop_global_main.handle = scm_cell (scm_tc16_thread,
  65                                       (scm_t_bits) &coop_global_main);
  66
  67   scm_gc_register_root (&all_threads);
  68   all_threads = scm_cons (coop_global_main.handle, SCM_EOL);
  69 }
  70
  71 void
  72 scm_threads_mark_stacks (void)
  73 {
  74   coop_t *thread;
  75
  76   for (thread = coop_global_allq.t.all_next;
  77        thread != NULL; thread = thread->all_next)
  78     {
  79       if (thread == coop_global_curr)
  80         {
  81           /* Active thread */
  82           /* stack_len is long rather than sizet in order to guarantee
  83              that &stack_len is long aligned */
  84 #if SCM_STACK_GROWS_UP
  85           long stack_len = ((SCM_STACKITEM *) (&thread) -
  86                             (SCM_STACKITEM *) thread->base);
  87
  88           /* Protect from the C stack.  This must be the first marking
  89            * done because it provides information about what objects
  90            * are "in-use" by the C code.   "in-use" objects are  those
  91            * for which the information about length and base address must
  92            * remain usable.   This requirement is stricter than a liveness
  93            * requirement -- in particular, it constrains the implementation
  94            * of scm_resizuve.
  95            */
  96           SCM_FLUSH_REGISTER_WINDOWS;
  97           /* This assumes that all registers are saved into the jmp_buf */
  98           setjmp (scm_save_regs_gc_mark);
  99           scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
 100                               ((size_t) sizeof scm_save_regs_gc_mark
 101                                / sizeof (SCM_STACKITEM)));
 102
 103           scm_mark_locations (((size_t) thread->base,
 104                                (sizet) stack_len));
 105 #else
 106           long stack_len = ((SCM_STACKITEM *) thread->base -
 107                             (SCM_STACKITEM *) (&thread));
 108
 109           /* Protect from the C stack.  This must be the first marking
 110            * done because it provides information about what objects
 111            * are "in-use" by the C code.   "in-use" objects are  those
 112            * for which the information about length and base address must
 113            * remain usable.   This requirement is stricter than a liveness
 114            * requirement -- in particular, it constrains the implementation
 115            * of scm_resizuve.
 116            */
 117           SCM_FLUSH_REGISTER_WINDOWS;
 118           /* This assumes that all registers are saved into the jmp_buf */
 119           setjmp (scm_save_regs_gc_mark);
 120           scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
 121                               ((size_t) sizeof scm_save_regs_gc_mark
 122                                / sizeof (SCM_STACKITEM)));
 123
 124           scm_mark_locations ((SCM_STACKITEM *) &thread,
 125                               stack_len);
 126 #endif
 127         }
 128       else
 129         {
 130           /* Suspended thread */
 131 #if SCM_STACK_GROWS_UP
 132           long stack_len = ((SCM_STACKITEM *) (thread->sp) -
 133                             (SCM_STACKITEM *) thread->base);
 134
 135           scm_mark_locations ((size_t)thread->base,
 136                               (sizet) stack_len);
 137 #else
 138           long stack_len = ((SCM_STACKITEM *) thread->base -
 139                             (SCM_STACKITEM *) (thread->sp));
 140
 141           /* Registers are already on the stack. No need to mark. */
 142
 143           scm_mark_locations ((SCM_STACKITEM *) (size_t)thread->sp,
 144                               stack_len);
 145 #endif
 146         }
 147
 148       /* Mark this thread's root */
 149       scm_gc_mark (((scm_root_state *) thread->data) -> handle);
 150     }
 151 }
 152
 153 /* NOTE: There are TWO mechanisms for starting a thread: The first one
 154    is used when spawning a thread from Scheme, while the second one is
 155    used from C.
 156
 157    It might be argued that the first should be implemented in terms of
 158    the second.  The reason it isn't is that that would require an
 159    extra unnecessary malloc (the thread_args structure).  By providing
 160    one pair of extra functions (c_launch_thread, scm_spawn_thread) the
 161    Scheme threads are started more efficiently.  */
 162
 163 /* This is the first thread spawning mechanism: threads from Scheme */
 164
 165 typedef struct scheme_launch_data {
 166   SCM rootcont;
 167   SCM body;
 168   SCM handler;
 169 } scheme_launch_data;
 170
 171 static SCM
 172 scheme_body_bootstrip (scheme_launch_data* data)
 173 {
 174   /* First save the new root continuation */
 175   data->rootcont = scm_root->rootcont;
 176   return scm_call_0 (data->body);
 177 }
 178
 179 static SCM
 180 scheme_handler_bootstrip (scheme_launch_data* data, SCM tag, SCM throw_args)
 181 {
 182   scm_root->rootcont = data->rootcont;
 183   return scm_apply_1 (data->handler, tag, throw_args);
 184 }
 185
 186 static void
 187 scheme_launch_thread (void *p)
 188 {
 189   /* The thread object will be GC protected by being a member of the
 190      list given as argument to launch_thread.  It will be marked
 191      during the conservative sweep of the stack. */
 192   register SCM argl = (SCM) p;
 193   SCM thread = SCM_CAR (argl);
 194   scheme_launch_data data;
 195   data.rootcont = SCM_BOOL_F;
 196   data.body = SCM_CADR (argl);
 197   data.handler = SCM_CADDR (argl);
 198   scm_internal_cwdr ((scm_t_catch_body) scheme_body_bootstrip,
 199                      &data,
 200                      (scm_t_catch_handler) scheme_handler_bootstrip,
 201                      &data,
 202                      (SCM_STACKITEM *) &thread);
 203   SCM_SET_CELL_WORD_1 (thread, 0);
 204   scm_thread_count--;
 205   all_threads = scm_delq (thread, all_threads);
 206   SCM_DEFER_INTS;
 207 }
 208
 209
 210 SCM
 211 scm_call_with_new_thread (SCM argl)
 212 #define FUNC_NAME s_call_with_new_thread
 213 {
 214   SCM thread;
 215
 216   /* Check arguments. */
 217   {
 218     register SCM args = argl;
 219     SCM thunk, handler;
 220     if (!SCM_CONSP (args))
 221       SCM_WRONG_NUM_ARGS ();
 222     thunk = SCM_CAR (args);
 223     SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
 224                 thunk,
 225                 SCM_ARG1,
 226                 s_call_with_new_thread);
 227     args = SCM_CDR (args);
 228     if (!SCM_CONSP (args))
 229       SCM_WRONG_NUM_ARGS ();
 230     handler = SCM_CAR (args);
 231     SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
 232                 handler,
 233                 SCM_ARG2,
 234                 s_call_with_new_thread);
 235     if (!SCM_NULLP (SCM_CDR (args)))
 236       SCM_WRONG_NUM_ARGS ();
 237   }
 238
 239   /* Make new thread. */
 240   {
 241     coop_t *t;
 242     SCM root, old_winds;
 243
 244     /* Unwind wind chain. */
 245     old_winds = scm_dynwinds;
 246     scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
 247
 248     /* Allocate thread locals. */
 249     root = scm_make_root (scm_root->handle);
 250     /* Make thread. */
 251     thread = scm_cell (scm_tc16_thread, 0);
 252     SCM_DEFER_INTS;
 253     argl = scm_cons (thread, argl);
 254     /* Note that we couldn't pass a pointer to argl as data since the
 255        argl variable may not exist in memory when the thread starts.  */
 256     t = coop_create (scheme_launch_thread, (void *) argl);
 257     t->data = SCM_ROOT_STATE (root);
 258     t->handle = thread;
 259     SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t);
 260     scm_thread_count++;
 261     all_threads = scm_cons (thread, all_threads);
 262     /* Note that the following statement also could cause coop_yield.*/
 263     SCM_ALLOW_INTS;
 264
 265     /* We're now ready for the thread to begin. */
 266     coop_yield();
 267
 268     /* Return to old dynamic context. */
 269     scm_dowinds (old_winds, - scm_ilength (old_winds));
 270   }
 271
 272   return thread;
 273 }
 274 #undef FUNC_NAME
 275
 276
 277 /* This is the second thread spawning mechanism: threads from C */
 278
 279 typedef struct c_launch_data {
 280   union {
 281     SCM thread;
 282     SCM rootcont;
 283   } u;
 284   scm_t_catch_body body;
 285   void *body_data;
 286   scm_t_catch_handler handler;
 287   void *handler_data;
 288 } c_launch_data;
 289
 290 static SCM
 291 c_body_bootstrip (c_launch_data* data)
 292 {
 293   /* First save the new root continuation */
 294   data->u.rootcont = scm_root->rootcont;
 295   return (data->body) (data->body_data);
 296 }
 297
 298 static SCM
 299 c_handler_bootstrip (c_launch_data* data, SCM tag, SCM throw_args)
 300 {
 301   scm_root->rootcont = data->u.rootcont;
 302   return (data->handler) (data->handler_data, tag, throw_args);
 303 }
 304
 305 static void
 306 c_launch_thread (void *p)
 307 {
 308   register c_launch_data *data = (c_launch_data *) p;
 309   /* The thread object will be GC protected by being on this stack */
 310   SCM thread = data->u.thread;
 311   /* We must use the address of `thread', otherwise the compiler will
 312      optimize it away.  This is OK since the longest SCM_STACKITEM
 313      also is a long.  */
 314   scm_internal_cwdr ((scm_t_catch_body) c_body_bootstrip,
 315                      data,
 316                      (scm_t_catch_handler) c_handler_bootstrip,
 317                      data,
 318                      (SCM_STACKITEM *) &thread);
 319   scm_thread_count--;
 320   free ((char *) data);
 321 }
 322
 323 SCM
 324 scm_spawn_thread (scm_t_catch_body body, void *body_data,
 325                   scm_t_catch_handler handler, void *handler_data)
 326 {
 327   SCM thread;
 328   coop_t *t;
 329   SCM root, old_winds;
 330   c_launch_data *data = (c_launch_data *) scm_malloc (sizeof (*data));
 331
 332   /* Unwind wind chain. */
 333   old_winds = scm_dynwinds;
 334   scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
 335
 336   /* Allocate thread locals. */
 337   root = scm_make_root (scm_root->handle);
 338   /* Make thread. */
 339   thread = scm_cell (scm_tc16_thread, 0);
 340   SCM_DEFER_INTS;
 341
 342   data->u.thread = thread;
 343   data->body = body;
 344   data->body_data = body_data;
 345   data->handler = handler;
 346   data->handler_data = handler_data;
 347
 348   t = coop_create (c_launch_thread, (void *) data);
 349   t->data = SCM_ROOT_STATE (root);
 350   t->handle = thread;
 351   SCM_SET_CELL_WORD_1 (thread, (scm_t_bits) t);
 352   scm_thread_count++;
 353   all_threads = scm_cons (thread, all_threads);
 354   /* Note that the following statement also could cause coop_yield.*/
 355   SCM_ALLOW_INTS;
 356
 357   /* We're now ready for the thread to begin. */
 358   coop_yield();
 359
 360   /* Return to old dynamic context. */
 361   scm_dowinds (old_winds, - scm_ilength (old_winds));
 362
 363   return thread;
 364 }
 365
 366 SCM
 367 scm_current_thread (void)
 368 {
 369   return coop_global_curr->handle;
 370 }
 371
 372 SCM
 373 scm_all_threads (void)
 374 {
 375   return all_threads;
 376 }
 377
 378 scm_root_state *
 379 scm_i_thread_root (SCM thread)
 380 {
 381   return (scm_root_state *)((coop_t *)SCM_THREAD_DATA (thread))->data;
 382 }
 383
 384 SCM
 385 scm_join_thread (SCM thread)
 386 #define FUNC_NAME s_join_thread
 387 {
 388   coop_t *thread_data;
 389   SCM_VALIDATE_THREAD (1, thread);
 390   /* Dirk:FIXME:: SCM_THREAD_DATA is a handle for a thread.  It may be that a
 391    * certain thread implementation uses a value of 0 as a valid thread handle.
 392    * With the following code, this thread would always be considered finished.
 393    */
 394   /* Dirk:FIXME:: With preemptive threading, a thread may finish immediately
 395    * after SCM_THREAD_DATA is read.  Thus, it must be guaranteed that the
 396    * handle remains valid until the thread-object is garbage collected, or
 397    * a mutex has to be used for reading and modifying SCM_THREAD_DATA.
 398    */
 399   thread_data = SCM_THREAD_DATA (thread);
 400   if (thread_data)
 401     /* The thread is still alive */
 402     coop_join (thread_data);
 403   /* XXX - return real result. */
 404   return SCM_BOOL_T;
 405 }
 406 #undef FUNC_NAME
 407
 408 int
 409 scm_c_thread_exited_p (SCM thread)
 410 #define FUNC_NAME s_scm_thread_exited_p
 411 {
 412   SCM_VALIDATE_THREAD (1, thread);
 413   return SCM_THREAD_DATA (thread) != NULL;
 414 }
 415 #undef FUNC_NAME
 416
 417 SCM
 418 scm_yield (void)
 419 {
 420   /* Yield early */
 421   scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
 422   coop_yield();
 423
 424   return SCM_BOOL_T;
 425 }
 426
 427 SCM
 428 scm_single_thread_p (void)
 429 {
 430   return (coop_global_runq.tail == &coop_global_runq.t
 431           ? SCM_BOOL_T
 432           : SCM_BOOL_F);
 433 }
 434
 435 SCM
 436 scm_make_mutex (void)
 437 {
 438   SCM m = scm_make_smob (scm_tc16_mutex);
 439   coop_mutex_init (SCM_MUTEX_DATA (m));
 440   return m;
 441 }
 442
 443 SCM
 444 scm_lock_mutex (SCM m)
 445 {
 446   SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
 447   coop_mutex_lock (SCM_MUTEX_DATA (m));
 448   return SCM_BOOL_T;
 449 }
 450
 451 SCM
 452 scm_try_mutex (SCM m)
 453 {
 454   SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
 455   return SCM_BOOL (coop_mutex_trylock (SCM_MUTEX_DATA (m)));
 456 }
 457
 458 SCM
 459 scm_unlock_mutex (SCM m)
 460 {
 461   SCM_ASSERT (SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
 462   coop_mutex_unlock(SCM_MUTEX_DATA (m));
 463
 464   /* Yield early */
 465   scm_switch_counter = SCM_THREAD_SWITCH_COUNT;
 466   coop_yield();
 467
 468   return SCM_BOOL_T;
 469 }
 470
 471 SCM
 472 scm_make_condition_variable (void)
 473 {
 474   SCM c = scm_make_smob (scm_tc16_condvar);
 475   coop_condition_variable_init (SCM_CONDVAR_DATA (c));
 476   return c;
 477 }
 478
 479 SCM
 480 scm_timed_wait_condition_variable (SCM c, SCM m, SCM t)
 481 #define FUNC_NAME s_wait_condition_variable
 482 {
 483   coop_c *cv;
 484   coop_m *mx;
 485   scm_t_timespec waittime;
 486
 487   SCM_ASSERT (SCM_CONDVARP (c),
 488               c,
 489               SCM_ARG1,
 490               s_wait_condition_variable);
 491   SCM_ASSERT (SCM_MUTEXP (m),
 492               m,
 493               SCM_ARG2,
 494               s_wait_condition_variable);
 495
 496   cv = SCM_CONDVAR_DATA (c);
 497   mx = SCM_MUTEX_DATA (m);
 498
 499   if (!SCM_UNBNDP (t))
 500     {
 501       if (SCM_CONSP (t))
 502         {
 503           SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
 504           SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
 505           waittime.tv_nsec *= 1000;
 506         }
 507       else
 508         {
 509           SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
 510           waittime.tv_nsec = 0;
 511         }
 512       return SCM_BOOL(
 513         coop_condition_variable_timed_wait_mutex (cv, mx, &waittime));
 514     }
 515   else
 516     {
 517       coop_condition_variable_wait_mutex (cv, mx);
 518       return SCM_BOOL_T;
 519     }
 520 }
 521 #undef FUNC_NAME
 522
 523 SCM
 524 scm_signal_condition_variable (SCM c)
 525 {
 526   SCM_ASSERT (SCM_CONDVARP (c),
 527               c,
 528               SCM_ARG1,
 529               s_signal_condition_variable);
 530   coop_condition_variable_signal (SCM_CONDVAR_DATA (c));
 531   return SCM_BOOL_T;
 532 }
 533
 534 SCM
 535 scm_broadcast_condition_variable (SCM c)
 536 {
 537   SCM_ASSERT (SCM_CONDVARP (c),
 538               c,
 539               SCM_ARG1,
 540               s_broadcast_condition_variable);
 541   coop_condition_variable_broadcast (SCM_CONDVAR_DATA (c));
 542   return SCM_BOOL_T;
 543 }
 544
 545 /*
 546   Local Variables:
 547   c-file-style: "gnu"
 548   End:
 549 */