libguile/mit-pthreads.c

   1 /*      Copyright (C) 1995, 1996 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 typedef struct scm_pthread_info {
  44   queue q;                   /* the dequeue on which this structure exists */
  45                              /* reqired to be the first element */
  46   pthread_t thread;          /* the corresponding thread structure */
  47   void *stack_top;           /* the highest address in this thread's stack */
  48   scm_root_state *root;      /* root for this thread */
  49 } scm_pthread_info;
  50
  51 pthread_mutex_t scm_critical_section_mutex;
  52 pthread_t scm_critical_section_owner;
  53
  54 static queue infos = { &infos, &infos };  /* the dequeue of info structures */
  55
  56 /* Key to thread specific data */
  57 pthread_key_t info_key;
  58
  59 #ifdef __STDC__
  60 size_t
  61 scm_threads_free_thread (SCM t)
  62 #else
  63 size_t
  64 scm_threads_free_thread (t)
  65      SCM t;
  66 #endif
  67 {
  68   scm_must_free (SCM_THREAD_DATA (t));
  69   return sizeof (pthread_t);
  70 }
  71
  72 #ifdef __STDC__
  73 size_t
  74 scm_threads_free_mutex (SCM m)
  75 #else
  76 size_t
  77 scm_threads_free_mutex (m)
  78      SCM m;
  79 #endif
  80 {
  81   pthread_mutex_destroy (SCM_MUTEX_DATA (m));
  82   scm_must_free (SCM_MUTEX_DATA (m));
  83   return sizeof (pthread_mutex_t);
  84 }
  85
  86 #ifdef __STDC__
  87 size_t
  88 scm_threads_free_condvar (SCM c)
  89 #else
  90 size_t
  91 scm_threads_free_condvar (c)
  92      SCM c;
  93 #endif
  94 {
  95   pthread_cond_destroy (SCM_CONDVAR_DATA (c));
  96   scm_must_free (SCM_CONDVAR_DATA (c));
  97   return sizeof (pthread_cond_t);
  98 }
  99
 100 /* cleanup for info structure
 101  */
 102 #ifdef __STDC__
 103 static void
 104 scm_pthread_delete_info (void *ptr)
 105 #else
 106 static void
 107 scm_pthread_delete_info (ptr)
 108      void *ptr;
 109 #endif
 110 {
 111   scm_pthread_info *info = (scm_pthread_info *) ptr;
 112   info->q.blink->flink = info->q.flink;
 113   info->q.flink->blink = info->q.blink;
 114   scm_must_free ((char *) info);
 115 }
 116
 117 #ifdef __STDC__
 118 void
 119 scm_threads_init (SCM_STACKITEM *i)
 120 #else
 121 void
 122 scm_threads_init (i)
 123      SCM_STACKITEM *i;
 124 #endif
 125 {
 126   /*
 127    * each info structure is made thread-specific, so that the cleanup
 128    * mechanism can be used to reclaim the space in a timely fashion.
 129    */
 130   pthread_key_create (&info_key, scm_pthread_delete_info);
 131
 132   /* initialize various mutex variables */
 133   pthread_mutex_init (&scm_critical_section_mutex, NULL);
 134
 135   /*
 136    * create an info structure for the initial thread and push it onto
 137    * the info dequeue
 138    */
 139   {
 140     scm_pthread_info *info;
 141     info = (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
 142                                                  "threads_init");
 143     infos.flink = infos.blink = &info->q;
 144     info->q.flink = info->q.blink = &infos;
 145     info->thread = pthread_initial;
 146     info->stack_top = (void *) i;
 147     pthread_setspecific(info_key, info);
 148   }
 149   /* The root state pointer gets initialized in init.c. */
 150 }
 151
 152 /* given some thread, find the corresponding info
 153  */
 154 static scm_pthread_info *pthreads_find_info (pthread_t target)
 155 {
 156   queue *ptr = infos.flink;
 157
 158   while (ptr != &infos)
 159     {
 160       scm_pthread_info *info = (scm_pthread_info *) ptr;
 161
 162       if (info->thread == target)
 163         {
 164           return (info);
 165         }
 166       ptr = ptr->flink;
 167     }
 168 }
 169
 170 #ifdef __STDC__
 171 void
 172 scm_threads_mark_stacks ()
 173 #else
 174 void
 175 scm_threads_mark_stacks ()
 176 #endif
 177 {
 178   scm_pthread_info *info;
 179   pthread_t thread;
 180   int j;
 181
 182   for (info = (scm_pthread_info *) infos.flink;
 183        info != (scm_pthread_info *) &infos;
 184        info = (scm_pthread_info *) info->q.flink)
 185     {
 186       thread = info->thread;
 187       if (thread == pthread_run)
 188         {
 189           /* Active thread */
 190           /* stack_len is long rather than sizet in order to guarantee
 191              that &stack_len is long aligned */
 192 #ifdef STACK_GROWS_UP
 193           long stack_len = ((SCM_STACKITEM *) (&thread) -
 194                             (SCM_STACKITEM *) info->stack_top);
 195
 196           /* Protect from the C stack.  This must be the first marking
 197            * done because it provides information about what objects
 198            * are "in-use" by the C code.   "in-use" objects are  those
 199            * for which the values from SCM_LENGTH and SCM_CHARS must remain
 200            * usable.   This requirement is stricter than a liveness
 201            * requirement -- in particular, it constrains the implementation
 202            * of scm_resizuve.
 203            */
 204           SCM_FLUSH_REGISTER_WINDOWS;
 205           /* This assumes that all registers are saved into the jmp_buf */
 206           setjmp (scm_save_regs_gc_mark);
 207           scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
 208                               ((scm_sizet) sizeof scm_save_regs_gc_mark
 209                                / sizeof (SCM_STACKITEM)));
 210
 211           scm_mark_locations (((size_t) info->stack_top,
 212                                (sizet) stack_len));
 213 #else
 214           long stack_len = ((SCM_STACKITEM *) info->stack_top -
 215                             (SCM_STACKITEM *) (&thread));
 216
 217           /* Protect from the C stack.  This must be the first marking
 218            * done because it provides information about what objects
 219            * are "in-use" by the C code.   "in-use" objects are  those
 220            * for which the values from SCM_LENGTH and SCM_CHARS must remain
 221            * usable.   This requirement is stricter than a liveness
 222            * requirement -- in particular, it constrains the implementation
 223            * of scm_resizuve.
 224            */
 225           SCM_FLUSH_REGISTER_WINDOWS;
 226           /* This assumes that all registers are saved into the jmp_buf */
 227           setjmp (scm_save_regs_gc_mark);
 228           scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
 229                               ((scm_sizet) sizeof scm_save_regs_gc_mark
 230                                / sizeof (SCM_STACKITEM)));
 231
 232           scm_mark_locations ((SCM_STACKITEM *) &thread,
 233                               stack_len);
 234 #endif
 235         }
 236       else
 237         {
 238           /* Suspended thread */
 239 #ifdef STACK_GROWS_UP
 240           long stack_len = ((SCM_STACKITEM *) (thread->THREAD_SP) -
 241                             (SCM_STACKITEM *) info->stack_top);
 242
 243           scm_mark_locations ((size_t)info->stack_top,
 244                               (sizet) stack_len);
 245 #else
 246           long stack_len = ((SCM_STACKITEM *) info->stack_top -
 247                             (SCM_STACKITEM *) (thread->THREAD_SP));
 248
 249           scm_mark_locations ((SCM_STACKITEM *) thread->machdep_data.machdep_state,
 250                               ((scm_sizet) sizeof (*thread->machdep_data.machdep_state)
 251                                / sizeof (SCM_STACKITEM)));
 252           scm_mark_locations ((SCM_STACKITEM *) (size_t) thread->THREAD_SP,
 253                               stack_len);
 254 #endif
 255         }
 256
 257       /* Mark this thread's root */
 258       scm_gc_mark (((scm_root_state *) info->root) -> handle);
 259     }
 260 }
 261
 262 #ifdef __STDC__
 263 void *
 264 launch_thread (void *p)
 265 #else
 266 void *
 267 launch_thread (p)
 268      void *p;
 269 #endif
 270 {
 271   /* The thread object will be GC protected by being a member of the
 272      list given as argument to launch_thread.  It will be marked
 273      during the conservative sweep of the stack. */
 274   SCM args = (SCM) p;
 275   pthread_attr_setcleanup (&pthread_self () -> attr,
 276                            NULL,
 277                            SCM_ROOT_STATE (SCM_CAR (args)));
 278   scm_call_with_dynamic_root (SCM_CADDR (args), SCM_CADDDR (args));
 279   return NULL;
 280 }
 281
 282 #ifdef __STDC__
 283 SCM
 284 scm_call_with_new_thread (SCM argl)
 285 #else
 286 SCM
 287 scm_call_with_new_thread (argl)
 288      SCM argl;
 289 #endif
 290 {
 291   SCM thread;
 292
 293   /* Check arguments. */
 294   {
 295     register SCM args = argl;
 296     SCM thunk, handler;
 297     SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
 298     thunk = SCM_CAR (args);
 299     SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (thunk)),
 300                 thunk,
 301                 SCM_ARG1,
 302                 s_call_with_new_thread);
 303     args = SCM_CDR (args);
 304     SCM_ASSERT (SCM_NIMP (args), argl, SCM_WNA, s_call_with_new_thread);
 305     handler = SCM_CAR (args);
 306     SCM_ASSERT (SCM_NFALSEP (scm_procedure_p (handler)),
 307                 handler,
 308                 SCM_ARG2,
 309                 s_call_with_new_thread);
 310     SCM_ASSERT (SCM_NULLP (SCM_CDR (args)), argl, SCM_WNA, s_call_with_new_thread);
 311   }
 312
 313   /* Make new thread. */
 314   {
 315     pthread_attr_t attr;
 316     pthread_t t;
 317     scm_pthread_info *info =
 318       (scm_pthread_info *) scm_must_malloc (sizeof (scm_pthread_info),
 319                                             "pthread_info");
 320     SCM root, old_winds;
 321
 322     /* Unwind wind chain. */
 323     old_winds = scm_dynwinds;
 324     scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
 325
 326     /* Allocate thread locals. */
 327     root = scm_make_root (scm_root->handle);
 328     /* Make thread. */
 329     SCM_NEWCELL (thread);
 330     SCM_DEFER_INTS;
 331     SCM_SETCAR (thread, scm_tc16_thread);
 332     argl = scm_cons2 (root, thread, argl);
 333
 334     /* thread mustn't start until we've built the info struct */
 335     pthread_kernel_lock++;
 336
 337     /* initialize and create the thread. */
 338     pthread_attr_init (&attr);
 339     pthread_attr_setschedpolicy (&attr, SCHED_RR);
 340
 341     pthread_create (&t, &attr, launch_thread, (void *) argl);
 342     pthread_attr_destroy (&attr);
 343
 344     /* push the info onto the dequeue */
 345     info->q.flink = infos.flink;
 346     info->q.blink = &infos;
 347     infos.flink->blink = &info->q;
 348     infos.flink = &info->q;
 349     /* pthread_create filled in the initial SP -- profitons-en ! */
 350     info->stack_top = (void *) (t->THREAD_SP);
 351     info->thread = t;
 352     info->root = SCM_ROOT_STATE (root);
 353     SCM_SETCDR (thread, t);
 354     SCM_ALLOW_INTS;
 355
 356     /* we're now ready for the thread to begin */
 357     pthread_kernel_lock--;
 358
 359     /* Return to old dynamic context. */
 360     scm_dowinds (old_winds, - scm_ilength (old_winds));
 361   }
 362
 363   return thread;
 364 }
 365
 366 #ifdef __STDC__
 367 SCM
 368 scm_join_thread (SCM t)
 369 #else
 370 SCM
 371 scm_join_thread (t)
 372      SCM t;
 373 #endif
 374 {
 375   void *value;
 376   pthread_join (SCM_THREAD_DATA (t), &value);
 377   return SCM_BOOL_T;
 378 }
 379
 380 #ifdef __STDC__
 381 SCM
 382 scm_yield ()
 383 #else
 384 SCM
 385 scm_yield ()
 386 #endif
 387 {
 388   pthread_yield ();
 389   return SCM_BOOL_T;
 390 }
 391
 392 #ifdef __STDC__
 393 SCM
 394 scm_make_mutex ()
 395 #else
 396 SCM
 397 scm_make_mutex ()
 398 #endif
 399 {
 400   SCM m;
 401   pthread_mutex_t *data = (pthread_mutex_t *) scm_must_malloc (sizeof (pthread_mutex_t), "mutex");
 402   SCM_NEWCELL (m);
 403   SCM_DEFER_INTS;
 404   SCM_SETCAR (m, scm_tc16_mutex);
 405   SCM_SETCDR (m, data);
 406   SCM_ALLOW_INTS;
 407   pthread_mutex_init (SCM_MUTEX_DATA (m), NULL);
 408   return m;
 409 }
 410
 411 #ifdef __STDC__
 412 SCM
 413 scm_lock_mutex (SCM m)
 414 #else
 415 SCM
 416 scm_lock_mutex (m)
 417      SCM m;
 418 #endif
 419 {
 420   SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_lock_mutex);
 421   pthread_mutex_lock (SCM_MUTEX_DATA (m));
 422   return SCM_BOOL_T;
 423 }
 424
 425 #ifdef __STDC__
 426 SCM
 427 scm_unlock_mutex (SCM m)
 428 #else
 429 SCM
 430 scm_unlock_mutex (m)
 431      SCM m;
 432 #endif
 433 {
 434   SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m), m, SCM_ARG1, s_unlock_mutex);
 435   pthread_mutex_unlock (SCM_MUTEX_DATA (m));
 436   return SCM_BOOL_T;
 437 }
 438
 439 #ifdef __STDC__
 440 SCM
 441 scm_make_condition_variable ()
 442 #else
 443 SCM
 444 scm_make_condition_variable ()
 445 #endif
 446 {
 447   SCM c;
 448   pthread_cond_t *data = (pthread_cond_t *) scm_must_malloc (sizeof (pthread_cond_t), "condvar");
 449   SCM_NEWCELL (c);
 450   SCM_DEFER_INTS;
 451   SCM_SETCAR (c, scm_tc16_condvar);
 452   SCM_SETCDR (c, data);
 453   SCM_ALLOW_INTS;
 454   pthread_cond_init (SCM_CONDVAR_DATA (c), NULL);
 455   return c;
 456 }
 457
 458 #ifdef __STDC__
 459 SCM
 460 scm_wait_condition_variable (SCM c, SCM m)
 461 #else
 462 SCM
 463 scm_wait_condition_variable (c, m)
 464      SCM c;
 465      SCM m;
 466 #endif
 467 {
 468   SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
 469               c,
 470               SCM_ARG1,
 471               s_wait_condition_variable);
 472   SCM_ASSERT (SCM_NIMP (m) && SCM_MUTEXP (m),
 473               m,
 474               SCM_ARG2,
 475               s_wait_condition_variable);
 476   pthread_cond_wait (SCM_CONDVAR_DATA (m), SCM_MUTEX_DATA (c));
 477   return SCM_BOOL_T;
 478 }
 479
 480 #ifdef __STDC__
 481 SCM
 482 scm_signal_condition_variable (SCM c)
 483 #else
 484 SCM
 485 scm_signal_condition_variable (c)
 486      SCM c;
 487 #endif
 488 {
 489   SCM_ASSERT (SCM_NIMP (c) && SCM_CONDVARP (c),
 490               c,
 491               SCM_ARG1,
 492               s_signal_condition_variable);
 493   pthread_cond_signal (SCM_CONDVAR_DATA (c));
 494   return SCM_BOOL_T;
 495 }