libguile/async.c

   1 /* Copyright (C) 1995, 96, 97, 98, 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 <stdio.h>
  48 #include <signal.h>
  49 #include "_scm.h"
  50 #include "eval.h"
  51 #include "throw.h"
  52 #include "root.h"
  53 #include "smob.h"
  54
  55 #include "validate.h"
  56 #include "async.h"
  57
  58 #ifdef HAVE_STRING_H
  59 #include <string.h>
  60 #endif
  61 #ifdef HAVE_UNISTD_H
  62 #include <unistd.h>
  63 #endif
  64
  65
  66 \f
  67 /* {Asynchronous Events}
  68  *
  69  *
  70  * Async == thunk + mark.
  71  *
  72  * Setting the mark guarantees future execution of the thunk.  More
  73  * than one set may be satisfied by a single execution.
  74  *
  75  * scm_tick_clock decremented once per SCM_ALLOW_INTS.
  76  * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0.
  77  * Async execution prevented by scm_mask_ints != 0.
  78  *
  79  * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock
  80  * to 1.
  81  *
  82  * If the clock reaches 0 any other time, run marked asyncs.
  83  *
  84  * From a unix signal handler, mark a corresponding async and set the clock
  85  * to 1.   Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not
  86  * called in the dynamic scope of a critical section, it is excecuted immediately.
  87  *
  88  * Overall, closely timed signals of a particular sort may be combined.  Pending signals
  89  * are delivered in a fixed priority order, regardless of arrival order.
  90  *
  91  */
  92
  93 /* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
  94  * when the interpreter is not running at all.
  95  */
  96 int scm_ints_disabled = 1;
  97 unsigned int scm_mask_ints = 1;
  98
  99 #ifdef GUILE_OLD_ASYNC_CLICK
 100 unsigned int scm_async_clock = 20;
 101 static unsigned int scm_async_rate = 20;
 102
 103 static unsigned int scm_tick_clock = 0;
 104 static unsigned int scm_tick_rate = 0;
 105 static unsigned int scm_desired_tick_rate = 0;
 106 static unsigned int scm_switch_clock = 0;
 107 static unsigned int scm_switch_rate = 0;
 108 static unsigned int scm_desired_switch_rate = 0;
 109 #else
 110 int scm_asyncs_pending_p = 0;
 111 #endif
 112
 113 static long scm_tc16_async;
 114
 115 \f
 116
 117 #ifdef GUILE_OLD_ASYNC_CLICK
 118 int
 119 scm_asyncs_pending ()
 120 {
 121   SCM pos;
 122   pos = scm_asyncs;
 123   while (pos != SCM_EOL)
 124     {
 125       SCM a;
 126       struct scm_async * it;
 127       a = SCM_CAR (pos);
 128       it = SCM_ASYNC (a);
 129       if (it->got_it)
 130         return 1;
 131       pos = SCM_CDR (pos);
 132     }
 133   return 0;
 134 }
 135
 136 #if 0
 137 static SCM
 138 scm_sys_tick_async_thunk (void)
 139 {
 140   scm_deliver_signal (SCM_TICK_SIGNAL);
 141   return SCM_BOOL_F;
 142 }
 143 #endif
 144
 145 void
 146 scm_async_click ()
 147 {
 148   int owe_switch;
 149   int owe_tick;
 150
 151   if (!scm_switch_rate)
 152     {
 153       owe_switch = 0;
 154       scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 155       scm_desired_switch_rate = 0;
 156     }
 157   else
 158     {
 159       owe_switch = (scm_async_rate >= scm_switch_clock);
 160       if (owe_switch)
 161         {
 162           if (scm_desired_switch_rate)
 163             {
 164               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 165               scm_desired_switch_rate = 0;
 166             }
 167           else
 168             scm_switch_clock = scm_switch_rate;
 169         }
 170       else
 171         {
 172           if (scm_desired_switch_rate)
 173             {
 174               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 175               scm_desired_switch_rate = 0;
 176             }
 177           else
 178             scm_switch_clock -= scm_async_rate;
 179         }
 180     }
 181
 182   if (scm_mask_ints)
 183     {
 184       if (owe_switch)
 185         scm_switch ();
 186       scm_async_clock = 1;
 187       return;;
 188     }
 189
 190   if (!scm_tick_rate)
 191     {
 192       unsigned int r;
 193       owe_tick = 0;
 194       r = scm_desired_tick_rate;
 195       if (r)
 196         {
 197           scm_desired_tick_rate = 0;
 198           scm_tick_rate = r;
 199           scm_tick_clock = r;
 200         }
 201     }
 202   else
 203     {
 204       owe_tick = (scm_async_rate >= scm_tick_clock);
 205       if (owe_tick)
 206         {
 207           scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 208           scm_desired_tick_rate = 0;
 209         }
 210       else
 211         {
 212           if (scm_desired_tick_rate)
 213             {
 214               scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 215               scm_desired_tick_rate = 0;
 216             }
 217           else
 218             scm_tick_clock -= scm_async_rate;
 219         }
 220     }
 221
 222   /*
 223      if (owe_tick)
 224        scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]);
 225      */
 226
 227   SCM_DEFER_INTS;
 228   if (scm_tick_rate && scm_switch_rate)
 229     {
 230       scm_async_rate = min (scm_tick_clock,  scm_switch_clock);
 231       scm_async_clock = scm_async_rate;
 232     }
 233   else if (scm_tick_rate)
 234     {
 235       scm_async_clock = scm_async_rate = scm_tick_clock;
 236     }
 237   else if (scm_switch_rate)
 238     {
 239       scm_async_clock = scm_async_rate = scm_switch_clock;
 240     }
 241   else
 242     scm_async_clock = scm_async_rate = 1 << 16;
 243   SCM_ALLOW_INTS_ONLY;
 244
 245  tail:
 246   scm_run_asyncs (scm_asyncs);
 247
 248   SCM_DEFER_INTS;
 249   if (scm_asyncs_pending ())
 250     {
 251       SCM_ALLOW_INTS_ONLY;
 252       goto tail;
 253     }
 254   SCM_ALLOW_INTS;
 255
 256   if (owe_switch)
 257     scm_switch ();
 258 }
 259
 260 void
 261 scm_switch ()
 262 {
 263 #if 0 /* Thread switching code should probably reside here, but the
 264          async switching code doesn't seem to work, so it's put in the
 265          SCM_DEFER_INTS macro instead. /mdj */
 266   SCM_THREAD_SWITCHING_CODE;
 267 #endif
 268 }
 269
 270 #else
 271
 272 void
 273 scm_async_click ()
 274 {
 275   if (!scm_mask_ints)
 276     do
 277       scm_run_asyncs (scm_asyncs);
 278     while (scm_asyncs_pending_p);
 279 }
 280
 281 #endif
 282
 283
 284 \f
 285
 286 static SCM
 287 mark_async (SCM obj)
 288 {
 289   struct scm_async * it;
 290   it = SCM_ASYNC (obj);
 291   return it->thunk;
 292 }
 293
 294 \f
 295
 296 SCM_DEFINE (scm_async, "async", 1, 0, 0,
 297            (SCM thunk),
 298 "")
 299 #define FUNC_NAME s_scm_async
 300 {
 301   SCM_RETURN_NEWSMOB2 (scm_tc16_async, 0, thunk);
 302 }
 303 #undef FUNC_NAME
 304
 305 SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
 306             (SCM thunk),
 307 "")
 308 #define FUNC_NAME s_scm_system_async
 309 {
 310   SCM it;
 311   SCM list;
 312
 313   it = scm_async (thunk);
 314   SCM_NEWCELL (list);
 315   SCM_SETCAR (list, it);
 316   SCM_SETCDR (list, scm_asyncs);
 317   scm_asyncs = list;
 318   return it;
 319 }
 320 #undef FUNC_NAME
 321
 322 SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
 323             (SCM a),
 324 "")
 325 #define FUNC_NAME s_scm_async_mark
 326 {
 327   struct scm_async * it;
 328   SCM_VALIDATE_ASYNC_COPY (1,a,it);
 329 #ifdef GUILE_OLD_ASYNC_CLICK
 330   it->got_it = 1;
 331 #else
 332   scm_asyncs_pending_p = it->got_it = 1;
 333 #endif
 334   return SCM_UNSPECIFIED;
 335 }
 336 #undef FUNC_NAME
 337
 338
 339 SCM_DEFINE (scm_system_async_mark, "system-async-mark", 1, 0, 0,
 340            (SCM a),
 341 "")
 342 #define FUNC_NAME s_scm_system_async_mark
 343 {
 344   struct scm_async *it;
 345   SCM_VALIDATE_ASYNC_COPY (1, a, it);
 346   SCM_REDEFER_INTS;
 347 #ifdef GUILE_OLD_ASYNC_CLICK
 348   it->got_it = 1;
 349   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 350   scm_async_clock = 1;
 351 #else
 352   scm_asyncs_pending_p = it->got_it = 1;
 353 #endif
 354   SCM_REALLOW_INTS;
 355   return SCM_UNSPECIFIED;
 356 }
 357 #undef FUNC_NAME
 358
 359
 360 SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
 361            (SCM list_of_a),
 362 "")
 363 #define FUNC_NAME s_scm_run_asyncs
 364 {
 365 #ifdef GUILE_OLD_ASYNC_CLICK
 366   if (scm_mask_ints)
 367     return SCM_BOOL_F;
 368 #else
 369   scm_asyncs_pending_p = 0;
 370 #endif
 371   while (list_of_a != SCM_EOL)
 372     {
 373       SCM a;
 374       struct scm_async * it;
 375       SCM_VALIDATE_CONS (1, list_of_a);
 376       a = SCM_CAR (list_of_a);
 377       SCM_VALIDATE_ASYNC_COPY (SCM_ARG1,a,it);
 378       scm_mask_ints = 1;
 379       if (it->got_it)
 380         {
 381           it->got_it = 0;
 382           scm_apply (it->thunk, SCM_EOL, SCM_EOL);
 383         }
 384       scm_mask_ints = 0;
 385       list_of_a = SCM_CDR (list_of_a);
 386     }
 387   return SCM_BOOL_T;
 388 }
 389 #undef FUNC_NAME
 390
 391 \f
 392
 393
 394 SCM_DEFINE (scm_noop, "noop", 0, 0, 1,
 395            (SCM args),
 396 "")
 397 #define FUNC_NAME s_scm_noop
 398 {
 399   return (SCM_NULLP (args) ? SCM_BOOL_F : SCM_CAR (args));
 400 }
 401 #undef FUNC_NAME
 402
 403
 404 \f
 405
 406 #ifdef GUILE_OLD_ASYNC_CLICK
 407
 408 SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0,
 409            (SCM n),
 410 "")
 411 #define FUNC_NAME s_scm_set_tick_rate
 412 {
 413   unsigned int old_n = scm_tick_rate;
 414   SCM_VALIDATE_INUM (1, n);
 415   scm_desired_tick_rate = SCM_INUM (n);
 416   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 417   scm_async_clock = 1;
 418   return SCM_MAKINUM (old_n);
 419 }
 420 #undef FUNC_NAME
 421
 422 \f
 423
 424
 425 SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0,
 426            (SCM n),
 427 "")
 428 #define FUNC_NAME s_scm_set_switch_rate
 429 {
 430   unsigned int old_n = scm_switch_rate;
 431   SCM_VALIDATE_INUM (1, n);
 432   scm_desired_switch_rate = SCM_INUM (n);
 433   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 434   scm_async_clock = 1;
 435   return SCM_MAKINUM (old_n);
 436 }
 437 #undef FUNC_NAME
 438
 439 #endif
 440 \f
 441
 442 /* points to the GC system-async, so that scm_gc_end can find it.  */
 443 SCM scm_gc_async;
 444
 445 /* the vcell for gc-thunk.  */
 446 static SCM scm_gc_vcell;
 447
 448 /* the thunk installed in the GC system-async, which is marked at the
 449    end of garbage collection.  */
 450 static SCM
 451 scm_sys_gc_async_thunk (void)
 452 {
 453   if (SCM_NFALSEP (scm_gc_vcell))
 454     {
 455       SCM proc = SCM_CDR (scm_gc_vcell);
 456
 457       if (SCM_NFALSEP (proc) && !SCM_UNBNDP (proc))
 458         scm_apply (proc, SCM_EOL, SCM_EOL);
 459     }
 460   return SCM_UNSPECIFIED;
 461 }
 462
 463 \f
 464
 465 SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
 466            (),
 467 "")
 468 #define FUNC_NAME s_scm_unmask_signals
 469 {
 470   scm_mask_ints = 0;
 471   return SCM_UNSPECIFIED;
 472 }
 473 #undef FUNC_NAME
 474
 475
 476 SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
 477            (),
 478 "")
 479 #define FUNC_NAME s_scm_mask_signals
 480 {
 481   scm_mask_ints = 1;
 482   return SCM_UNSPECIFIED;
 483 }
 484 #undef FUNC_NAME
 485
 486 \f
 487
 488 void
 489 scm_init_async ()
 490 {
 491   SCM a_thunk;
 492   scm_tc16_async = scm_make_smob_type_mfpe ("async", 0,
 493                                            mark_async, NULL, NULL, NULL);
 494   scm_gc_vcell = scm_sysintern ("gc-thunk", SCM_BOOL_F);
 495   a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk);
 496   scm_gc_async = scm_system_async (a_thunk);
 497
 498 #include "async.x"
 499 }
 500
 501 /*
 502   Local Variables:
 503   c-file-style: "gnu"
 504   End:
 505 */