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