libguile/coop-threads.c

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