libguile/coop-threads.c

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