libguile/coop-pthreads.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20
  21 #include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */
  22
  23 #include <unistd.h>
  24 #include <stdio.h>
  25 #include <assert.h>
  26 #include <sys/time.h>
  27
  28 #include "libguile/validate.h"
  29 #include "libguile/coop-pthreads.h"
  30 #include "libguile/root.h"
  31 #include "libguile/eval.h"
  32 #include "libguile/async.h"
  33 #include "libguile/ports.h"
  34 #include "libguile/smob.h"
  35
  36 #undef DEBUG
  37
  38 /*** Queues */
  39
  40 static SCM
  41 make_queue ()
  42 {
  43   return scm_cons (SCM_EOL, SCM_EOL);
  44 }
  45
  46 static void
  47 enqueue (SCM q, SCM t)
  48 {
  49   SCM c = scm_cons (t, SCM_EOL);
  50   if (scm_is_null (SCM_CAR (q)))
  51     SCM_SETCAR (q, c);
  52   else
  53     SCM_SETCDR (SCM_CDR (q), c);
  54   SCM_SETCDR (q, c);
  55 }
  56
  57 static SCM
  58 dequeue (SCM q)
  59 {
  60   SCM c = SCM_CAR (q);
  61   if (scm_is_null (c))
  62     return SCM_BOOL_F;
  63   else
  64     {
  65       SCM_SETCAR (q, SCM_CDR (c));
  66       if (scm_is_null (SCM_CAR (q)))
  67         SCM_SETCDR (q, SCM_EOL);
  68       return SCM_CAR (c);
  69     }
  70 }
  71
  72
  73 /*** Threads */
  74
  75 typedef struct scm_copt_thread {
  76
  77   /* A condition variable for sleeping on.
  78    */
  79   pthread_cond_t sleep_cond;
  80
  81   /* A link for waiting queues.
  82    */
  83   struct scm_copt_thread *next_waiting;
  84
  85   scm_root_state *root;
  86   SCM handle;
  87   pthread_t pthread;
  88   SCM result;
  89
  90   SCM joining_threads;
  91
  92   /* For keeping track of the stack and registers. */
  93   SCM_STACKITEM *base;
  94   SCM_STACKITEM *top;
  95   jmp_buf regs;
  96
  97 } scm_copt_thread;
  98
  99 static SCM
 100 make_thread (SCM creation_protects)
 101 {
 102   SCM z;
 103   scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");
 104
 105   SCM_NEWSMOB (z, t);
 106   t->handle = z;
 107   t->result = creation_protects;
 108   t->base = NULL;
 109   t->joining_threads = make_queue ();
 110   pthread_cond_init (&t->sleep_cond, NULL);
 111   return z;
 112 }
 113
 114 static void
 115 init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)
 116 {
 117   scm_copt_thread *t = SCM_THREAD_DATA(thread);
 118   t->root = r;
 119   t->pthread = th;
 120 #ifdef DEBUG
 121   // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
 122 #endif
 123 }
 124
 125 static void
 126 init_thread_creatant (SCM thread, SCM_STACKITEM *base)
 127 {
 128   scm_copt_thread *t = SCM_THREAD_DATA(thread);
 129   t->base = base;
 130   t->top = NULL;
 131 }
 132
 133 static int
 134 thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 135 {
 136   scm_copt_thread *t = SCM_THREAD_DATA (exp);
 137   scm_puts ("#<thread ", port);
 138   scm_uintprint ((scm_t_bits)t, 16, port);
 139   if (t->pthread != -1)
 140     {
 141       scm_putc (' ', port);
 142       scm_intprint (t->pthread, 10, port);
 143     }
 144   else
 145     scm_puts (" (exited)", port);
 146   scm_putc ('>', port);
 147   return 1;
 148 }
 149
 150 static size_t
 151 thread_free (SCM obj)
 152 {
 153   scm_copt_thread *t = SCM_THREAD_DATA (obj);
 154   if (t->pthread != -1)
 155     abort ();
 156   scm_gc_free (t, sizeof (*t), "thread");
 157   return 0;
 158 }
 159
 160 /*** Fair mutexes */
 161
 162 /* POSIX mutexes are not necessarily fair but since we'd like to use a
 163    mutex for scheduling, we build a fair one on top of POSIX.
 164 */
 165
 166 typedef struct fair_mutex {
 167   pthread_mutex_t lock;
 168   scm_copt_thread *owner;
 169   scm_copt_thread *next_waiting, *last_waiting;
 170 } fair_mutex;
 171
 172 static void
 173 fair_mutex_init (fair_mutex *m)
 174 {
 175   pthread_mutex_init (&m->lock, NULL);
 176   m->owner = NULL;
 177   m->next_waiting = NULL;
 178   m->last_waiting = NULL;
 179 }
 180
 181 static void
 182 fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t)
 183 {
 184   if (m->owner == NULL)
 185     m->owner = t;
 186   else
 187     {
 188       t->next_waiting = NULL;
 189       if (m->last_waiting)
 190         m->last_waiting->next_waiting = t;
 191       else
 192         m->next_waiting = t;
 193       m->last_waiting = t;
 194       do
 195         {
 196           pthread_cond_wait (&t->sleep_cond, &m->lock);
 197         }
 198       while (m->owner != t);
 199       assert (m->next_waiting == t);
 200       m->next_waiting = t->next_waiting;
 201       if (m->next_waiting == NULL)
 202         m->last_waiting = NULL;
 203     }
 204   pthread_mutex_unlock (&m->lock);
 205 }
 206
 207 static void
 208 fair_mutex_lock (fair_mutex *m, scm_copt_thread *t)
 209 {
 210   pthread_mutex_lock (&m->lock);
 211   fair_mutex_lock_1 (m, t);
 212 }
 213
 214 static void
 215 fair_mutex_unlock_1 (fair_mutex *m)
 216 {
 217   scm_copt_thread *t;
 218   pthread_mutex_lock (&m->lock);
 219   // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
 220   if ((t = m->next_waiting) != NULL)
 221     {
 222       m->owner = t;
 223       pthread_cond_signal (&t->sleep_cond);
 224     }
 225   else
 226     m->owner = NULL;
 227   // fprintf (stderr, "%ld unlocked\n", pthread_self ());
 228 }
 229
 230 static void
 231 fair_mutex_unlock (fair_mutex *m)
 232 {
 233   fair_mutex_unlock_1 (m);
 234   pthread_mutex_unlock (&m->lock);
 235 }
 236
 237 /*  Temporarily give up the mutex.  This function makes sure that we
 238     are on the wait queue before starting the next thread.  Otherwise
 239     the next thread might preempt us and we will have a hard time
 240     getting on the wait queue.
 241 */
 242 #if 0
 243 static void
 244 fair_mutex_yield (fair_mutex *m)
 245 {
 246   scm_copt_thread *self, *next;
 247
 248   pthread_mutex_lock (&m->lock);
 249
 250   /* get next thread
 251    */
 252   if ((next = m->next_waiting) == NULL)
 253     {
 254       /* No use giving it up. */
 255       pthread_mutex_unlock (&m->lock);
 256       return;
 257     }
 258
 259   /* put us on queue
 260    */
 261   self = m->owner;
 262   self->next_waiting = NULL;
 263   if (m->last_waiting)
 264     m->last_waiting->next_waiting = self;
 265   else
 266     m->next_waiting = self;
 267   m->last_waiting = self;
 268
 269   /* wake up next thread
 270    */
 271
 272   m->owner = next;
 273   pthread_cond_signal (&next->sleep_cond);
 274
 275   /* wait for mutex
 276    */
 277   do
 278     {
 279       pthread_cond_wait (&self->sleep_cond, &m->lock);
 280     }
 281   while (m->owner != self);
 282   assert (m->next_waiting == self);
 283   m->next_waiting = self->next_waiting;
 284   if (m->next_waiting == NULL)
 285     m->last_waiting = NULL;
 286
 287   pthread_mutex_unlock (&m->lock);
 288 }
 289 #else
 290 static void
 291 fair_mutex_yield (fair_mutex *m)
 292 {
 293   scm_copt_thread *self = m->owner;
 294   fair_mutex_unlock_1 (m);
 295   fair_mutex_lock_1 (m, self);
 296 }
 297 #endif
 298
 299 static void
 300 fair_cond_wait (pthread_cond_t *c, fair_mutex *m)
 301 {
 302   scm_copt_thread *t = m->owner;
 303   fair_mutex_unlock_1 (m);
 304   pthread_cond_wait (c, &m->lock);
 305   fair_mutex_lock_1 (m, t);
 306 }
 307
 308 /* Return 1 when the mutex was signalled and 0 when not. */
 309 static int
 310 fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at)
 311 {
 312   int res;
 313   scm_copt_thread *t = m->owner;
 314   fair_mutex_unlock_1 (m);
 315   res = pthread_cond_timedwait (c, &m->lock, at);  /* XXX - signals? */
 316   fair_mutex_lock_1 (m, t);
 317   return res == 0;
 318 }
 319
 320 /*** Scheduling */
 321
 322 /* When a thread wants to execute Guile functions, it locks the
 323    guile_mutex.
 324 */
 325
 326 static fair_mutex guile_mutex;
 327
 328 static SCM cur_thread;
 329 void *scm_i_copt_thread_data;
 330
 331 void
 332 scm_i_copt_set_thread_data (void *data)
 333 {
 334   scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
 335   scm_i_copt_thread_data = data;
 336   t->root = (scm_root_state *)data;
 337 }
 338
 339 static void
 340 resume (scm_copt_thread *t)
 341 {
 342   cur_thread = t->handle;
 343   scm_i_copt_thread_data = t->root;
 344   t->top = NULL;
 345 }
 346
 347 static void
 348 enter_guile (scm_copt_thread *t)
 349 {
 350   fair_mutex_lock (&guile_mutex, t);
 351   resume (t);
 352 }
 353
 354 static scm_copt_thread *
 355 suspend ()
 356 {
 357   SCM cur = cur_thread;
 358   scm_copt_thread *c = SCM_THREAD_DATA (cur);
 359
 360   /* record top of stack for the GC */
 361   c->top = (SCM_STACKITEM *)&c;
 362   /* save registers. */
 363   SCM_FLUSH_REGISTER_WINDOWS;
 364   setjmp (c->regs);
 365
 366   return c;
 367 }
 368
 369 static scm_copt_thread *
 370 leave_guile ()
 371 {
 372   scm_copt_thread *c = suspend ();
 373   fair_mutex_unlock (&guile_mutex);
 374   return c;
 375 }
 376
 377 int scm_i_switch_counter;
 378
 379 SCM
 380 scm_yield ()
 381 {
 382   /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
 383      is OK since the outcome is not critical.  Even when it changes
 384      after the test, we do the right thing.
 385   */
 386   if (guile_mutex.next_waiting)
 387     {
 388       scm_copt_thread *t = suspend ();
 389       fair_mutex_yield (&guile_mutex);
 390       resume (t);
 391     }
 392   return SCM_BOOL_T;
 393 }
 394
 395 /* Put the current thread to sleep until it is explicitely unblocked.
 396  */
 397 static void
 398 block ()
 399 {
 400   scm_copt_thread *t = suspend ();
 401   fair_cond_wait (&t->sleep_cond, &guile_mutex);
 402   resume (t);
 403 }
 404
 405 /* Put the current thread to sleep until it is explicitely unblocked
 406    or until a signal arrives or until time AT (absolute time) is
 407    reached.  Return 1 when it has been unblocked; 0 otherwise.
 408  */
 409 static int
 410 timed_block (scm_t_timespec *at)
 411 {
 412   int res;
 413   scm_copt_thread *t = suspend ();
 414   res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
 415   resume (t);
 416   return res;
 417 }
 418
 419 /* Unblock a sleeping thread.
 420  */
 421 static void
 422 unblock (scm_copt_thread *t)
 423 {
 424   pthread_cond_signal (&t->sleep_cond);
 425 }
 426
 427 /*** Thread creation */
 428
 429 static SCM all_threads;
 430 static int thread_count;
 431
 432 typedef struct launch_data {
 433   SCM thread;
 434   SCM rootcont;
 435   scm_t_catch_body body;
 436   void *body_data;
 437   scm_t_catch_handler handler;
 438   void *handler_data;
 439 } launch_data;
 440
 441 static SCM
 442 body_bootstrip (launch_data* data)
 443 {
 444   /* First save the new root continuation */
 445   data->rootcont = scm_root->rootcont;
 446   return (data->body) (data->body_data);
 447   // return scm_call_0 (data->body);
 448 }
 449
 450 static SCM
 451 handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
 452 {
 453   scm_root->rootcont = data->rootcont;
 454   return (data->handler) (data->handler_data, tag, throw_args);
 455   // return scm_apply_1 (data->handler, tag, throw_args);
 456 }
 457
 458 static void
 459 really_launch (SCM_STACKITEM *base, launch_data *data)
 460 {
 461   SCM thread = data->thread;
 462   scm_copt_thread *t = SCM_THREAD_DATA (thread);
 463   init_thread_creatant (thread, base);
 464   enter_guile (t);
 465
 466   data->rootcont = SCM_BOOL_F;
 467   t->result =
 468     scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
 469                        data,
 470                        (scm_t_catch_handler) handler_bootstrip,
 471                        data, base);
 472   free (data);
 473
 474   pthread_detach (t->pthread);
 475   all_threads = scm_delq (thread, all_threads);
 476   t->pthread = -1;
 477   thread_count--;
 478   leave_guile ();
 479 }
 480
 481 static void *
 482 launch_thread (void *p)
 483 {
 484   really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
 485   return NULL;
 486 }
 487
 488 static SCM
 489 create_thread (scm_t_catch_body body, void *body_data,
 490                scm_t_catch_handler handler, void *handler_data,
 491                SCM protects)
 492 {
 493   SCM thread;
 494
 495   /* Make new thread.  The first thing the new thread will do is to
 496      lock guile_mutex.  Thus, we can safely complete its
 497      initialization after creating it.  While the new thread starts,
 498      all its data is protected via all_threads.
 499    */
 500
 501   {
 502     pthread_t th;
 503     SCM root, old_winds;
 504     launch_data *data;
 505
 506     /* Unwind wind chain. */
 507     old_winds = scm_dynwinds;
 508     scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
 509
 510     /* Allocate thread locals. */
 511     root = scm_make_root (scm_root->handle);
 512     data = scm_gc_malloc (sizeof (launch_data));
 513
 514     /* Make thread. */
 515     thread = make_thread (protects);
 516     data->thread = thread;
 517     data->body = body;
 518     data->body_data = body_data;
 519     data->handler = handler;
 520     data->handler_data = handler_data;
 521     pthread_create (&th, NULL, launch_thread, (void *) data);
 522     init_thread_creator (thread, th, SCM_ROOT_STATE (root));
 523     all_threads = scm_cons (thread, all_threads);
 524     thread_count++;
 525
 526     /* Return to old dynamic context. */
 527     scm_dowinds (old_winds, - scm_ilength (old_winds));
 528   }
 529
 530   return thread;
 531 }
 532
 533 SCM
 534 scm_call_with_new_thread (SCM argl)
 535 #define FUNC_NAME s_call_with_new_thread
 536 {
 537   SCM thunk, handler;
 538
 539   /* Check arguments. */
 540   {
 541     register SCM args = argl;
 542     if (!scm_is_pair (args))
 543       SCM_WRONG_NUM_ARGS ();
 544     thunk = SCM_CAR (args);
 545     SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)),
 546                 thunk,
 547                 SCM_ARG1,
 548                 s_call_with_new_thread);
 549     args = SCM_CDR (args);
 550     if (!scm_is_pair (args))
 551       SCM_WRONG_NUM_ARGS ();
 552     handler = SCM_CAR (args);
 553     SCM_ASSERT (scm_is_true (scm_procedure_p (handler)),
 554                 handler,
 555                 SCM_ARG2,
 556                 s_call_with_new_thread);
 557     if (!scm_is_null (SCM_CDR (args)))
 558       SCM_WRONG_NUM_ARGS ();
 559   }
 560
 561   return create_thread ((scm_t_catch_body) scm_call_0, thunk,
 562                         (scm_t_catch_handler) scm_apply_1, handler,
 563                         argl);
 564 }
 565 #undef FUNC_NAME
 566
 567 SCM
 568 scm_spawn_thread (scm_t_catch_body body, void *body_data,
 569                   scm_t_catch_handler handler, void *handler_data)
 570 {
 571   return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
 572 }
 573
 574 /*** Mutexes */
 575
 576 /* We implement our own mutex type since we want them to be 'fair', we
 577    want to do fancy things while waiting for them (like running
 578    asyncs) and we want to support waiting on many things at once.
 579    Also, we might add things that are nice for debugging.
 580 */
 581
 582 typedef struct scm_copt_mutex {
 583   /* the thread currently owning the mutex, or SCM_BOOL_F. */
 584   SCM owner;
 585   /* how much the owner owns us. */
 586   int level;
 587   /* the threads waiting for this mutex. */
 588   SCM waiting;
 589 } scm_copt_mutex;
 590
 591
 592 SCM
 593 scm_make_mutex ()
 594 {
 595   SCM mx = scm_make_smob (scm_tc16_mutex);
 596   scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
 597   m->owner = SCM_BOOL_F;
 598   m->level = 0;
 599   m->waiting = make_queue ();
 600   return mx;
 601 }
 602
 603 SCM
 604 scm_lock_mutex (SCM mx)
 605 #define FUNC_NAME s_lock_mutex
 606 {
 607   scm_copt_mutex *m;
 608   SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
 609   m = SCM_MUTEX_DATA (mx);
 610
 611   if (m->owner == SCM_BOOL_F)
 612     m->owner = cur_thread;
 613   else if (m->owner == cur_thread)
 614     m->level++;
 615   else
 616     {
 617       while (m->owner != cur_thread)
 618         {
 619           enqueue (m->waiting, cur_thread);
 620           block ();
 621           SCM_ASYNC_TICK;
 622         }
 623     }
 624   return SCM_BOOL_T;
 625 }
 626 #undef FUNC_NAME
 627
 628 SCM
 629 scm_try_mutex (SCM mx)
 630 #define FUNC_NAME s_try_mutex
 631 {
 632   scm_copt_mutex *m;
 633   SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
 634   m = SCM_MUTEX_DATA (mx);
 635
 636   if (m->owner == SCM_BOOL_F)
 637     m->owner = cur_thread;
 638   else if (m->owner == cur_thread)
 639     m->level++;
 640   else
 641     return SCM_BOOL_F;
 642   return SCM_BOOL_T;
 643 }
 644 #undef FUNC_NAME
 645
 646 SCM
 647 scm_unlock_mutex (SCM mx)
 648 #define FUNC_NAME s_unlock_mutex
 649 {
 650   scm_copt_mutex *m;
 651   SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
 652   m = SCM_MUTEX_DATA (mx);
 653
 654   if (m->owner != cur_thread)
 655     {
 656       if (m->owner == SCM_BOOL_F)
 657         SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
 658       else
 659         SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
 660     }
 661   else if (m->level > 0)
 662     m->level--;
 663   else
 664     {
 665       SCM next = dequeue (m->waiting);
 666       if (scm_is_true (next))
 667         {
 668           m->owner = next;
 669           unblock (SCM_THREAD_DATA (next));
 670           scm_yield ();
 671         }
 672       else
 673         m->owner = SCM_BOOL_F;
 674     }
 675   return SCM_BOOL_T;
 676 }
 677 #undef FUNC_NAME
 678
 679 /*** Condition variables */
 680
 681 /* Like mutexes, we implement our own condition variables using the
 682    primitives above.
 683 */
 684
 685 /* yeah, we don't need a structure for this, but more things (like a
 686    name) will likely follow... */
 687
 688 typedef struct scm_copt_cond {
 689   /* the threads waiting for this condition. */
 690   SCM waiting;
 691 } scm_copt_cond;
 692
 693 static SCM
 694 cond_mark (SCM cv)
 695 {
 696   scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
 697   return c->waiting;
 698 }
 699
 700 SCM
 701 scm_make_condition_variable (void)
 702 {
 703   SCM cv = scm_make_smob (scm_tc16_condvar);
 704   scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
 705   c->waiting = make_queue ();
 706   return cv;
 707 }
 708
 709 SCM
 710 scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t)
 711 #define FUNC_NAME s_wait_condition_variable
 712 {
 713   scm_copt_cond *c;
 714   scm_t_timespec waittime;
 715   int res;
 716
 717   SCM_ASSERT (SCM_CONDVARP (cv),
 718               cv,
 719               SCM_ARG1,
 720               s_wait_condition_variable);
 721   SCM_ASSERT (SCM_MUTEXP (mx),
 722               mx,
 723               SCM_ARG2,
 724               s_wait_condition_variable);
 725   if (!SCM_UNBNDP (t))
 726     {
 727       if (scm_is_pair (t))
 728         {
 729           SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
 730           SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
 731           waittime.tv_nsec *= 1000;
 732         }
 733       else
 734         {
 735           SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
 736           waittime.tv_nsec = 0;
 737         }
 738     }
 739
 740   c = SCM_CONDVAR_DATA (cv);
 741
 742   enqueue (c->waiting, cur_thread);
 743   scm_unlock_mutex (mx);
 744   if (SCM_UNBNDP (t))
 745     {
 746       block ();
 747       res = 1;
 748     }
 749   else
 750     res = timed_block (&waittime);
 751   scm_lock_mutex (mx);
 752   return scm_from_bool (res);
 753 }
 754 #undef FUNC_NAME
 755
 756 SCM
 757 scm_signal_condition_variable (SCM cv)
 758 #define FUNC_NAME s_signal_condition_variable
 759 {
 760   SCM th;
 761   scm_copt_cond *c;
 762   SCM_ASSERT (SCM_CONDVARP (cv),
 763               cv,
 764               SCM_ARG1,
 765               s_signal_condition_variable);
 766   c = SCM_CONDVAR_DATA (cv);
 767   if (scm_is_true (th = dequeue (c->waiting)))
 768     unblock (SCM_THREAD_DATA (th));
 769   return SCM_BOOL_T;
 770 }
 771 #undef FUNC_NAME
 772
 773 SCM
 774 scm_broadcast_condition_variable (SCM cv)
 775 #define FUNC_NAME s_broadcast_condition_variable
 776 {
 777   SCM th;
 778   scm_copt_cond *c;
 779   SCM_ASSERT (SCM_CONDVARP (cv),
 780               cv,
 781               SCM_ARG1,
 782               s_signal_condition_variable);
 783   c = SCM_CONDVAR_DATA (cv);
 784   while (scm_is_true (th = dequeue (c->waiting)))
 785     unblock (SCM_THREAD_DATA (th));
 786   return SCM_BOOL_T;
 787 }
 788 #undef FUNC_NAME
 789
 790 /*** Initialization */
 791
 792 void
 793 scm_threads_init (SCM_STACKITEM *base)
 794 {
 795   scm_tc16_thread = scm_make_smob_type ("thread", 0);
 796   scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex));
 797   scm_tc16_condvar = scm_make_smob_type ("condition-variable",
 798                                          sizeof (scm_copt_cond));
 799
 800   scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;
 801
 802   fair_mutex_init (&guile_mutex);
 803
 804   cur_thread = make_thread (SCM_BOOL_F);
 805   enter_guile (SCM_THREAD_DATA (cur_thread));
 806   /* root is set later from init.c */
 807   init_thread_creator (cur_thread, pthread_self(), NULL);
 808   init_thread_creatant (cur_thread, base);
 809
 810   thread_count = 1;
 811   scm_gc_register_root (&all_threads);
 812   all_threads = scm_cons (cur_thread, SCM_EOL);
 813
 814   scm_set_smob_print (scm_tc16_thread, thread_print);
 815 }
 816
 817 /*** Marking stacks */
 818
 819 /* XXX - what to do with this?  Do we need to handle this for blocked
 820    threads as well?
 821 */
 822 #ifdef __ia64__
 823 # define SCM_MARK_BACKING_STORE() do {                                \
 824     ucontext_t ctx;                                                   \
 825     SCM_STACKITEM * top, * bot;                                       \
 826     getcontext (&ctx);                                                \
 827     scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext,           \
 828       ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
 829        / sizeof (SCM_STACKITEM)));                                    \
 830     bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base ();  \
 831     top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx);                   \
 832     scm_mark_locations (bot, top - bot); } while (0)
 833 #else
 834 # define SCM_MARK_BACKING_STORE()
 835 #endif
 836
 837
 838
 839 /*** Select */
 840
 841 int
 842 scm_internal_select (int nfds,
 843                      SELECT_TYPE *readfds,
 844                      SELECT_TYPE *writefds,
 845                      SELECT_TYPE *exceptfds,
 846                      struct timeval *timeout)
 847 {
 848   int res, eno;
 849   scm_copt_thread *c = leave_guile ();
 850   res = select (nfds, readfds, writefds, exceptfds, timeout);
 851   eno = errno;
 852   enter_guile (c);
 853   SCM_ASYNC_TICK;
 854   errno = eno;
 855   return res;
 856 }
 857
 858 void
 859 scm_init_iselect ()
 860 {
 861 }
 862
 863 unsigned long
 864 scm_thread_usleep (unsigned long usec)
 865 {
 866   scm_copt_thread *c = leave_guile ();
 867   usleep (usec);
 868   enter_guile (c);
 869   return 0;
 870 }
 871
 872 unsigned long
 873 scm_thread_sleep (unsigned long sec)
 874 {
 875   unsigned long res;
 876   scm_copt_thread *c = leave_guile ();
 877   res = sleep (sec);
 878   enter_guile (c);
 879   return res;
 880 }
 881
 882 /*** Misc */
 883
 884 SCM
 885 scm_current_thread (void)
 886 {
 887   return cur_thread;
 888 }
 889
 890 SCM
 891 scm_all_threads (void)
 892 {
 893   return all_threads;
 894 }
 895
 896 scm_root_state *
 897 scm_i_thread_root (SCM thread)
 898 {
 899   if (thread == cur_thread)
 900     return scm_i_copt_thread_data;
 901   else
 902     return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;
 903 }
 904
 905 SCM
 906 scm_join_thread (SCM thread)
 907 #define FUNC_NAME s_join_thread
 908 {
 909   scm_copt_thread *t;
 910   SCM res;
 911
 912   SCM_VALIDATE_THREAD (1, thread);
 913
 914   t = SCM_THREAD_DATA (thread);
 915   if (t->pthread != -1)
 916     {
 917       scm_copt_thread *c = leave_guile ();
 918       pthread_join (t->pthread, NULL);
 919       enter_guile (c);
 920     }
 921   res = t->result;
 922   t->result = SCM_BOOL_F;
 923   return res;
 924 }
 925 #undef FUNC_NAME
 926
 927 int
 928 scm_c_thread_exited_p (SCM thread)
 929 #define FUNC_NAME s_scm_thread_exited_p
 930 {
 931   scm_copt_thread *t;
 932   SCM_VALIDATE_THREAD (1, thread);
 933   t = SCM_THREAD_DATA (thread);
 934   return t->pthread == -1;
 935 }
 936 #undef FUNC_NAME
 937
 938 /*
 939   Local Variables:
 940   c-file-style: "gnu"
 941   End:
 942 */
 943