libguile/async.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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include <signal.h>
  45 #include "_scm.h"
  46
  47 #ifdef HAVE_STRING_H
  48 #include <string.h>
  49 #endif
  50 #ifdef HAVE_UNISTD_H
  51 #include <unistd.h>
  52 #endif
  53
  54
  55 \f
  56 /* {Asynchronous Events}
  57  *
  58  *
  59  * Async == thunk + mark.
  60  *
  61  * Setting the mark guarantees future execution of the thunk.  More
  62  * than one set may be satisfied by a single execution.
  63  *
  64  * scm_tick_clock decremented once per SCM_ALLOW_INTS.
  65  * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0.
  66  * Async execution prevented by scm_mask_ints != 0.
  67  *
  68  * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock
  69  * to 1.
  70  *
  71  * If the clock reaches 0 any other time, run marked asyncs.
  72  *
  73  * From a unix signal handler, mark a corresponding async and set the clock
  74  * to 1.   Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not
  75  * called in the dynamic scope of a critical section, it is excecuted immediately.
  76  *
  77  * Overall, closely timed signals of a particular sort may be combined.  Pending signals
  78  * are delivered in a fixed priority order, regardless of arrival order.
  79  *
  80  */
  81
  82
  83 #define min(A,B) ((A) < (B) ? (A) : (B))
  84
  85
  86 unsigned int scm_async_clock = 20;
  87 static unsigned int scm_async_rate = 20;
  88 unsigned int scm_mask_ints = 1;
  89
  90 static unsigned int scm_tick_clock = 0;
  91 static unsigned int scm_tick_rate = 0;
  92 static unsigned int scm_desired_tick_rate = 0;
  93 static unsigned int scm_switch_clock = 0;
  94 static unsigned int scm_switch_rate = 0;
  95 static unsigned int scm_desired_switch_rate = 0;
  96
  97 static SCM system_signal_asyncs[SCM_NUM_SIGS];
  98 static SCM handler_var;
  99 static SCM symbol_signal;
 100
 101
 102 struct scm_async
 103 {
 104   int got_it;                   /* needs to be delivered? */
 105   SCM thunk;                    /* the handler. */
 106 };
 107
 108
 109 static long scm_tc16_async;
 110
 111 #define SCM_ASYNCP(X)   (scm_tc16_async == SCM_GCTYP16 (X))
 112 #define SCM_ASYNC(X)    ((struct scm_async *)SCM_CDR (X))
 113
 114
 115
 116
 117 \f
 118
 119 #ifdef __STDC__
 120 static int
 121 asyncs_pending (void)
 122 #else
 123 static int
 124 asyncs_pending ()
 125 #endif
 126 {
 127   SCM pos;
 128   pos = scm_asyncs;
 129   while (pos != SCM_EOL)
 130     {
 131       SCM a;
 132       struct scm_async * it;
 133       a = SCM_CAR (pos);
 134       it = SCM_ASYNC (a);
 135       if (it->got_it)
 136         return 1;
 137       pos = SCM_CDR (pos);
 138     }
 139   return 0;
 140 }
 141
 142
 143 #ifdef __STDC__
 144 void
 145 scm_async_click (void)
 146 #else
 147 void
 148 scm_async_click ()
 149 #endif
 150 {
 151   int owe_switch;
 152   int owe_tick;
 153
 154   if (!scm_switch_rate)
 155     {
 156       owe_switch = 0;
 157       scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 158       scm_desired_switch_rate = 0;
 159     }
 160   else
 161     {
 162       owe_switch = (scm_async_rate >= scm_switch_clock);
 163       if (owe_switch)
 164         {
 165           if (scm_desired_switch_rate)
 166             {
 167               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 168               scm_desired_switch_rate = 0;
 169             }
 170           else
 171             scm_switch_clock = scm_switch_rate;
 172         }
 173       else
 174         {
 175           if (scm_desired_switch_rate)
 176             {
 177               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 178               scm_desired_switch_rate = 0;
 179             }
 180           else
 181             scm_switch_clock -= scm_async_rate;
 182         }
 183     }
 184
 185   if (scm_mask_ints)
 186     {
 187       if (owe_switch)
 188         scm_switch ();
 189       scm_async_clock = 1;
 190       return;;
 191     }
 192
 193   if (!scm_tick_rate)
 194     {
 195       unsigned int r;
 196       owe_tick = 0;
 197       r = scm_desired_tick_rate;
 198       if (r)
 199         {
 200           scm_desired_tick_rate = 0;
 201           scm_tick_rate = r;
 202           scm_tick_clock = r;
 203         }
 204     }
 205   else
 206     {
 207       owe_tick = (scm_async_rate >= scm_tick_clock);
 208       if (owe_tick)
 209         {
 210           scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 211           scm_desired_tick_rate = 0;
 212         }
 213       else
 214         {
 215           if (scm_desired_tick_rate)
 216             {
 217               scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 218               scm_desired_tick_rate = 0;
 219             }
 220           else
 221             scm_tick_clock -= scm_async_rate;
 222         }
 223     }
 224
 225   if (owe_tick)
 226     scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]);
 227
 228   SCM_DEFER_INTS;
 229   if (scm_tick_rate && scm_switch_rate)
 230     {
 231       scm_async_rate = min (scm_tick_clock,  scm_switch_clock);
 232       scm_async_clock = scm_async_rate;
 233     }
 234   else if (scm_tick_rate)
 235     {
 236       scm_async_clock = scm_async_rate = scm_tick_clock;
 237     }
 238   else if (scm_switch_rate)
 239     {
 240       scm_async_clock = scm_async_rate = scm_switch_clock;
 241     }
 242   else
 243     scm_async_clock = scm_async_rate = 1 << 16;
 244   SCM_ALLOW_INTS_ONLY;
 245
 246  tail:
 247   scm_run_asyncs (scm_asyncs);
 248
 249   SCM_DEFER_INTS;
 250   if (asyncs_pending ())
 251     {
 252       SCM_ALLOW_INTS_ONLY;
 253       goto tail;
 254     }
 255   SCM_ALLOW_INTS;
 256
 257   if (owe_switch)
 258     scm_switch ();
 259 }
 260
 261
 262 \f
 263
 264 #ifdef __STDC__
 265 void
 266 scm_switch (void)
 267 #else
 268 void
 269 scm_switch ()
 270 #endif
 271 {}
 272
 273
 274 #ifdef __STDC__
 275 static void
 276 scm_deliver_signal (int num)
 277 #else
 278 static void
 279 scm_deliver_signal (num)
 280      int num;
 281 #endif
 282 {
 283   SCM handler;
 284   handler = SCM_CDR (handler_var);
 285   if (handler != SCM_BOOL_F)
 286     scm_apply (handler, SCM_MAKINUM (num), scm_listofnull);
 287   else
 288     {
 289       scm_mask_ints = 0;
 290       scm_throw (symbol_signal,
 291                            scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED));
 292     }
 293 }
 294
 295
 296 \f
 297
 298 #ifdef __STDC__
 299 static int
 300 print_async (SCM exp, SCM port, int writing)
 301 #else
 302 static int
 303 print_async (exp, port, writing)
 304      SCM exp;
 305      SCM port;
 306      int writing;
 307 #endif
 308 {
 309   scm_gen_puts (scm_regular_string, "#<async ", port);
 310   scm_intprint(exp, 16, port);
 311   scm_gen_putc('>', port);
 312   return 1;
 313 }
 314
 315 #ifdef __STDC__
 316 static SCM
 317 mark_async (SCM obj)
 318 #else
 319 static SCM
 320 mark_async (obj)
 321      SCM obj;
 322 #endif
 323 {
 324   struct scm_async * it;
 325   if (SCM_GC8MARKP (obj))
 326     return SCM_BOOL_F;
 327   SCM_SETGC8MARK (obj);
 328   it = SCM_ASYNC (obj);
 329   return it->thunk;
 330 }
 331
 332 #ifdef __STDC__
 333 static scm_sizet
 334 free_async (SCM obj)
 335 #else
 336 static scm_sizet
 337 free_async (SCM obj)
 338      SCM obj;
 339 #endif
 340 {
 341   struct scm_async * it;
 342   it = SCM_ASYNC (obj);
 343   scm_must_free ((char *)it);
 344   return (sizeof (*it));
 345 }
 346
 347
 348 static scm_smobfuns  async_smob =
 349 {
 350   mark_async,
 351   free_async,
 352   print_async,
 353   0
 354 };
 355
 356
 357 \f
 358
 359 SCM_PROC(s_async, "async", 1, 0, 0, scm_async);
 360 #ifdef __STDC__
 361 SCM
 362 scm_async (SCM thunk)
 363 #else
 364 SCM
 365 scm_async (thunk)
 366      SCM thunk;
 367 #endif
 368 {
 369   SCM it;
 370   struct scm_async * async;
 371
 372   SCM_NEWCELL (it);
 373   SCM_DEFER_INTS;
 374   SCM_SETCDR (it, SCM_EOL);
 375   async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async);
 376   async->got_it = 0;
 377   async->thunk = thunk;
 378   SCM_SETCDR (it, (SCM)async);
 379   SCM_SETCAR (it, (SCM)scm_tc16_async);
 380   SCM_ALLOW_INTS;
 381   return it;
 382 }
 383
 384 SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
 385 #ifdef __STDC__
 386 SCM
 387 scm_system_async (SCM thunk)
 388 #else
 389 SCM
 390 scm_system_async (thunk)
 391      SCM thunk;
 392 #endif
 393 {
 394   SCM it;
 395   SCM list;
 396
 397   it = scm_async (thunk);
 398   SCM_NEWCELL (list);
 399   SCM_DEFER_INTS;
 400   SCM_SETCAR (list, it);
 401   SCM_SETCDR (list, scm_asyncs);
 402   scm_asyncs = list;
 403   SCM_ALLOW_INTS;
 404   return it;
 405 }
 406
 407 SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark);
 408 #ifdef __STDC__
 409 SCM
 410 scm_async_mark (SCM a)
 411 #else
 412 SCM
 413 scm_async_mark (a)
 414      SCM a;
 415 #endif
 416 {
 417   struct scm_async * it;
 418   SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
 419   it = SCM_ASYNC (a);
 420   it->got_it = 1;
 421   return SCM_UNSPECIFIED;
 422 }
 423
 424
 425 SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark);
 426 #ifdef __STDC__
 427 SCM
 428 scm_system_async_mark (SCM a)
 429 #else
 430 SCM
 431 scm_system_async_mark (a)
 432      SCM a;
 433 #endif
 434 {
 435   struct scm_async * it;
 436   SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
 437   it = SCM_ASYNC (a);
 438   SCM_REDEFER_INTS;
 439   it->got_it = 1;
 440   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 441   scm_async_clock = 1;
 442   SCM_REALLOW_INTS;
 443   return SCM_UNSPECIFIED;
 444 }
 445
 446
 447 SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs);
 448 #ifdef __STDC__
 449 SCM
 450 scm_run_asyncs (SCM list_of_a)
 451 #else
 452 SCM
 453 scm_run_asyncs (list_of_a)
 454      SCM list_of_a;
 455 #endif
 456 {
 457   SCM pos;
 458
 459   if (scm_mask_ints)
 460     return SCM_BOOL_F;
 461   pos = list_of_a;
 462   while (pos != SCM_EOL)
 463     {
 464       SCM a;
 465       struct scm_async * it;
 466       SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs);
 467       a = SCM_CAR (pos);
 468       SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs);
 469       it = SCM_ASYNC (a);
 470       scm_mask_ints = 1;
 471       if (it->got_it)
 472         {
 473           it->got_it = 0;
 474           scm_apply (it->thunk, SCM_EOL, SCM_EOL);
 475         }
 476       scm_mask_ints = 0;
 477       pos = SCM_CDR (pos);
 478     }
 479   return SCM_BOOL_T;
 480 }
 481
 482 \f
 483
 484
 485 SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop);
 486 #ifdef __STDC__
 487 SCM
 488 scm_noop (SCM args)
 489 #else
 490 SCM
 491 scm_noop (args)
 492      SCM args;
 493 #endif
 494 {
 495   return (SCM_NULLP (args)
 496           ? SCM_BOOL_F
 497           : SCM_CAR (args));
 498 }
 499
 500
 501 \f
 502
 503 SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate);
 504 #ifdef __STDC__
 505 SCM
 506 scm_set_tick_rate (SCM n)
 507 #else
 508 SCM
 509 scm_set_tick_rate (n)
 510      SCM n;
 511 #endif
 512 {
 513   unsigned int old_n;
 514   SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate);
 515   old_n = scm_tick_rate;
 516   scm_desired_tick_rate = SCM_INUM (n);
 517   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 518   scm_async_clock = 1;
 519   return SCM_MAKINUM (old_n);
 520 }
 521
 522 \f
 523
 524
 525 SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate);
 526 #ifdef __STDC__
 527 SCM
 528 scm_set_switch_rate (SCM n)
 529 #else
 530 SCM
 531 scm_set_switch_rate (n)
 532      SCM n;
 533 #endif
 534 {
 535   unsigned int old_n;
 536   SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate);
 537   old_n = scm_switch_rate;
 538   scm_desired_switch_rate = SCM_INUM (n);
 539   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 540   scm_async_clock = 1;
 541   return SCM_MAKINUM (old_n);
 542 }
 543
 544 \f
 545
 546 #ifdef __STDC__
 547 static SCM
 548 scm_sys_hup_async_thunk (void)
 549 #else
 550 static SCM
 551 scm_sys_hup_async_thunk ()
 552 #endif
 553 {
 554   scm_deliver_signal (SCM_HUP_SIGNAL);
 555   return SCM_BOOL_F;
 556 }
 557
 558 #ifdef __STDC__
 559 static SCM
 560 scm_sys_int_async_thunk (void)
 561 #else
 562 static SCM
 563 scm_sys_int_async_thunk ()
 564 #endif
 565 {
 566   scm_deliver_signal (SCM_INT_SIGNAL);
 567   return SCM_BOOL_F;
 568 }
 569
 570 #ifdef __STDC__
 571 static SCM
 572 scm_sys_fpe_async_thunk (void)
 573 #else
 574 static SCM
 575 scm_sys_fpe_async_thunk ()
 576 #endif
 577 {
 578   scm_deliver_signal (SCM_FPE_SIGNAL);
 579   return SCM_BOOL_F;
 580 }
 581
 582 #ifdef __STDC__
 583 static SCM
 584 scm_sys_bus_async_thunk (void)
 585 #else
 586 static SCM
 587 scm_sys_bus_async_thunk ()
 588 #endif
 589 {
 590   scm_deliver_signal (SCM_BUS_SIGNAL);
 591   return SCM_BOOL_F;
 592 }
 593
 594 #ifdef __STDC__
 595 static SCM
 596 scm_sys_segv_async_thunk (void)
 597 #else
 598 static SCM
 599 scm_sys_segv_async_thunk ()
 600 #endif
 601 {
 602   scm_deliver_signal (SCM_SEGV_SIGNAL);
 603   return SCM_BOOL_F;
 604 }
 605
 606 #ifdef __STDC__
 607 static SCM
 608 scm_sys_alrm_async_thunk (void)
 609 #else
 610 static SCM
 611 scm_sys_alrm_async_thunk ()
 612 #endif
 613 {
 614   scm_deliver_signal (SCM_ALRM_SIGNAL);
 615   return SCM_BOOL_F;
 616 }
 617
 618 #ifdef __STDC__
 619 static SCM
 620 scm_sys_gc_async_thunk (void)
 621 #else
 622 static SCM
 623 scm_sys_gc_async_thunk ()
 624 #endif
 625 {
 626   scm_deliver_signal (SCM_GC_SIGNAL);
 627   return SCM_BOOL_F;
 628 }
 629
 630 #ifdef __STDC__
 631 static SCM
 632 scm_sys_tick_async_thunk (void)
 633 #else
 634 static SCM
 635 scm_sys_tick_async_thunk ()
 636 #endif
 637 {
 638   scm_deliver_signal (SCM_TICK_SIGNAL);
 639   return SCM_BOOL_F;
 640 }
 641
 642
 643
 644 \f
 645
 646 #ifdef __STDC__
 647 SCM
 648 scm_take_signal (int n)
 649 #else
 650 SCM
 651 scm_take_signal (n)
 652      int n;
 653 #endif
 654 {
 655   SCM ignored;
 656   if (!scm_ints_disabled)
 657     {
 658       SCM_NEWCELL (ignored);            /* In case we interrupted SCM_NEWCELL,
 659                                          * throw out the possibly already allocated
 660                                          * free cell.
 661                                          */
 662     }
 663   scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]);
 664   return SCM_BOOL_F;
 665 }
 666
 667 \f
 668
 669 SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals);
 670 #ifdef __STDC__
 671 SCM
 672 scm_unmask_signals (void)
 673 #else
 674 SCM
 675 scm_unmask_signals ()
 676 #endif
 677 {
 678   scm_mask_ints = 0;
 679   return SCM_UNSPECIFIED;
 680 }
 681
 682
 683 SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals);
 684 #ifdef __STDC__
 685 SCM
 686 scm_mask_signals (void)
 687 #else
 688 SCM
 689 scm_mask_signals ()
 690 #endif
 691 {
 692   scm_mask_ints = 1;
 693   return SCM_UNSPECIFIED;
 694 }
 695
 696 \f
 697
 698 #ifdef __STDC__
 699 void
 700 scm_init_async (void)
 701 #else
 702 void
 703 scm_init_async ()
 704 #endif
 705 {
 706   SCM a_thunk;
 707   scm_tc16_async = scm_newsmob (&async_smob);
 708   symbol_signal = SCM_CAR (scm_sysintern ("signal", strlen ("signal")));
 709   scm_permanent_object (symbol_signal);
 710
 711   /* These are in the opposite order of delivery priortity.
 712    *
 713    * Error conditions are given low priority:
 714    */
 715   a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk);
 716   system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk);
 717   a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk);
 718   system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk);
 719   a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk);
 720   system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk);
 721   a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk);
 722   system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk);
 723   a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk);
 724   system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk);
 725
 726
 727   a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk);
 728   system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk);
 729
 730   /* Clock and PC driven conditions are given highest priority. */
 731   a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk);
 732   system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk);
 733   a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk);
 734   system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk);
 735
 736   handler_var = scm_sysintern ("signal-handler", strlen ("signal"));
 737   SCM_SETCDR (handler_var, SCM_BOOL_F);
 738   scm_permanent_object (handler_var);
 739 #include "async.x"
 740 }