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