1 /* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
49 #include "libguile/_scm.h"
50 #include "libguile/eval.h"
51 #include "libguile/throw.h"
52 #include "libguile/root.h"
53 #include "libguile/smob.h"
54 #include "libguile/gc.h"
56 #include "libguile/validate.h"
57 #include "libguile/async.h"
68 /* {Asynchronous Events}
71 * Async == thunk + mark.
73 * Setting the mark guarantees future execution of the thunk. More
74 * than one set may be satisfied by a single execution.
76 * scm_tick_clock decremented once per SCM_ALLOW_INTS.
77 * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0.
78 * Async execution prevented by scm_mask_ints != 0.
80 * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock
83 * If the clock reaches 0 any other time, run marked asyncs.
85 * From a unix signal handler, mark a corresponding async and set the clock
86 * to 1. Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not
87 * called in the dynamic scope of a critical section, it is excecuted immediately.
89 * Overall, closely timed signals of a particular sort may be combined. Pending signals
90 * are delivered in a fixed priority order, regardless of arrival order.
94 /* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
95 * when the interpreter is not running at all.
97 int scm_ints_disabled
= 1;
98 unsigned int scm_mask_ints
= 1;
100 #ifdef GUILE_OLD_ASYNC_CLICK
101 unsigned int scm_async_clock
= 20;
102 static unsigned int scm_async_rate
= 20;
104 static unsigned int scm_tick_clock
= 0;
105 static unsigned int scm_tick_rate
= 0;
106 static unsigned int scm_desired_tick_rate
= 0;
107 static unsigned int scm_switch_clock
= 0;
108 static unsigned int scm_switch_rate
= 0;
109 static unsigned int scm_desired_switch_rate
= 0;
111 int scm_asyncs_pending_p
= 0;
114 static long tc16_async
;
118 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
120 #define SCM_ASYNCP(X) (SCM_NIMP(X) && (tc16_async == SCM_GCTYP16 (X)))
122 #define VALIDATE_ASYNC(pos,a) SCM_MAKE_VALIDATE(pos, a, ASYNCP)
124 #define ASYNC_GOT_IT(X) (SCM_CELL_WORD_0 (X) >> 16)
125 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_CELL_WORD_0 (X, (SCM_CELL_WORD_0 (X) & ((1 << 16) - 1)) | ((V) << 16)))
126 #define ASYNC_THUNK(X) SCM_CELL_OBJECT_1 (X)
130 #ifdef GUILE_OLD_ASYNC_CLICK
132 scm_asyncs_pending ()
136 while (pos
!= SCM_EOL
)
138 SCM a
= SCM_CAR (pos
);
139 if (ASYNC_GOT_IT (a
))
148 scm_sys_tick_async_thunk (void)
150 scm_deliver_signal (SCM_TICK_SIGNAL
);
161 if (!scm_switch_rate
)
164 scm_switch_clock
= scm_switch_rate
= scm_desired_switch_rate
;
165 scm_desired_switch_rate
= 0;
169 owe_switch
= (scm_async_rate
>= scm_switch_clock
);
172 if (scm_desired_switch_rate
)
174 scm_switch_clock
= scm_switch_rate
= scm_desired_switch_rate
;
175 scm_desired_switch_rate
= 0;
178 scm_switch_clock
= scm_switch_rate
;
182 if (scm_desired_switch_rate
)
184 scm_switch_clock
= scm_switch_rate
= scm_desired_switch_rate
;
185 scm_desired_switch_rate
= 0;
188 scm_switch_clock
-= scm_async_rate
;
204 r
= scm_desired_tick_rate
;
207 scm_desired_tick_rate
= 0;
214 owe_tick
= (scm_async_rate
>= scm_tick_clock
);
217 scm_tick_clock
= scm_tick_rate
= scm_desired_tick_rate
;
218 scm_desired_tick_rate
= 0;
222 if (scm_desired_tick_rate
)
224 scm_tick_clock
= scm_tick_rate
= scm_desired_tick_rate
;
225 scm_desired_tick_rate
= 0;
228 scm_tick_clock
-= scm_async_rate
;
234 scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); */
237 if (scm_tick_rate
&& scm_switch_rate
)
239 scm_async_rate
= min (scm_tick_clock
, scm_switch_clock
);
240 scm_async_clock
= scm_async_rate
;
242 else if (scm_tick_rate
)
244 scm_async_clock
= scm_async_rate
= scm_tick_clock
;
246 else if (scm_switch_rate
)
248 scm_async_clock
= scm_async_rate
= scm_switch_clock
;
251 scm_async_clock
= scm_async_rate
= 1 << 16;
255 scm_run_asyncs (scm_asyncs
);
258 if (scm_asyncs_pending ())
272 #if 0 /* Thread switching code should probably reside here, but the
273 async switching code doesn't seem to work, so it's put in the
274 SCM_DEFER_INTS macro instead. /mdj */
275 SCM_THREAD_SWITCHING_CODE
;
286 scm_run_asyncs (scm_asyncs
);
287 while (scm_asyncs_pending_p
);
298 return ASYNC_THUNK (obj
);
303 SCM_DEFINE (scm_async
, "async", 1, 0, 0,
306 #define FUNC_NAME s_scm_async
308 SCM_RETURN_NEWSMOB (tc16_async
, SCM_UNPACK (thunk
));
312 SCM_DEFINE (scm_system_async
, "system-async", 1, 0, 0,
315 #define FUNC_NAME s_scm_system_async
320 it
= scm_async (thunk
);
322 SCM_SETCAR (list
, it
);
323 SCM_SETCDR (list
, scm_asyncs
);
329 SCM_DEFINE (scm_async_mark
, "async-mark", 1, 0, 0,
332 #define FUNC_NAME s_scm_async_mark
334 VALIDATE_ASYNC (1, a
);
335 #ifdef GUILE_OLD_ASYNC_CLICK
336 SET_ASYNC_GOT_IT (a
, 1);
338 SET_ASYNC_GOT_IT (a
, scm_asyncs_pending_p
= 1);
340 return SCM_UNSPECIFIED
;
345 SCM_DEFINE (scm_system_async_mark
, "system-async-mark", 1, 0, 0,
348 #define FUNC_NAME s_scm_system_async_mark
350 VALIDATE_ASYNC (1, a
);
352 #ifdef GUILE_OLD_ASYNC_CLICK
353 SET_ASYNC_GOT_IT (a
, 1);
354 scm_async_rate
= 1 + scm_async_rate
- scm_async_clock
;
357 SET_ASYNC_GOT_IT (a
, scm_asyncs_pending_p
= 1);
360 return SCM_UNSPECIFIED
;
365 SCM_DEFINE (scm_run_asyncs
, "run-asyncs", 1, 0, 0,
368 #define FUNC_NAME s_scm_run_asyncs
370 #ifdef GUILE_OLD_ASYNC_CLICK
374 scm_asyncs_pending_p
= 0;
376 while (! SCM_NULLP (list_of_a
))
379 SCM_VALIDATE_CONS (1, list_of_a
);
380 a
= SCM_CAR (list_of_a
);
381 VALIDATE_ASYNC (SCM_ARG1
, a
);
383 if (ASYNC_GOT_IT (a
))
385 SET_ASYNC_GOT_IT (a
, 0);
386 scm_apply (ASYNC_THUNK (a
), SCM_EOL
, SCM_EOL
);
389 list_of_a
= SCM_CDR (list_of_a
);
398 SCM_DEFINE (scm_noop
, "noop", 0, 0, 1,
401 #define FUNC_NAME s_scm_noop
403 return (SCM_NULLP (args
) ? SCM_BOOL_F
: SCM_CAR (args
));
410 #ifdef GUILE_OLD_ASYNC_CLICK
412 SCM_DEFINE (scm_set_tick_rate
, "set-tick-rate", 1, 0, 0,
415 #define FUNC_NAME s_scm_set_tick_rate
417 unsigned int old_n
= scm_tick_rate
;
418 SCM_VALIDATE_INUM (1, n
);
419 scm_desired_tick_rate
= SCM_INUM (n
);
420 scm_async_rate
= 1 + scm_async_rate
- scm_async_clock
;
422 return SCM_MAKINUM (old_n
);
429 SCM_DEFINE (scm_set_switch_rate
, "set-switch-rate", 1, 0, 0,
432 #define FUNC_NAME s_scm_set_switch_rate
434 unsigned int old_n
= scm_switch_rate
;
435 SCM_VALIDATE_INUM (1, n
);
436 scm_desired_switch_rate
= SCM_INUM (n
);
437 scm_async_rate
= 1 + scm_async_rate
- scm_async_clock
;
439 return SCM_MAKINUM (old_n
);
446 /* points to the GC system-async, so that scm_gc_end can find it. */
449 /* the vcell for gc-thunk. */
450 static SCM scm_gc_vcell
;
452 /* the thunk installed in the GC system-async, which is marked at the
453 end of garbage collection. */
455 scm_sys_gc_async_thunk (void)
457 scm_c_run_hook (scm_after_gc_hook
, SCM_EOL
);
459 #if (SCM_DEBUG_DEPRECATED == 0)
461 /* The following code will be removed in Guile 1.5. */
462 if (SCM_NFALSEP (scm_gc_vcell
))
464 SCM proc
= SCM_CDR (scm_gc_vcell
);
466 if (SCM_NFALSEP (proc
) && !SCM_UNBNDP (proc
))
467 scm_apply (proc
, SCM_EOL
, SCM_EOL
);
470 #endif /* SCM_DEBUG_DEPRECATED == 0 */
472 return SCM_UNSPECIFIED
;
477 SCM_DEFINE (scm_unmask_signals
, "unmask-signals", 0, 0, 0,
480 #define FUNC_NAME s_scm_unmask_signals
483 return SCM_UNSPECIFIED
;
488 SCM_DEFINE (scm_mask_signals
, "mask-signals", 0, 0, 0,
491 #define FUNC_NAME s_scm_mask_signals
494 return SCM_UNSPECIFIED
;
504 tc16_async
= scm_make_smob_type_mfpe ("async", 0,
505 mark_async
, NULL
, NULL
, NULL
);
506 scm_gc_vcell
= scm_sysintern ("gc-thunk", SCM_BOOL_F
);
507 a_thunk
= scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk
);
508 scm_gc_async
= scm_system_async (a_thunk
);
510 #include "libguile/async.x"