libguile/async.c

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