libguile/coop-threads.c

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