libguile/coop.c

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