libguile/coop.c

   1 /*      Copyright (C) 1995, 1996, 1997, 1998, 1999, 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 \f
  42
  43 /* $Id: coop.c,v 1.25 2000-04-21 14:16:30 mdj Exp $ */
  44
  45 /* Cooperative thread library, based on QuickThreads */
  46
  47 #ifdef HAVE_UNISTD_H
  48 #include <unistd.h>
  49 #endif
  50
  51 #include <errno.h>
  52
  53 #include "qt/qt.h"
  54 #include "libguile/eval.h"
  55
  56 \f/* #define COOP_STKSIZE (0x10000) */
  57 #define COOP_STKSIZE (scm_eval_stack)
  58
  59 /* `alignment' must be a power of 2. */
  60 #define COOP_STKALIGN(sp, alignment) \
  61 ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
  62
  63 \f
  64
  65 /* Queue access functions. */
  66
  67 static void
  68 coop_qinit (coop_q_t *q)
  69 {
  70   q->t.next = q->tail = &q->t;
  71
  72   q->t.all_prev = NULL;
  73   q->t.all_next = NULL;
  74 #ifdef GUILE_ISELECT
  75   q->t.nfds = 0;
  76   q->t.readfds = NULL;
  77   q->t.writefds = NULL;
  78   q->t.exceptfds = NULL;
  79   q->t.timeoutp = 0;
  80 #endif
  81 }
  82
  83
  84 coop_t *
  85 coop_qget (coop_q_t *q)
  86 {
  87   coop_t *t;
  88
  89   t = q->t.next;
  90   q->t.next = t->next;
  91   if (t->next == &q->t)
  92     {
  93       if (t == &q->t)
  94         {                       /* If it was already empty .. */
  95           return NULL;          /* .. say so. */
  96         }
  97       q->tail = &q->t;          /* Else now it is empty. */
  98     }
  99   return (t);
 100 }
 101
 102
 103 void
 104 coop_qput (coop_q_t *q, coop_t *t)
 105 {
 106   q->tail->next = t;
 107   t->next = &q->t;
 108   q->tail = t;
 109 }
 110
 111 static void
 112 coop_all_qput (coop_q_t *q, coop_t *t)
 113 {
 114   if (q->t.all_next)
 115     q->t.all_next->all_prev = t;
 116   t->all_prev = NULL;
 117   t->all_next = q->t.all_next;
 118   q->t.all_next = t;
 119 }
 120
 121 static void
 122 coop_all_qremove (coop_q_t *q, coop_t *t)
 123 {
 124   if (t->all_prev)
 125     t->all_prev->all_next = t->all_next;
 126   else
 127     q->t.all_next = t->all_next;
 128   if (t->all_next)
 129       t->all_next->all_prev = t->all_prev;
 130 }
 131
 132 #ifdef GUILE_ISELECT
 133 /* Insert thread t into the ordered queue q.
 134    q is ordered after wakeup_time.  Threads which aren't sleeping but
 135    waiting for I/O go last into the queue. */
 136 void
 137 coop_timeout_qinsert (coop_q_t *q, coop_t *t)
 138 {
 139   coop_t *pred = &q->t;
 140   int sec = t->wakeup_time.tv_sec;
 141   int usec = t->wakeup_time.tv_usec;
 142   while (pred->next != &q->t
 143          && pred->next->timeoutp
 144          && (pred->next->wakeup_time.tv_sec < sec
 145              || (pred->next->wakeup_time.tv_sec == sec
 146                  && pred->next->wakeup_time.tv_usec < usec)))
 147     pred = pred->next;
 148   t->next = pred->next;
 149   pred->next = t;
 150   if (t->next == &q->t)
 151     q->tail = t;
 152 }
 153 #endif
 154
 155
 156 \f/* Thread routines. */
 157
 158 coop_q_t coop_global_runq;      /* A queue of runable threads. */
 159 coop_q_t coop_global_sleepq;    /* A queue of sleeping threads. */
 160 coop_q_t coop_tmp_queue;        /* A temp working queue */
 161 coop_q_t coop_global_allq;      /* A queue of all threads. */
 162 static coop_t coop_global_main; /* Thread for the process. */
 163 coop_t *coop_global_curr;       /* Currently-executing thread. */
 164
 165 #ifdef GUILE_PTHREAD_COMPAT
 166 static coop_q_t coop_deadq;
 167 static int coop_quitting_p = -1;
 168 static pthread_cond_t coop_cond_quit;
 169 static pthread_cond_t coop_cond_create;
 170 static pthread_mutex_t coop_mutex_create;
 171 static pthread_t coop_mother;
 172 static coop_t *coop_child;
 173 #endif
 174
 175 static void *coop_starthelp (qt_t *old, void *ignore0, void *ignore1);
 176 static void coop_only (void *pu, void *pt, qt_userf_t *f);
 177 static void *coop_aborthelp (qt_t *sp, void *old, void *null);
 178 static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
 179
 180
 181 /* called on process termination.  */
 182 #ifdef HAVE_ATEXIT
 183 static void
 184 coop_finish (void)
 185 #else
 186 #ifdef HAVE_ON_EXIT
 187 extern int on_exit (void (*procp) (), int arg);
 188
 189 static void
 190 coop_finish (int status, void *arg)
 191 #else
 192 #error Dont know how to setup a cleanup handler on your system.
 193 #endif
 194 #endif
 195 {
 196 #ifdef GUILE_PTHREAD_COMPAT
 197   coop_quitting_p = 1;
 198   pthread_cond_signal (&coop_cond_create);
 199   pthread_cond_broadcast (&coop_cond_quit);
 200 #endif
 201 }
 202
 203 void
 204 coop_init ()
 205 {
 206   coop_qinit (&coop_global_runq);
 207   coop_qinit (&coop_global_sleepq);
 208   coop_qinit (&coop_tmp_queue);
 209   coop_qinit (&coop_global_allq);
 210   coop_global_curr = &coop_global_main;
 211 #ifdef GUILE_PTHREAD_COMPAT
 212   coop_qinit (&coop_deadq);
 213   pthread_cond_init (&coop_cond_quit, NULL);
 214   pthread_cond_init (&coop_cond_create, NULL);
 215   pthread_mutex_init (&coop_mutex_create, NULL);
 216 #endif
 217 #ifdef HAVE_ATEXIT
 218   atexit (coop_finish);
 219 #else
 220 #ifdef HAVE_ON_EXIT
 221   on_exit (coop_finish, 0);
 222 #endif
 223 #endif
 224 }
 225
 226 /* Return the next runnable thread. If no threads are currently runnable,
 227    and there are sleeping threads - wait until one wakes up. Otherwise,
 228    return NULL. */
 229
 230 #ifndef GUILE_ISELECT
 231 coop_t *
 232 coop_next_runnable_thread()
 233 {
 234   int sleepers;
 235   coop_t *t;
 236   time_t now;
 237
 238   do {
 239     sleepers = 0;
 240     now = time(NULL);
 241
 242     /* Check the sleeping queue */
 243     while ((t = coop_qget(&coop_global_sleepq)) != NULL)
 244       {
 245         sleepers++;
 246         if (t->wakeup_time <= now)
 247           coop_qput(&coop_global_runq, t);
 248         else
 249           coop_qput(&coop_tmp_queue, t);
 250       }
 251     while ((t = coop_qget(&coop_tmp_queue)) != NULL)
 252       coop_qput(&coop_global_sleepq, t);
 253
 254     t = coop_qget (&coop_global_runq);
 255
 256   } while ((t == NULL) && (sleepers > 0));
 257
 258   return t;
 259 }
 260 #endif
 261
 262 void
 263 coop_start()
 264 {
 265   coop_t *next;
 266
 267   while ((next = coop_qget (&coop_global_runq)) != NULL) {
 268     coop_global_curr = next;
 269     QT_BLOCK (coop_starthelp, 0, 0, next->sp);
 270   }
 271 }
 272
 273
 274 static void *
 275 coop_starthelp (qt_t *old, void *ignore0, void *ignore1)
 276 {
 277   coop_global_main.sp = old;
 278   coop_global_main.joining = NULL;
 279   coop_qput (&coop_global_runq, &coop_global_main);
 280   return NULL; /* not used, but keeps compiler happy */
 281 }
 282
 283 int
 284 coop_mutex_init (coop_m *m)
 285 {
 286   return coop_new_mutex_init (m, NULL);
 287 }
 288
 289 int
 290 coop_new_mutex_init (coop_m *m, coop_mattr *attr)
 291 {
 292   m->owner = NULL;
 293   coop_qinit(&(m->waiting));
 294   return 0;
 295 }
 296
 297 int
 298 coop_mutex_trylock (coop_m *m)
 299 {
 300   if (m->owner == NULL)
 301     {
 302       m->owner = coop_global_curr;
 303       return 0;
 304     }
 305   else
 306     return EBUSY;
 307 }
 308
 309 int
 310 coop_mutex_lock (coop_m *m)
 311 {
 312   if (m->owner == NULL)
 313     {
 314       m->owner = coop_global_curr;
 315     }
 316   else
 317     {
 318       coop_t *old, *newthread;
 319
 320       /* Record the current top-of-stack before going to sleep */
 321       coop_global_curr->top = &old;
 322
 323 #ifdef GUILE_ISELECT
 324       newthread = coop_wait_for_runnable_thread();
 325       if (newthread == coop_global_curr)
 326         coop_abort ();
 327 #else
 328       newthread = coop_next_runnable_thread();
 329 #endif
 330       old = coop_global_curr;
 331       coop_global_curr = newthread;
 332       QT_BLOCK (coop_yieldhelp, old, &(m->waiting), newthread->sp);
 333     }
 334   return 0;
 335 }
 336
 337
 338 int
 339 coop_mutex_unlock (coop_m *m)
 340 {
 341   coop_t *old, *newthread;
 342
 343   newthread = coop_qget (&(m->waiting));
 344   if (newthread != NULL)
 345     {
 346       /* Record the current top-of-stack before going to sleep */
 347       coop_global_curr->top = &old;
 348
 349       old = coop_global_curr;
 350       coop_global_curr = newthread;
 351       /* The new thread came into m->waiting through a lock operation.
 352          It now owns this mutex. */
 353       m->owner = coop_global_curr;
 354       QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
 355     }
 356   else
 357     {
 358       m->owner = NULL;
 359     }
 360   return 0;
 361 }
 362
 363
 364 int
 365 coop_mutex_destroy (coop_m *m)
 366 {
 367   return 0;
 368 }
 369
 370
 371 int
 372 coop_condition_variable_init (coop_c *c)
 373 {
 374   return coop_new_condition_variable_init (c, NULL);
 375 }
 376
 377 int
 378 coop_new_condition_variable_init (coop_c *c, coop_cattr *a)
 379 {
 380   coop_qinit(&(c->waiting));
 381   return 0;
 382 }
 383
 384 int
 385 coop_condition_variable_wait_mutex (coop_c *c, coop_m *m)
 386 {
 387   coop_t *old, *newthread;
 388
 389   /* coop_mutex_unlock (m); */
 390   newthread = coop_qget (&(m->waiting));
 391   if (newthread != NULL)
 392     {
 393       m->owner = newthread;
 394     }
 395   else
 396     {
 397       m->owner = NULL;
 398       /*fixme* Should we really wait here?  Isn't it OK just to proceed? */
 399 #ifdef GUILE_ISELECT
 400       newthread = coop_wait_for_runnable_thread();
 401       if (newthread == coop_global_curr)
 402         coop_abort ();
 403 #else
 404       newthread = coop_next_runnable_thread();
 405 #endif
 406     }
 407   coop_global_curr->top = &old;
 408   old = coop_global_curr;
 409   coop_global_curr = newthread;
 410   QT_BLOCK (coop_yieldhelp, old, &(c->waiting), newthread->sp);
 411
 412   coop_mutex_lock (m);
 413   return 0;
 414 }
 415
 416 int
 417 coop_condition_variable_timed_wait_mutex (coop_c *c,
 418                                           coop_m *m,
 419                                           const struct timespec *abstime)
 420 {
 421   coop_t *old, *t;
 422   int res = ETIMEDOUT;
 423
 424   /* coop_mutex_unlock (m); */
 425   t = coop_qget (&(m->waiting));
 426   if (t != NULL)
 427     {
 428       m->owner = t;
 429     }
 430   else
 431     {
 432       m->owner = NULL;
 433 #ifdef GUILE_ISELECT
 434       coop_global_curr->timeoutp = 1;
 435       coop_global_curr->wakeup_time.tv_sec = abstime->tv_sec;
 436       coop_global_curr->wakeup_time.tv_usec = abstime->tv_nsec / 1000;
 437       coop_timeout_qinsert (&coop_global_sleepq, coop_global_curr);
 438       t = coop_wait_for_runnable_thread();
 439 #else
 440       /*fixme* Implement!*/
 441       t = coop_next_runnable_thread();
 442 #endif
 443     }
 444   if (t != coop_global_curr)
 445     {
 446       coop_global_curr->top = &old;
 447       old = coop_global_curr;
 448       coop_global_curr = t;
 449       QT_BLOCK (coop_yieldhelp, old, &(c->waiting), t->sp);
 450
 451       /* Are we still in the sleep queue? */
 452       old = &coop_global_sleepq.t;
 453       for (t = old->next; t != &coop_global_sleepq.t; old = t, t = t->next)
 454         if (t == coop_global_curr)
 455           {
 456             old->next = t->next; /* unlink */
 457             res = 0;
 458             break;
 459           }
 460     }
 461   coop_mutex_lock (m);
 462   return res;
 463 }
 464
 465 int
 466 coop_condition_variable_signal (coop_c *c)
 467 {
 468   coop_t *newthread;
 469
 470   while ((newthread = coop_qget (&(c->waiting))) != NULL)
 471     {
 472       coop_qput (&coop_global_runq, newthread);
 473     }
 474   return 0;
 475 }
 476
 477 /* {Keys}
 478  */
 479
 480 static int n_keys = 0;
 481 static int max_keys = 0;
 482 static void (**destructors) (void *) = 0;
 483
 484 int
 485 coop_key_create (coop_k *keyp, void (*destructor) (void *value))
 486 {
 487   if (n_keys >= max_keys)
 488     {
 489       int i;
 490       max_keys = max_keys ? max_keys * 3 / 2 : 10;
 491       destructors = realloc (destructors, sizeof (void *) * max_keys);
 492       if (destructors == 0)
 493         {
 494           fprintf (stderr, "Virtual memory exceeded in coop_key_create\n");
 495           exit (1);
 496         }
 497       for (i = n_keys; i < max_keys; ++i)
 498         destructors[i] = NULL;
 499     }
 500   destructors[n_keys] = destructor;
 501   *keyp = n_keys++;
 502   return 0;
 503 }
 504
 505 int
 506 coop_setspecific (coop_k key, const void *value)
 507 {
 508   int n_keys = coop_global_curr->n_keys;
 509   if (key >= n_keys)
 510     {
 511       int i;
 512       coop_global_curr->n_keys = max_keys;
 513       coop_global_curr->specific = realloc (n_keys
 514                                             ? coop_global_curr->specific
 515                                             : NULL,
 516                                             sizeof (void *) * max_keys);
 517       if (coop_global_curr->specific == 0)
 518         {
 519           fprintf (stderr, "Virtual memory exceeded in coop_setspecific\n");
 520           exit (1);
 521         }
 522       for (i = n_keys; i < max_keys; ++i)
 523         coop_global_curr->specific[i] = NULL;
 524     }
 525   coop_global_curr->specific[key] = (void *) value;
 526   return 0;
 527 }
 528
 529 void *
 530 coop_getspecific (coop_k key)
 531 {
 532   return (key < coop_global_curr->n_keys
 533           ? coop_global_curr->specific[key]
 534           : NULL);
 535 }
 536
 537 int
 538 coop_key_delete (coop_k key)
 539 {
 540   return 0;
 541 }
 542
 543
 544 int
 545 coop_condition_variable_destroy (coop_c *c)
 546 {
 547   return 0;
 548 }
 549
 550 #ifdef GUILE_PTHREAD_COMPAT
 551
 552 /* 1K room for the cond wait routine */
 553 #ifdef SCM_STACK_GROWS_UP
 554 #define COOP_STACK_ROOM (256)
 555 #else
 556 #define COOP_STACK_ROOM (-256)
 557 #endif
 558
 559 static void *
 560 dummy_start (void *coop_thread)
 561 {
 562   coop_t *t = (coop_t *) coop_thread;
 563   int res;
 564   t->sp = (qt_t *) (&t + COOP_STACK_ROOM);
 565   pthread_mutex_init (&t->dummy_mutex, NULL);
 566   pthread_mutex_lock (&t->dummy_mutex);
 567   coop_child = 0;
 568   do
 569     res = pthread_cond_wait (&coop_cond_quit, &t->dummy_mutex);
 570   while (res == EINTR);
 571   return 0;
 572 }
 573
 574 static void *
 575 mother (void *dummy)
 576 {
 577   pthread_mutex_lock (&coop_mutex_create);
 578   while (!coop_quitting_p)
 579     {
 580       int res;
 581       pthread_create (&coop_child->dummy_thread,
 582                       NULL,
 583                       dummy_start,
 584                       coop_child);
 585       do
 586         res = pthread_cond_wait (&coop_cond_create, &coop_mutex_create);
 587       while (res == EINTR);
 588     }
 589   return 0;
 590 }
 591
 592 #endif
 593
 594 coop_t *
 595 coop_create (coop_userf_t *f, void *pu)
 596 {
 597   coop_t *t;
 598 #ifndef GUILE_PTHREAD_COMPAT
 599   void *sto;
 600 #endif
 601
 602 #ifdef GUILE_PTHREAD_COMPAT
 603   t = coop_qget (&coop_deadq);
 604   if (t)
 605     {
 606       t->sp = t->base;
 607       t->specific = 0;
 608       t->n_keys = 0;
 609     }
 610   else
 611 #endif
 612     {
 613       t = malloc (sizeof (coop_t));
 614
 615       t->specific = NULL;
 616       t->n_keys = 0;
 617 #ifdef GUILE_PTHREAD_COMPAT
 618       coop_child = t;
 619       if (coop_quitting_p < 0)
 620         {
 621           coop_quitting_p = 0;
 622           /* We can't create threads ourselves since the pthread
 623            * corresponding to this stack might be sleeping.
 624            */
 625           pthread_create (&coop_mother, NULL, mother, NULL);
 626         }
 627       else
 628         {
 629           pthread_cond_signal (&coop_cond_create);
 630         }
 631       /* We can't use a pthreads condition variable since "this"
 632        * pthread could already be asleep.  We can't use a COOP
 633        * condition variable because they are not safe against
 634        * pre-emptive switching.
 635        */
 636       while (coop_child)
 637         usleep (0);
 638 #else
 639       t->sto = malloc (COOP_STKSIZE);
 640       sto = COOP_STKALIGN (t->sto, QT_STKALIGN);
 641       t->sp = QT_SP (sto, COOP_STKSIZE - QT_STKALIGN);
 642 #endif
 643       t->base = t->sp;
 644     }
 645   t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, coop_only);
 646   t->joining = NULL;
 647   coop_qput (&coop_global_runq, t);
 648   coop_all_qput (&coop_global_allq, t);
 649
 650   return t;
 651 }
 652
 653
 654 static void
 655 coop_only (void *pu, void *pt, qt_userf_t *f)
 656 {
 657   coop_global_curr = (coop_t *)pt;
 658   (*(coop_userf_t *)f)(pu);
 659   coop_abort();
 660   /* NOTREACHED */
 661 }
 662
 663
 664 void
 665 coop_abort ()
 666 {
 667   coop_t *old, *newthread;
 668
 669   /* Wake up any threads that are waiting to join this one */
 670   if (coop_global_curr->joining)
 671     {
 672       while ((newthread = coop_qget ((coop_q_t *)(coop_global_curr->joining)))
 673              != NULL)
 674         {
 675           coop_qput (&coop_global_runq, newthread);
 676         }
 677       free (coop_global_curr->joining);
 678     }
 679
 680 #ifdef GUILE_ISELECT
 681   scm_I_am_dead = 1;
 682   do {
 683     newthread = coop_wait_for_runnable_thread();
 684   } while (newthread == coop_global_curr);
 685   scm_I_am_dead = 0;
 686 #else
 687   newthread = coop_next_runnable_thread();
 688 #endif
 689   coop_all_qremove (&coop_global_allq, coop_global_curr);
 690   old = coop_global_curr;
 691   coop_global_curr = newthread;
 692   QT_ABORT (coop_aborthelp, old, (void *) NULL, newthread->sp);
 693 }
 694
 695
 696 static void *
 697 coop_aborthelp (qt_t *sp, void *old, void *null)
 698 {
 699   coop_t *oldthread = (coop_t *) old;
 700
 701 #if 0
 702   /* Marking old->base NULL indicates that this thread is dead */
 703   oldthread->base = NULL;
 704 #endif
 705
 706   if (oldthread->specific)
 707     free (oldthread->specific);
 708 #ifndef GUILE_PTHREAD_COMPAT
 709   free (oldthread->sto);
 710   free (oldthread);
 711 #else
 712   coop_qput (&coop_deadq, oldthread);
 713 #endif
 714
 715   return NULL;
 716 }
 717
 718
 719 void
 720 coop_join(coop_t *t)
 721 {
 722   coop_t *old, *newthread;
 723
 724   /* Check if t is already finished */
 725   if (t->base == NULL)
 726     return;
 727
 728   /* Create a join list if necessary */
 729   if (t->joining == NULL)
 730     {
 731       t->joining = malloc(sizeof(coop_q_t));
 732       coop_qinit((coop_q_t *) t->joining);
 733     }
 734
 735 #ifdef GUILE_ISELECT
 736   newthread = coop_wait_for_runnable_thread();
 737   if (newthread == coop_global_curr)
 738     return;
 739 #else
 740   newthread = coop_next_runnable_thread();
 741 #endif
 742   old = coop_global_curr;
 743   coop_global_curr = newthread;
 744   QT_BLOCK (coop_yieldhelp, old, (coop_q_t *) t->joining, newthread->sp);
 745 }
 746
 747 void
 748 coop_yield()
 749 {
 750   coop_t *old = NULL;
 751   coop_t *newthread;
 752
 753   newthread = coop_next_runnable_thread();
 754
 755   /* There may be no other runnable threads. Return if this is the
 756      case. */
 757 #if GUILE_ISELECT
 758   if (newthread == coop_global_curr)
 759       return;
 760 #else
 761   if (newthread == NULL)
 762       return;
 763 #endif
 764
 765   old = coop_global_curr;
 766
 767   coop_global_curr = newthread;
 768   QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
 769 }
 770
 771
 772 static void *
 773 coop_yieldhelp (qt_t *sp, void *old, void *blockq)
 774 {
 775   ((coop_t *)old)->sp = sp;
 776   coop_qput ((coop_q_t *)blockq, (coop_t *)old);
 777   return NULL;
 778 }
 779
 780 /* Replacement for the system's sleep() function. Does the right thing
 781    for the process - but not for the system (it busy-waits) */
 782
 783 void *
 784 coop_sleephelp (qt_t *sp, void *old, void *blockq)
 785 {
 786   ((coop_t *)old)->sp = sp;
 787   /* old is already on the sleep queue - so there's no need to
 788      do anything extra here */
 789   return NULL;
 790 }
 791
 792 #ifdef GUILE_ISELECT
 793
 794 unsigned long
 795 scm_thread_usleep (unsigned long usec)
 796 {
 797   struct timeval timeout;
 798   timeout.tv_sec = 0;
 799   timeout.tv_usec = usec;
 800   scm_internal_select (0, NULL, NULL, NULL, &timeout);
 801   return 0;  /* Maybe we should calculate actual time slept,
 802                 but this is faster... :) */
 803 }
 804
 805 unsigned long
 806 scm_thread_sleep (unsigned long sec)
 807 {
 808   time_t now = time (NULL);
 809   struct timeval timeout;
 810   unsigned long slept;
 811   timeout.tv_sec = sec;
 812   timeout.tv_usec = 0;
 813   scm_internal_select (0, NULL, NULL, NULL, &timeout);
 814   slept = time (NULL) - now;
 815   return slept > sec ? 0 : sec - slept;
 816 }
 817
 818 #else /* GUILE_ISELECT */
 819
 820 unsigned long
 821 scm_thread_sleep (unsigned long s)
 822 {
 823   coop_t *newthread, *old;
 824   time_t now = time (NULL);
 825   coop_global_curr->wakeup_time = now + s;
 826
 827   /* Put the current thread on the sleep queue */
 828   coop_qput (&coop_global_sleepq, coop_global_curr);
 829
 830   newthread = coop_next_runnable_thread();
 831
 832   /* If newthread is the same as the sleeping thread, do nothing */
 833   if (newthread == coop_global_curr)
 834     return s;
 835
 836   old = coop_global_curr;
 837
 838   coop_global_curr = newthread;
 839   QT_BLOCK (coop_sleephelp, old, NULL, newthread->sp);
 840
 841   return s;
 842 }
 843
 844 unsigned long
 845 scm_thread_usleep (unsigned long usec)
 846 {
 847   /* We're so cheap.  */
 848   scm_thread_sleep (usec / 1000000);
 849   struct timeval timeout;
 850   return 0;  /* Maybe we should calculate actual time slept,
 851                 but this is faster... :) */
 852 }
 853
 854 #endif /* GUILE_ISELECT */
 855
 856 /*
 857   Local Variables:
 858   c-file-style: "gnu"
 859   End:
 860 */