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 #include "eval.h"
  47 #include "throw.h"
  48 #include "smob.h"
  49
  50 #include "async.h"
  51
  52 #ifdef HAVE_STRING_H
  53 #include <string.h>
  54 #endif
  55 #ifdef HAVE_UNISTD_H
  56 #include <unistd.h>
  57 #endif
  58
  59
  60 \f
  61 /* {Asynchronous Events}
  62  *
  63  *
  64  * Async == thunk + mark.
  65  *
  66  * Setting the mark guarantees future execution of the thunk.  More
  67  * than one set may be satisfied by a single execution.
  68  *
  69  * scm_tick_clock decremented once per SCM_ALLOW_INTS.
  70  * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0.
  71  * Async execution prevented by scm_mask_ints != 0.
  72  *
  73  * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock
  74  * to 1.
  75  *
  76  * If the clock reaches 0 any other time, run marked asyncs.
  77  *
  78  * From a unix signal handler, mark a corresponding async and set the clock
  79  * to 1.   Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not
  80  * called in the dynamic scope of a critical section, it is excecuted immediately.
  81  *
  82  * Overall, closely timed signals of a particular sort may be combined.  Pending signals
  83  * are delivered in a fixed priority order, regardless of arrival order.
  84  *
  85  */
  86
  87
  88
  89 unsigned int scm_async_clock = 20;
  90 static unsigned int scm_async_rate = 20;
  91 unsigned int scm_mask_ints = 1;
  92
  93 static unsigned int scm_tick_clock = 0;
  94 static unsigned int scm_tick_rate = 0;
  95 static unsigned int scm_desired_tick_rate = 0;
  96 static unsigned int scm_switch_clock = 0;
  97 static unsigned int scm_switch_rate = 0;
  98 static unsigned int scm_desired_switch_rate = 0;
  99
 100 static SCM system_signal_asyncs[SCM_NUM_SIGS];
 101 static SCM handler_var;
 102 static SCM symbol_signal;
 103
 104
 105 struct scm_async
 106 {
 107   int got_it;                   /* needs to be delivered? */
 108   SCM thunk;                    /* the handler. */
 109 };
 110
 111
 112 static long scm_tc16_async;
 113
 114 #define SCM_ASYNCP(X)   (scm_tc16_async == SCM_GCTYP16 (X))
 115 #define SCM_ASYNC(X)    ((struct scm_async *)SCM_CDR (X))
 116
 117
 118
 119
 120 \f
 121
 122 static int asyncs_pending SCM_P ((void));
 123
 124 static int
 125 asyncs_pending ()
 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
 144 void
 145 scm_async_click ()
 146 {
 147   int owe_switch;
 148   int owe_tick;
 149
 150   if (!scm_switch_rate)
 151     {
 152       owe_switch = 0;
 153       scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 154       scm_desired_switch_rate = 0;
 155     }
 156   else
 157     {
 158       owe_switch = (scm_async_rate >= scm_switch_clock);
 159       if (owe_switch)
 160         {
 161           if (scm_desired_switch_rate)
 162             {
 163               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 164               scm_desired_switch_rate = 0;
 165             }
 166           else
 167             scm_switch_clock = scm_switch_rate;
 168         }
 169       else
 170         {
 171           if (scm_desired_switch_rate)
 172             {
 173               scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
 174               scm_desired_switch_rate = 0;
 175             }
 176           else
 177             scm_switch_clock -= scm_async_rate;
 178         }
 179     }
 180
 181   if (scm_mask_ints)
 182     {
 183       if (owe_switch)
 184         scm_switch ();
 185       scm_async_clock = 1;
 186       return;;
 187     }
 188
 189   if (!scm_tick_rate)
 190     {
 191       unsigned int r;
 192       owe_tick = 0;
 193       r = scm_desired_tick_rate;
 194       if (r)
 195         {
 196           scm_desired_tick_rate = 0;
 197           scm_tick_rate = r;
 198           scm_tick_clock = r;
 199         }
 200     }
 201   else
 202     {
 203       owe_tick = (scm_async_rate >= scm_tick_clock);
 204       if (owe_tick)
 205         {
 206           scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 207           scm_desired_tick_rate = 0;
 208         }
 209       else
 210         {
 211           if (scm_desired_tick_rate)
 212             {
 213               scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
 214               scm_desired_tick_rate = 0;
 215             }
 216           else
 217             scm_tick_clock -= scm_async_rate;
 218         }
 219     }
 220
 221   if (owe_tick)
 222     scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]);
 223
 224   SCM_DEFER_INTS;
 225   if (scm_tick_rate && scm_switch_rate)
 226     {
 227       scm_async_rate = min (scm_tick_clock,  scm_switch_clock);
 228       scm_async_clock = scm_async_rate;
 229     }
 230   else if (scm_tick_rate)
 231     {
 232       scm_async_clock = scm_async_rate = scm_tick_clock;
 233     }
 234   else if (scm_switch_rate)
 235     {
 236       scm_async_clock = scm_async_rate = scm_switch_clock;
 237     }
 238   else
 239     scm_async_clock = scm_async_rate = 1 << 16;
 240   SCM_ALLOW_INTS_ONLY;
 241
 242  tail:
 243   scm_run_asyncs (scm_asyncs);
 244
 245   SCM_DEFER_INTS;
 246   if (asyncs_pending ())
 247     {
 248       SCM_ALLOW_INTS_ONLY;
 249       goto tail;
 250     }
 251   SCM_ALLOW_INTS;
 252
 253   if (owe_switch)
 254     scm_switch ();
 255 }
 256
 257
 258 \f
 259
 260
 261 void
 262 scm_switch ()
 263 {
 264 #if 0 /* Thread switching code should probably reside here, but the
 265          async switching code doesn't seem to work, so it's put in the
 266          SCM_ASYNC_TICK macro instead. /mdj */
 267   SCM_THREAD_SWITCHING_CODE;
 268 #endif
 269 }
 270
 271
 272
 273 static void scm_deliver_signal SCM_P ((int num));
 274
 275 static void
 276 scm_deliver_signal (num)
 277      int num;
 278 {
 279   SCM handler;
 280   handler = SCM_CDR (handler_var);
 281   if (handler != SCM_BOOL_F)
 282     scm_apply (handler, SCM_MAKINUM (num), scm_listofnull);
 283   else
 284     {
 285       scm_mask_ints = 0;
 286       scm_throw (symbol_signal,
 287                            scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED));
 288     }
 289 }
 290
 291
 292 \f
 293
 294
 295 static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
 296
 297 static int
 298 print_async (exp, port, pstate)
 299      SCM exp;
 300      SCM port;
 301      scm_print_state *pstate;
 302 {
 303   scm_gen_puts (scm_regular_string, "#<async ", port);
 304   scm_intprint(exp, 16, port);
 305   scm_gen_putc('>', port);
 306   return 1;
 307 }
 308
 309
 310 static SCM mark_async SCM_P ((SCM obj));
 311
 312 static SCM
 313 mark_async (obj)
 314      SCM obj;
 315 {
 316   struct scm_async * it;
 317   if (SCM_GC8MARKP (obj))
 318     return SCM_BOOL_F;
 319   SCM_SETGC8MARK (obj);
 320   it = SCM_ASYNC (obj);
 321   return it->thunk;
 322 }
 323
 324
 325 static scm_sizet free_async SCM_P ((SCM obj));
 326
 327 static scm_sizet
 328 free_async (obj)
 329      SCM obj;
 330 {
 331   struct scm_async * it;
 332   it = SCM_ASYNC (obj);
 333   scm_must_free ((char *)it);
 334   return (sizeof (*it));
 335 }
 336
 337
 338 static scm_smobfuns  async_smob =
 339 {
 340   mark_async,
 341   free_async,
 342   print_async,
 343   0
 344 };
 345
 346
 347 \f
 348
 349 SCM_PROC(s_async, "async", 1, 0, 0, scm_async);
 350
 351 SCM
 352 scm_async (thunk)
 353      SCM thunk;
 354 {
 355   SCM it;
 356   struct scm_async * async;
 357
 358   SCM_NEWCELL (it);
 359   SCM_DEFER_INTS;
 360   SCM_SETCDR (it, SCM_EOL);
 361   async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async);
 362   async->got_it = 0;
 363   async->thunk = thunk;
 364   SCM_SETCDR (it, (SCM)async);
 365   SCM_SETCAR (it, (SCM)scm_tc16_async);
 366   SCM_ALLOW_INTS;
 367   return it;
 368 }
 369
 370 SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
 371
 372 SCM
 373 scm_system_async (thunk)
 374      SCM thunk;
 375 {
 376   SCM it;
 377   SCM list;
 378
 379   it = scm_async (thunk);
 380   SCM_NEWCELL (list);
 381   SCM_DEFER_INTS;
 382   SCM_SETCAR (list, it);
 383   SCM_SETCDR (list, scm_asyncs);
 384   scm_asyncs = list;
 385   SCM_ALLOW_INTS;
 386   return it;
 387 }
 388
 389 SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark);
 390
 391 SCM
 392 scm_async_mark (a)
 393      SCM a;
 394 {
 395   struct scm_async * it;
 396   SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
 397   it = SCM_ASYNC (a);
 398   it->got_it = 1;
 399   return SCM_UNSPECIFIED;
 400 }
 401
 402
 403 SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark);
 404
 405 SCM
 406 scm_system_async_mark (a)
 407      SCM a;
 408 {
 409   struct scm_async * it;
 410   SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
 411   it = SCM_ASYNC (a);
 412   SCM_REDEFER_INTS;
 413   it->got_it = 1;
 414   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 415   scm_async_clock = 1;
 416   SCM_REALLOW_INTS;
 417   return SCM_UNSPECIFIED;
 418 }
 419
 420
 421 SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs);
 422
 423 SCM
 424 scm_run_asyncs (list_of_a)
 425      SCM list_of_a;
 426 {
 427   SCM pos;
 428
 429   if (scm_mask_ints)
 430     return SCM_BOOL_F;
 431   pos = list_of_a;
 432   while (pos != SCM_EOL)
 433     {
 434       SCM a;
 435       struct scm_async * it;
 436       SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs);
 437       a = SCM_CAR (pos);
 438       SCM_ASSERT (SCM_NIMP (a) &&  SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs);
 439       it = SCM_ASYNC (a);
 440       scm_mask_ints = 1;
 441       if (it->got_it)
 442         {
 443           it->got_it = 0;
 444           scm_apply (it->thunk, SCM_EOL, SCM_EOL);
 445         }
 446       scm_mask_ints = 0;
 447       pos = SCM_CDR (pos);
 448     }
 449   return SCM_BOOL_T;
 450 }
 451
 452 \f
 453
 454
 455 SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop);
 456
 457 SCM
 458 scm_noop (args)
 459      SCM args;
 460 {
 461   return (SCM_NULLP (args)
 462           ? SCM_BOOL_F
 463           : SCM_CAR (args));
 464 }
 465
 466
 467 \f
 468
 469 SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate);
 470
 471 SCM
 472 scm_set_tick_rate (n)
 473      SCM n;
 474 {
 475   unsigned int old_n;
 476   SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate);
 477   old_n = scm_tick_rate;
 478   scm_desired_tick_rate = SCM_INUM (n);
 479   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 480   scm_async_clock = 1;
 481   return SCM_MAKINUM (old_n);
 482 }
 483
 484 \f
 485
 486
 487 SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate);
 488
 489 SCM
 490 scm_set_switch_rate (n)
 491      SCM n;
 492 {
 493   unsigned int old_n;
 494   SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate);
 495   old_n = scm_switch_rate;
 496   scm_desired_switch_rate = SCM_INUM (n);
 497   scm_async_rate = 1 + scm_async_rate - scm_async_clock;
 498   scm_async_clock = 1;
 499   return SCM_MAKINUM (old_n);
 500 }
 501
 502 \f
 503
 504
 505 static SCM scm_sys_hup_async_thunk SCM_P ((void));
 506
 507 static SCM
 508 scm_sys_hup_async_thunk ()
 509 {
 510   scm_deliver_signal (SCM_HUP_SIGNAL);
 511   return SCM_BOOL_F;
 512 }
 513
 514
 515 static SCM scm_sys_int_async_thunk SCM_P ((void));
 516
 517 static SCM
 518 scm_sys_int_async_thunk ()
 519 {
 520   scm_deliver_signal (SCM_INT_SIGNAL);
 521   return SCM_BOOL_F;
 522 }
 523
 524
 525 static SCM scm_sys_fpe_async_thunk SCM_P ((void));
 526
 527 static SCM
 528 scm_sys_fpe_async_thunk ()
 529 {
 530   scm_deliver_signal (SCM_FPE_SIGNAL);
 531   return SCM_BOOL_F;
 532 }
 533
 534
 535 static SCM scm_sys_bus_async_thunk SCM_P ((void));
 536
 537 static SCM
 538 scm_sys_bus_async_thunk ()
 539 {
 540   scm_deliver_signal (SCM_BUS_SIGNAL);
 541   return SCM_BOOL_F;
 542 }
 543
 544
 545 static SCM scm_sys_segv_async_thunk SCM_P ((void));
 546
 547 static SCM
 548 scm_sys_segv_async_thunk ()
 549 {
 550   scm_deliver_signal (SCM_SEGV_SIGNAL);
 551   return SCM_BOOL_F;
 552 }
 553
 554
 555 static SCM scm_sys_alrm_async_thunk SCM_P ((void));
 556
 557 static SCM
 558 scm_sys_alrm_async_thunk ()
 559 {
 560   scm_deliver_signal (SCM_ALRM_SIGNAL);
 561   return SCM_BOOL_F;
 562 }
 563
 564
 565 static SCM scm_sys_gc_async_thunk SCM_P ((void));
 566
 567 static SCM
 568 scm_sys_gc_async_thunk ()
 569 {
 570   scm_deliver_signal (SCM_GC_SIGNAL);
 571   return SCM_BOOL_F;
 572 }
 573
 574
 575 static SCM scm_sys_tick_async_thunk SCM_P ((void));
 576
 577 static SCM
 578 scm_sys_tick_async_thunk ()
 579 {
 580   scm_deliver_signal (SCM_TICK_SIGNAL);
 581   return SCM_BOOL_F;
 582 }
 583
 584
 585
 586 \f
 587
 588
 589 SCM
 590 scm_take_signal (n)
 591      int n;
 592 {
 593   SCM ignored;
 594   if (!scm_ints_disabled)
 595     {
 596       /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
 597          interrupts.  Instead, it first sets its argument to point to
 598          the first cell in the list, and then advances the freelist
 599          pointer to the next cell.  Now, if this procedure is
 600          interrupted, the only anomalous state possible is to have
 601          both SCM_NEWCELL's argument and scm_freelist pointing to the
 602          same cell.  To deal with this case, we always throw away the
 603          first cell in scm_freelist here.
 604
 605          At least, that's the theory.  I'm not convinced that that's
 606          the only anomalous path we need to worry about.  */
 607       SCM_NEWCELL (ignored);
 608     }
 609   scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]);
 610   return SCM_BOOL_F;
 611 }
 612
 613 \f
 614
 615 SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals);
 616
 617 SCM
 618 scm_unmask_signals ()
 619 {
 620   scm_mask_ints = 0;
 621   return SCM_UNSPECIFIED;
 622 }
 623
 624
 625 SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals);
 626
 627 SCM
 628 scm_mask_signals ()
 629 {
 630   scm_mask_ints = 1;
 631   return SCM_UNSPECIFIED;
 632 }
 633
 634 \f
 635
 636
 637 void
 638 scm_init_async ()
 639 {
 640   SCM a_thunk;
 641   scm_tc16_async = scm_newsmob (&async_smob);
 642   symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED));
 643   scm_permanent_object (symbol_signal);
 644
 645   /* These are in the opposite order of delivery priortity.
 646    *
 647    * Error conditions are given low priority:
 648    */
 649   a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk);
 650   system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk);
 651   a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk);
 652   system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk);
 653   a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk);
 654   system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk);
 655   a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk);
 656   system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk);
 657   a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk);
 658   system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk);
 659
 660
 661   a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk);
 662   system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk);
 663
 664   /* Clock and PC driven conditions are given highest priority. */
 665   a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk);
 666   system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk);
 667   a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk);
 668   system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk);
 669
 670   handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED);
 671   SCM_SETCDR (handler_var, SCM_BOOL_F);
 672   scm_permanent_object (handler_var);
 673 #include "async.x"
 674 }