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