1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 #include <fcntl.h> /* for mingw */
30 #include "libguile/_scm.h"
32 #include "libguile/async.h"
33 #include "libguile/eval.h"
34 #include "libguile/root.h"
35 #include "libguile/vectors.h"
37 #include "libguile/validate.h"
38 #include "libguile/scmsigs.h"
41 #include <io.h> /* for mingw _pipe() */
45 #include <process.h> /* for mingw */
52 #ifdef HAVE_SYS_TIME_H
58 #define alarm(sec) (0)
59 /* This weird comma expression is because Sleep is void under Windows. */
60 #define sleep(sec) (Sleep ((sec) * 1000), 0)
61 #define usleep(usec) (Sleep ((usec) / 1000), 0)
62 #define pipe(fd) _pipe (fd, 256, O_BINARY)
67 /* SIGRETTYPE is the type that signal handlers return. See <signal.h> */
70 # define SIGRETTYPE RETSIGTYPE
73 # define SIGRETTYPE void
75 # define SIGRETTYPE int
81 /* take_signal is installed as the C signal handler whenever a Scheme
82 handler is set. When a signal arrives, take_signal will write a
83 byte into the 'signal pipe'. The 'signal delivery thread' will
84 read this pipe and queue the appropriate asyncs.
86 When Guile is built without threads, the signal handler will
87 install the async directly.
91 /* Scheme vectors with information about a signal. signal_handlers
92 contains the handler procedure or #f, signal_handler_asyncs
93 contains the thunk to be marked as an async when the signal arrives
94 (or the cell with the thunk in a singlethreaded Guile), and
95 signal_handler_threads points to the thread that a signal should be
98 static SCM *signal_handlers;
99 static SCM signal_handler_asyncs;
100 static SCM signal_handler_threads;
102 /* saves the original C handlers, when a new handler is installed.
103 set to SIG_ERR if the original handler is installed. */
104 #ifdef HAVE_SIGACTION
105 static struct sigaction orig_handlers[NSIG];
107 static SIGRETTYPE (*orig_handlers[NSIG])(int);
111 handler_to_async (SCM handler, int signum)
113 if (scm_is_false (handler))
117 SCM async = scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
119 scm_from_int (signum))));
120 #if !SCM_USE_PTHREAD_THREADS
121 async = scm_cons (async, SCM_BOOL_F);
127 #if SCM_USE_PTHREAD_THREADS
128 /* On mingw there's no notion of inter-process signals, only a raise()
129 within the process itself which apparently invokes the registered handler
130 immediately. Not sure how well the following code will cope in this
131 case. It builds but it may not offer quite the same scheme-level
132 semantics as on a proper system. If you're relying on much in the way of
133 signal handling on mingw you probably lose anyway. */
135 static int signal_pipe[2];
138 take_signal (int signum)
141 char sigbyte = signum;
143 count = write (signal_pipe[1], &sigbyte, 1);
145 #ifndef HAVE_SIGACTION
146 signal (signum, take_signal);
155 } read_without_guile_data;
158 do_read_without_guile (void *raw_data)
160 read_without_guile_data *data = (read_without_guile_data *)raw_data;
161 data->res = read (data->fd, data->buf, data->n);
166 read_without_guile (int fd, char *buf, size_t n)
168 read_without_guile_data data;
172 scm_without_guile (do_read_without_guile, &data);
177 signal_delivery_thread (void *data)
181 #if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
183 sigfillset (&all_sigs);
184 scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
189 n = read_without_guile (signal_pipe[0], &sigbyte, 1);
191 if (n == 1 && sig >= 0 && sig < NSIG)
195 h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
196 t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
198 scm_system_async_mark_for_thread (h, t);
200 else if (n < 0 && errno != EINTR)
201 perror ("error in signal delivery thread");
204 return SCM_UNSPECIFIED; /* not reached */
208 start_signal_delivery_thread (void)
210 if (pipe (signal_pipe) != 0)
212 scm_spawn_thread (signal_delivery_thread, NULL,
213 scm_handle_by_message, "signal delivery thread");
217 ensure_signal_delivery_thread ()
219 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
220 scm_i_pthread_once (&once, start_signal_delivery_thread);
223 #else /* !SCM_USE_PTHREAD_THREADS */
226 take_signal (int signum)
228 SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
229 scm_i_thread *t = SCM_I_CURRENT_THREAD;
231 if (scm_is_false (SCM_CDR (cell)))
233 SCM_SETCDR (cell, t->active_asyncs);
234 t->active_asyncs = cell;
235 t->pending_asyncs = 1;
238 #ifndef HAVE_SIGACTION
239 signal (signum, take_signal);
244 ensure_signal_delivery_thread ()
249 #endif /* !SCM_USE_PTHREAD_THREADS */
252 install_handler (int signum, SCM thread, SCM handler, SCM async)
254 SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
255 SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
256 SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
260 scm_sigaction (SCM signum, SCM handler, SCM flags)
262 return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
265 /* user interface for installation of signal handlers. */
266 SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
267 (SCM signum, SCM handler, SCM flags, SCM thread),
268 "Install or report the signal handler for a specified signal.\n\n"
269 "@var{signum} is the signal number, which can be specified using the value\n"
270 "of variables such as @code{SIGINT}.\n\n"
271 "If @var{handler} is omitted, @code{sigaction} returns a pair: the\n"
272 "CAR is the current\n"
273 "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
274 "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
275 "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
276 "signal. The CDR contains the current @code{sigaction} flags for the handler.\n\n"
277 "If @var{handler} is provided, it is installed as the new handler for\n"
278 "@var{signum}. @var{handler} can be a Scheme procedure taking one\n"
279 "argument, or the value of @code{SIG_DFL} (default action) or\n"
280 "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
281 "was installed before @code{sigaction} was first used. When\n"
282 "a scheme procedure has been specified, that procedure will run\n"
283 "in the given @var{thread}. When no thread has been given, the\n"
284 "thread that made this call to @code{sigaction} is used.\n"
285 "Flags can optionally be specified for the new handler.\n"
286 "The return value is a pair with information about the\n"
287 "old handler as described above.\n\n"
288 "This interface does not provide access to the \"signal blocking\"\n"
289 "facility. Maybe this is not needed, since the thread support may\n"
290 "provide solutions to the problem of consistent access to data\n"
292 #define FUNC_NAME s_scm_sigaction_for_thread
295 #ifdef HAVE_SIGACTION
296 struct sigaction action;
297 struct sigaction old_action;
299 SIGRETTYPE (* chandler) (int) = SIG_DFL;
300 SIGRETTYPE (* old_chandler) (int);
303 int save_handler = 0;
308 csig = scm_to_signed_integer (signum, 0, NSIG-1);
310 #if defined(HAVE_SIGACTION)
312 if (!SCM_UNBNDP (flags))
313 action.sa_flags |= scm_to_int (flags);
314 sigemptyset (&action.sa_mask);
317 if (SCM_UNBNDP (thread))
318 thread = scm_current_thread ();
321 SCM_VALIDATE_THREAD (4, thread);
322 if (scm_c_thread_exited_p (thread))
323 SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
326 /* Allocate upfront, as we can't do it inside the critical
328 async = handler_to_async (handler, csig);
330 ensure_signal_delivery_thread ();
332 SCM_CRITICAL_SECTION_START;
333 old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
334 if (SCM_UNBNDP (handler))
336 else if (scm_is_integer (handler))
338 long handler_int = scm_to_long (handler);
340 if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
342 #ifdef HAVE_SIGACTION
343 action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
345 chandler = (SIGRETTYPE (*) (int)) handler_int;
347 install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
351 SCM_CRITICAL_SECTION_END;
352 SCM_OUT_OF_RANGE (2, handler);
355 else if (scm_is_false (handler))
357 /* restore the default handler. */
358 #ifdef HAVE_SIGACTION
359 if (orig_handlers[csig].sa_handler == SIG_ERR)
363 action = orig_handlers[csig];
364 orig_handlers[csig].sa_handler = SIG_ERR;
365 install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
368 if (orig_handlers[csig] == SIG_ERR)
372 chandler = orig_handlers[csig];
373 orig_handlers[csig] = SIG_ERR;
374 install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
380 SCM_VALIDATE_PROC (2, handler);
381 #ifdef HAVE_SIGACTION
382 action.sa_handler = take_signal;
383 if (orig_handlers[csig].sa_handler == SIG_ERR)
386 chandler = take_signal;
387 if (orig_handlers[csig] == SIG_ERR)
390 install_handler (csig, thread, handler, async);
393 /* XXX - Silently ignore setting handlers for `program error signals'
394 because they can't currently be handled by Scheme code.
399 /* This list of program error signals is from the GNU Libc
408 #if defined(SIGIOT) && (SIGIOT != SIGABRT)
423 #ifdef HAVE_SIGACTION
426 if (sigaction (csig, 0, &old_action) == -1)
431 if (sigaction (csig, &action , &old_action) == -1)
434 orig_handlers[csig] = old_action;
436 if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
437 old_handler = scm_from_long ((long) old_action.sa_handler);
438 SCM_CRITICAL_SECTION_END;
439 return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
443 if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
445 if (signal (csig, old_chandler) == SIG_ERR)
450 if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
453 orig_handlers[csig] = old_chandler;
455 if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
456 old_handler = scm_from_long ((long) old_chandler);
457 SCM_CRITICAL_SECTION_END;
458 return scm_cons (old_handler, scm_from_int (0));
463 SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
465 "Return all signal handlers to the values they had before any call to\n"
466 "@code{sigaction} was made. The return value is unspecified.")
467 #define FUNC_NAME s_scm_restore_signals
470 for (i = 0; i < NSIG; i++)
472 #ifdef HAVE_SIGACTION
473 if (orig_handlers[i].sa_handler != SIG_ERR)
475 if (sigaction (i, &orig_handlers[i], NULL) == -1)
477 orig_handlers[i].sa_handler = SIG_ERR;
478 SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
481 if (orig_handlers[i] != SIG_ERR)
483 if (signal (i, orig_handlers[i]) == SIG_ERR)
485 orig_handlers[i] = SIG_ERR;
486 SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
490 return SCM_UNSPECIFIED;
494 SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
496 "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
497 "number of seconds (an integer). It's advisable to install a signal\n"
499 "@code{SIGALRM} beforehand, since the default action is to terminate\n"
501 "The return value indicates the time remaining for the previous alarm,\n"
502 "if any. The new value replaces the previous alarm. If there was\n"
503 "no previous alarm, the return value is zero.")
504 #define FUNC_NAME s_scm_alarm
506 return scm_from_uint (alarm (scm_to_uint (i)));
510 #ifdef HAVE_SETITIMER
511 SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
513 SCM interval_seconds, SCM interval_microseconds,
514 SCM value_seconds, SCM value_microseconds),
515 "Set the timer specified by @var{which_timer} according to the given\n"
516 "@var{interval_seconds}, @var{interval_microseconds},\n"
517 "@var{value_seconds}, and @var{value_microseconds} values.\n"
519 "Return information about the timer's previous setting."
521 "Errors are handled as described in the guile info pages under ``POSIX\n"
522 "Interface Conventions''.\n"
524 "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
525 "and @code{ITIMER_PROF}.\n"
527 "The return value will be a list of two cons pairs representing the\n"
528 "current state of the given timer. The first pair is the seconds and\n"
529 "microseconds of the timer @code{it_interval}, and the second pair is\n"
530 "the seconds and microseconds of the timer @code{it_value}.")
531 #define FUNC_NAME s_scm_setitimer
535 struct itimerval new_timer;
536 struct itimerval old_timer;
538 c_which_timer = SCM_NUM2INT(1, which_timer);
539 new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
540 new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
541 new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
542 new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);
544 SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));
549 return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
550 scm_from_long (old_timer.it_interval.tv_usec)),
551 scm_cons (scm_from_long (old_timer.it_value.tv_sec),
552 scm_from_long (old_timer.it_value.tv_usec)));
555 #endif /* HAVE_SETITIMER */
557 #ifdef HAVE_GETITIMER
558 SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
560 "Return information about the timer specified by @var{which_timer}"
562 "Errors are handled as described in the guile info pages under ``POSIX\n"
563 "Interface Conventions''.\n"
565 "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
566 "and @code{ITIMER_PROF}.\n"
568 "The return value will be a list of two cons pairs representing the\n"
569 "current state of the given timer. The first pair is the seconds and\n"
570 "microseconds of the timer @code{it_interval}, and the second pair is\n"
571 "the seconds and microseconds of the timer @code{it_value}.")
572 #define FUNC_NAME s_scm_getitimer
576 struct itimerval old_timer;
578 c_which_timer = SCM_NUM2INT(1, which_timer);
580 SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));
585 return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
586 scm_from_long (old_timer.it_interval.tv_usec)),
587 scm_cons (scm_from_long (old_timer.it_value.tv_sec),
588 scm_from_long (old_timer.it_value.tv_usec)));
591 #endif /* HAVE_GETITIMER */
594 SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
596 "Pause the current process (thread?) until a signal arrives whose\n"
597 "action is to either terminate the current process or invoke a\n"
598 "handler procedure. The return value is unspecified.")
599 #define FUNC_NAME s_scm_pause
602 return SCM_UNSPECIFIED;
607 SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
609 "Wait for the given number of seconds (an integer) or until a signal\n"
610 "arrives. The return value is zero if the time elapses or the number\n"
611 "of seconds remaining otherwise.\n"
613 "See also @code{usleep}.")
614 #define FUNC_NAME s_scm_sleep
616 return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
620 SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
622 "Wait the given period @var{usecs} microseconds (an integer).\n"
623 "If a signal arrives the wait stops and the return value is the\n"
624 "time remaining, in microseconds. If the period elapses with no\n"
625 "signal the return is zero.\n"
627 "On most systems the process scheduler is not microsecond accurate and\n"
628 "the actual period slept by @code{usleep} may be rounded to a system\n"
629 "clock tick boundary. Traditionally such ticks were 10 milliseconds\n"
630 "apart, and that interval is often still used.\n"
632 "See also @code{sleep}.")
633 #define FUNC_NAME s_scm_usleep
635 return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
639 SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
641 "Sends a specified signal @var{sig} to the current process, where\n"
642 "@var{sig} is as described for the kill procedure.")
643 #define FUNC_NAME s_scm_raise
645 if (raise (scm_to_int (sig)) != 0)
647 return SCM_UNSPECIFIED;
659 SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
660 scm_c_make_vector (NSIG, SCM_BOOL_F)));
661 signal_handler_asyncs =
662 scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
663 signal_handler_threads =
664 scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
666 for (i = 0; i < NSIG; i++)
668 #ifdef HAVE_SIGACTION
669 orig_handlers[i].sa_handler = SIG_ERR;
672 orig_handlers[i] = SIG_ERR;
676 scm_c_define ("NSIG", scm_from_long (NSIG));
677 scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
678 scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
680 scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
683 scm_c_define ("SA_RESTART", scm_from_long (SA_RESTART));
686 #if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER)
687 /* Stuff needed by setitimer and getitimer. */
688 scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
689 scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
690 scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
691 #endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */
693 #include "libguile/scmsigs.x"