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