[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] interrupts overhaul
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] interrupts overhaul |
|
Date: |
Thu, 13 Oct 2011 07:35:05 -0400 (EDT) |
Hello!
Attached is a patch for overhauling the signal- and interrupt-
handling. This is just for an initial review, not a proper commit. It
is based on suggestions by Joerg and Alan, with some additional stuff
by me. Please have a look - I'm not completely sure my assumptions are
correct and I may have overlooked some things.
1) The global signal handler is set up using sigaction(3), where
available (all but mingw).
2) SIGINT handling has been moved to csi, to make it work without
loading the "posix" unit.
3) The primitives for reading and peeking from a port check for EINTR
now and invoke "##sys#dispatch-interrupt", which invokes signal
handlers for all pending signals. Also the interrupt hook processes
signals until all are dispatched. The interrupt hook has been
changed to accept a continuation procedure instead of a thread
context.
4) Signals are queued (stacked, really) in a global buffer. According
to Stevens, multiple occurrences of a signal in fast succession may
result in lost signals, since sigaction(3) is not required to queue
incoming signals during the execution of a signal handler that
blocks. Timer-interrupts may be dropped during the processing of
interrupts caused by signals, but I assume this is acceptable.
5) TCP connect/accept and recv/send operations check and handle
EINTR.
6) A silly test program has been added. I was not able to detect any
improvement in the number of caught signals with the changes in
this patch, as compared to the current state, but it should be more
reliable in any case (testing is a bit difficult - if someone can
come up with good testcases, please consider posting).
Things to improve:
- "fast_read_line_from_file" (library.scm) probably has to do EINTR
handling - I guess it has.
- Do we have to block all currently handled signals when setting up
the signal handler for a certain signal? It probably should.
cheers,
felix
diff --git a/Makefile.bsd b/Makefile.bsd
index 5eab203..98e44fd 100644
--- a/Makefile.bsd
+++ b/Makefile.bsd
@@ -83,6 +83,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/Makefile.cygwin b/Makefile.cygwin
index f56bc29..cee6e74 100644
--- a/Makefile.cygwin
+++ b/Makefile.cygwin
@@ -95,6 +95,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/Makefile.haiku b/Makefile.haiku
index 1f86bc3..54634a2 100644
--- a/Makefile.haiku
+++ b/Makefile.haiku
@@ -71,6 +71,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/Makefile.linux b/Makefile.linux
index c713b45..6e5116a 100644
--- a/Makefile.linux
+++ b/Makefile.linux
@@ -72,6 +72,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/Makefile.macosx b/Makefile.macosx
index b4a44d9..da612a4 100644
--- a/Makefile.macosx
+++ b/Makefile.macosx
@@ -96,6 +96,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/Makefile.solaris b/Makefile.solaris
index f2d4dee..84dc433 100644
--- a/Makefile.solaris
+++ b/Makefile.solaris
@@ -102,6 +102,7 @@ chicken-config.h: chicken-defaults.h
echo "#define HAVE_LONG_LONG 1" >>$@
echo "#define HAVE_MEMMOVE 1" >>$@
echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_SIGACTION 1" >>$@
echo "#define HAVE_STDINT_H 1" >>$@
echo "#define HAVE_STDLIB_H 1" >>$@
echo "#define HAVE_STRERROR 1" >>$@
diff --git a/chicken.h b/chicken.h
index 5524bc4..0be8fd4 100644
--- a/chicken.h
+++ b/chicken.h
@@ -863,6 +863,9 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_isatty isatty
# define C_fileno fileno
# define C_select select
+# if defined(HAVE_SIGACTION)
+# define C_sigaction sigaction
+# endif
# define C_signal signal
# define C_getrusage getrusage
# define C_tolower tolower
@@ -1852,6 +1855,7 @@ C_fctexport void C_ccall
C_peek_unsigned_integer_32(C_word c, C_word closure, C_
#endif
C_fctexport C_word C_fcall C_decode_literal(C_word **ptr, C_char *str)
C_regparm;
+C_fctexport C_word C_fcall C_i_pending_interrupt(C_word dummy) C_regparm;
/* defined in eval.scm: */
C_fctexport void CHICKEN_get_error_message(char *buf,int bufsize);
diff --git a/csi.scm b/csi.scm
index fa95e2f..8846dd4 100644
--- a/csi.scm
+++ b/csi.scm
@@ -31,6 +31,8 @@
(disable-interrupts)
(compile-syntax)
(foreign-declare #<<EOF
+#include <signal.h>
+
#if defined(HAVE_DIRECT_H)
# include <direct.h>
#else
@@ -906,6 +908,20 @@ EOF
(##sys#void))))))
+;;; Handle some signals:
+
+(define-foreign-variable _sigint int "SIGINT")
+
+(define-syntax defhandler
+ (syntax-rules ()
+ ((_ sig handler)
+ (begin
+ (##core#inline "C_establish_signal_handler" sig sig)
+ (##sys#setslot ##sys#signal-vector sig handler)))))
+
+(defhandler _sigint (lambda (n) (##sys#user-interrupt-hook)))
+
+
;;; Start interpreting:
(define (member* keys set)
diff --git a/distribution/manifest b/distribution/manifest
index 2c3a43a..dd39f86 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -198,6 +198,7 @@ tests/reverser/tags/1.1/reverser.meta
tests/reverser/tags/1.1/reverser.setup
tests/reverser/tags/1.1/reverser.scm
tests/rev-app.scm
+tests/signal-tests.scm
tweaks.scm
utils.scm
apply-hack.x86.S
diff --git a/library.scm b/library.scm
index 8075c2f..700d0b7 100644
--- a/library.scm
+++ b/library.scm
@@ -1736,9 +1736,17 @@ EOF
(define ##sys#stream-port-class
(vector (lambda (p) ; read-char
- (##core#inline "C_read_char" p) )
+ (let loop ()
+ (let ((c (##core#inline "C_read_char" p)))
+ (if (eq? -1 c) ; EINTR
+ (##sys#dispatch-interrupt loop)
+ c))))
(lambda (p) ; peek-char
- (##core#inline "C_peek_char" p) )
+ (let loop ()
+ (let ((c (##core#inline "C_peek_char" p)))
+ (if (eq? -1 c) ; EINTR
+ (##sys#dispatch-interrupt loop)
+ c))))
(lambda (p c) ; write-char
(##core#inline "C_display_char" p c) )
(lambda (p s) ; write-string
@@ -3909,6 +3917,7 @@ EOF
[(#:arity-error) '(exn arity)]
[(#:access-error) '(exn access)]
[(#:domain-error) '(exn domain)]
+ ((#:memory-error) '(exn memory))
[else '(exn)] )
(list '(exn . message) msg
'(exn . arguments) args
@@ -4344,10 +4353,23 @@ EOF
(define ##sys#context-switch (##core#primitive "C_context_switch"))
+(define ##sys#signal-vector (make-vector 256 #f))
+
(define (##sys#interrupt-hook reason state)
- (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)
- (##sys#run-pending-finalizers state) )
- (else (##sys#context-switch state) ) ) )
+ (let loop ((reason reason))
+ (cond ((and reason (##sys#slot ##sys#signal-vector reason)) =>
+ (lambda (handler)
+ (handler reason)
+ (loop (##core#inline "C_i_pending_interrupt" #f))))
+ ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)
+ (##sys#run-pending-finalizers state) )
+ ((procedure? state) (state))
+ (else (##sys#context-switch state) ) ) ) )
+
+(define (##sys#dispatch-interrupt k)
+ (##sys#interrupt-hook
+ (##core#inline "C_i_pending_interrupt" #f)
+ k))
;;; Accessing "errno":
@@ -4568,19 +4590,20 @@ EOF
(vector-fill! ##sys#pending-finalizers (##core#undefined))
(##sys#setislot ##sys#pending-finalizers 0 0)
(set! working #f) ) )
- (when state (##sys#context-switch state) ) ) ) )
+ (cond ((not state))
+ ((procedure? state) (state))
+ (state (##sys#context-switch state) ) ) ) ))
(define (##sys#force-finalizers)
(let loop ()
(let ([n (##sys#gc)])
- (if (fx> (##sys#slot ##sys#pending-finalizers 0) 0)
- (begin
- (##sys#run-pending-finalizers #f)
- (loop) )
- n) ) ) )
+ (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)
+ (##sys#run-pending-finalizers #f)
+ (loop) )
+ (else n) ) ) ))
(define (gc . arg)
- (let ([a (and (pair? arg) (car arg))])
+ (let ((a (and (pair? arg) (car arg))))
(if a
(##sys#force-finalizers)
(apply ##sys#gc arg) ) ) )
diff --git a/manual/Unit posix b/manual/Unit posix
index 0f6d0a2..a81b834 100644
--- a/manual/Unit posix
+++ b/manual/Unit posix
@@ -848,6 +848,12 @@ after {{SECONDS}} are elapsed. You can use the
==== set-signal-handler!
+==== signal-handler
+
+<procedure>(signal-handler SIGNUM)</procedure>
+
+Returns the signal handler for the code {{SIGNUM}} or {{#f}}.
+
<procedure>(set-signal-handler! SIGNUM PROC)</procedure>
Establishes the procedure of one argument {{PROC}} as the handler
@@ -855,13 +861,13 @@ for the signal with the code {{SIGNUM}}. {{PROC}} is
called
with the signal number as its sole argument. If the argument {{PROC}} is {{#f}}
then any signal handler will be removed, and the corresponding signal set to
{{SIG_IGN}}.
-Note that is is unspecified in which thread of execution the signal handler
will be invoked.
+Notes
-==== signal-handler
+* it is unspecified in which thread of execution the signal handler will be
invoked.
-<procedure>(signal-handler SIGNUM)</procedure>
+* when signals arrive in quick succession (specifically, before the handler
for a signal has been started), then signals will be queued (up to a certain
limit); the order in which the queued signals will be handled is not specified
-Returns the signal handler for the code {{SIGNUM}} or {{#f}}.
+* {{(set! (signal-handler SIG) PROC)}} can be used as an alternative to
{{(set-signal-handler! SIG PROC)}}
==== set-signal-mask!
diff --git a/posix-common.scm b/posix-common.scm
index 8c95354..9c4088f 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -487,3 +487,17 @@ EOF
(##sys#substring str 0 (fx- (##sys#size str) 1))
(##sys#error 'time->string "cannot convert time vector to
string" tm) ) ) ) ) ) )
+
+;;; Signals
+
+(define (set-signal-handler! sig proc)
+ (##sys#check-exact sig 'set-signal-handler!)
+ (##core#inline "C_establish_signal_handler" sig (and proc sig))
+ (vector-set! ##sys#signal-vector sig proc) )
+
+(define signal-handler
+ (getter-with-setter
+ (lambda (sig)
+ (##sys#check-exact sig 'signal-handler)
+ (##sys#slot ##sys#signal-vector sig) )
+ set-signal-handler!))
diff --git a/posixunix.scm b/posixunix.scm
index ee17325..c64e250 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -950,26 +950,6 @@ EOF
signal/tstp signal/pipe signal/xcpu signal/xfsz signal/usr1 signal/usr2
signal/winch))
-(let ([oldhook ##sys#interrupt-hook]
- [sigvector (make-vector 256 #f)] )
- (set! signal-handler
- (lambda (sig)
- (##sys#check-exact sig 'signal-handler)
- (##sys#slot sigvector sig) ) )
- (set! set-signal-handler!
- (lambda (sig proc)
- (##sys#check-exact sig 'set-signal-handler!)
- (##core#inline "C_establish_signal_handler" sig (and proc sig))
- (vector-set! sigvector sig proc) ) )
- (set! ##sys#interrupt-hook
- (lambda (reason state)
- (let ([h (##sys#slot sigvector reason)])
- (if h
- (begin
- (h reason)
- (##sys#context-switch state) )
- (oldhook reason state) ) ) ) ) )
-
(define set-signal-mask!
(lambda (sigs)
(##sys#check-list sigs 'set-signal-mask!)
@@ -1005,12 +985,6 @@ EOF
(when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
(posix-error #:process-error 'signal-unmask! "cannot unblock signal") )
)
-;;; Set SIGINT handler:
-
-(set-signal-handler!
- signal/int
- (lambda (n) (##sys#user-interrupt-hook)) )
-
;;; Getting system-, group- and user-information:
diff --git a/posixwin.scm b/posixwin.scm
index 64c544e..5409600 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1263,25 +1263,6 @@ EOF
signal/term signal/int signal/fpe signal/ill
signal/segv signal/abrt signal/break))
-(let ([oldhook ##sys#interrupt-hook]
- [sigvector (make-vector 256 #f)] )
- (set! signal-handler
- (lambda (sig)
- (##sys#check-exact sig 'signal-handler)
- (##sys#slot sigvector sig) ) )
- (set! set-signal-handler!
- (lambda (sig proc)
- (##sys#check-exact sig 'set-signal-handler!)
- (##core#inline "C_establish_signal_handler" sig (and proc sig))
- (vector-set! sigvector sig proc) ) )
- (set! ##sys#interrupt-hook
- (lambda (reason state)
- (let ([h (##sys#slot sigvector reason)])
- (if h
- (begin
- (h reason)
- (##sys#context-switch state) )
- (oldhook reason state) ) ) ) ) )
;;; More errno codes:
diff --git a/runtime.c b/runtime.c
index 5e2f161..edb7e97 100644
--- a/runtime.c
+++ b/runtime.c
@@ -32,6 +32,7 @@
#include <assert.h>
#include <limits.h>
#include <math.h>
+#include <signal.h>
#ifdef HAVE_SYSEXITS_H
# include <sysexits.h>
@@ -156,6 +157,8 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int
count) C_noret;
#define FILE_INFO_SIZE 7
+#define MAX_PENDING_INTERRUPTS 100
+
#ifdef C_DOUBLE_IS_32_BITS
# define FLONUM_PRINT_PRECISION 7
#else
@@ -447,6 +450,9 @@ static C_TLS FINALIZER_NODE
static C_TLS void *current_module_handle;
static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;
static C_TLS HDUMP_BUCKET **hdump_table;
+static C_TLS int
+ pending_interrupts[ MAX_PENDING_INTERRUPTS ],
+ pending_interrupts_count;
/* Prototypes: */
@@ -696,6 +702,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols,
void *toplevel)
C_clear_trace_buffer();
chicken_is_running = chicken_ran_once = 0;
interrupt_reason = 0;
+ pending_interrupts_count = 0;
last_interrupt_latency = 0;
C_interrupts_enabled = 1;
C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
@@ -719,7 +726,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols,
void *toplevel)
static C_PTABLE_ENTRY *create_initial_ptable()
{
- /* hardcoded table size - this must match the number of C_pte calls! */
+ /* IMPORTANT: hardcoded table size - this must match the number of C_pte
calls! */
C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 60);
int i = 0;
@@ -751,6 +758,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_divide);
C_pte(C_nequalp);
C_pte(C_greaterp);
+ /* IMPORTANT: have you read the comments at the start and the end of this
function? */
C_pte(C_lessp);
C_pte(C_greater_or_equal_p);
C_pte(C_less_or_equal_p);
@@ -785,7 +793,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_filter_heap_objects);
C_pte(C_get_argument);
- /* did you remember the hardcoded pte table size? */
+ /* IMPORTANT: did you remember the hardcoded pte table size? */
pt[ i ].id = NULL;
return pt;
}
@@ -983,7 +991,9 @@ void initialize_symbol_table(void)
void global_signal_handler(int signum)
{
C_raise_interrupt(signal_mapping_table[ signum ]);
- signal(signum, global_signal_handler);
+#ifndef HAVE_SIGACTION
+ C_signal(signum, global_signal_handler);
+#endif
}
@@ -2712,7 +2722,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void
*proc)
if(gc_mode == GC_REALLOC) {
C_rereclaim2(percentage(heap_size, C_heap_growth), 0);
gc_mode = GC_MAJOR;
- goto never_mind_edsgar;
+ goto i_like_spaghetti;
}
heap_scan_top = (C_byte *)C_align((C_uword)tospace_top);
@@ -2898,7 +2908,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void
*proc)
tospace_limit = tmp;
}
- never_mind_edsgar:
+ i_like_spaghetti:
++gc_count_2;
if(C_enable_gcweak) {
@@ -4006,7 +4016,12 @@ C_regparm C_word C_fcall C_read_char(C_word port)
{
int c = C_getc(C_port_file(port));
- return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
+ if(c == EOF) {
+ if(errno == EINTR) return C_fix(-1);
+ else return C_SCHEME_END_OF_FILE;
+ }
+
+ return C_make_character(c);
}
@@ -4015,8 +4030,13 @@ C_regparm C_word C_fcall C_peek_char(C_word port)
C_FILEPTR fp = C_port_file(port);
int c = C_getc(fp);
+ if(c == EOF) {
+ if(errno == EINTR) return C_fix(-1);
+ else return C_SCHEME_END_OF_FILE;
+ }
+
C_ungetc(c, fp);
- return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
+ return C_make_character(c);
}
@@ -4264,16 +4284,25 @@ C_regparm void C_fcall
C_paranoid_check_for_interrupt(void)
C_regparm void C_fcall C_raise_interrupt(int reason)
{
if(C_interrupts_enabled) {
- saved_stack_limit = C_stack_limit;
+ if(interrupt_reason) {
+ if(reason != C_TIMER_INTERRUPT_NUMBER) {
+ if(pending_interrupts_count < MAX_PENDING_INTERRUPTS)
+ /* drop signals if too many */
+ pending_interrupts[ pending_interrupts_count++ ] = reason;
+ }
+ }
+ else {
+ saved_stack_limit = C_stack_limit;
#if C_STACK_GROWS_DOWNWARD
- C_stack_limit = C_stack_pointer + 1000;
+ C_stack_limit = C_stack_pointer + 1000;
#else
- C_stack_limit = C_stack_pointer - 1000;
+ C_stack_limit = C_stack_pointer - 1000;
#endif
- interrupt_reason = reason;
- interrupt_time = C_cpu_milliseconds();
+ interrupt_reason = reason;
+ interrupt_time = C_cpu_milliseconds();
+ }
}
}
@@ -4297,11 +4326,23 @@ C_regparm C_word C_fcall C_disable_interrupts(void)
C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word
reason)
{
int sig = C_unfix(signum);
+#if defined(HAVE_SIGACTION)
+ struct sigaction new;
+
+ new.sa_flags = 0;
+ sigemptyset(&new.sa_mask);
+#endif
if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
else {
signal_mapping_table[ sig ] = C_unfix(reason);
+#if defined(HAVE_SIGACTION)
+ sigaddset(&new.sa_mask, sig);
+ new.sa_handler = global_signal_handler;
+ C_sigaction(sig, &new, NULL);
+#else
C_signal(sig, global_signal_handler);
+#endif
}
return C_SCHEME_UNDEFINED;
@@ -9261,3 +9302,19 @@ C_i_file_exists_p(C_word name, C_word file, C_word dir)
}
+C_regparm C_word C_fcall
+C_i_pending_interrupt(C_word dummy)
+{
+ int i;
+
+ if(interrupt_reason && interrupt_reason != C_TIMER_INTERRUPT_NUMBER) {
+ i = interrupt_reason;
+ interrupt_reason = 0;
+ return C_fix(i);
+ }
+
+ if(pending_interrupts_count > 0)
+ return C_fix(pending_interrupts[ --pending_interrupts_count ]);
+
+ return C_SCHEME_FALSE;
+}
diff --git a/tcp.scm b/tcp.scm
index 4dfe579..4731c01 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -99,6 +99,7 @@ EOF
(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
+(define-foreign-variable _eintr int "EINTR")
(define-foreign-variable _einprogress int "EINPROGRESS")
(define ##net#socket (foreign-lambda int "socket" int int int))
@@ -359,6 +360,8 @@ EOF
#:network-timeout-error
"read operation timed out" tmr fd) )
(loop) )
+ ((eq? errno _eintr)
+ (##sys#dispatch-interrupt loop))
(else
(##sys#update-errno)
(##sys#signal-hook
@@ -474,6 +477,9 @@ EOF
#:network-timeout-error
"write operation timed out" tmw fd) )
(loop len offset) )
+ ((eq? errno _eintr)
+ (##sys#dispatch-interrupt
+ (cut loop len offset)))
(else
(##sys#update-errno)
(##sys#signal-hook
@@ -524,12 +530,16 @@ EOF
(let loop ()
(if (eq? 1 (##net#select fd))
(let ((fd (##net#accept fd #f #f)))
- (when (eq? -1 fd)
- (##sys#update-errno)
- (##sys#signal-hook
- #:network-error 'tcp-accept (##sys#string-append "could not
accept from listener - " strerror)
- tcpl) )
- (##net#io-ports fd) )
+ (cond ((not (eq? -1 fd)) (##net#io-ports fd))
+ ((eq? errno _eintr)
+ (##sys#dispatch-interrupt loop))
+ (else
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error
+ 'tcp-accept
+ (##sys#string-append "could not accept from listener - "
strerror)
+ tcpl))))
(begin
(when tma
(##sys#thread-block-for-timeout!
@@ -559,7 +569,7 @@ EOF
"int err, optlen;"
"optlen = sizeof(err);"
"if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t
*)&optlen) == -1)"
- "C_return(-1);"
+ " C_return(-1);"
"C_return(err);"))
(define general-strerror (foreign-lambda c-string "strerror" int))
@@ -590,25 +600,28 @@ EOF
(unless (##net#make-nonblocking s)
(##sys#update-errno)
(##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append
"fcntl() failed - " strerror)) )
- (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
- (if (eq? errno _einprogress)
- (let loop ()
- (let ((f (##net#select-write s)))
- (when (eq? f -1) (fail))
- (unless (eq? f 1)
- (when tmc
- (##sys#thread-block-for-timeout!
- ##sys#current-thread
- (+ (current-milliseconds) tmc) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
- (yield)
- (when (##sys#slot ##sys#current-thread 13)
- (##sys#signal-hook
- #:network-timeout-error
- 'tcp-connect
- "connect operation timed out" tmc s) )
- (loop) ) ) )
- (fail) ) )
+ (let loop ()
+ (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
+ (cond ((eq? errno _einprogress)
+ (let loop2 ()
+ (let ((f (##net#select-write s)))
+ (when (eq? f -1) (fail))
+ (unless (eq? f 1)
+ (when tmc
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread
+ (+ (current-milliseconds) tmc) ) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread s
#:all)
+ (yield)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-timeout-error
+ 'tcp-connect
+ "connect operation timed out" tmc s) )
+ (loop2) ) ) ))
+ ((eq? errno _eintr)
+ (##sys#dispatch-interrupt loop))
+ (else (fail) ) )))
(let ((err (get-socket-error s)))
(cond ((fx= err -1)
(##net#close s)
diff --git a/tests/arithmetic-test.scm b/tests/arithmetic-test.scm
index 9334b33..f131915 100644
--- a/tests/arithmetic-test.scm
+++ b/tests/arithmetic-test.scm
@@ -7,6 +7,13 @@
; fx-ops
+;; the windows runtime library prints flonums differently
+#+windows
+(begin
+ (print "this test can not be run on Windows")
+ (exit))
+
+
(use extras)
#+use-numbers (use numbers)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 9c3f7cf..d54c9bc 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -153,10 +153,7 @@ $compile lolevel-tests.scm
./a.out
echo "======================================== arithmetic tests ..."
-if test -z "$MSYSTEM"; then
- # the windows runtime library prints flonums differently
- $interpret -D check -s arithmetic-test.scm
-fi
+$interpret -D check -s arithmetic-test.scm
echo "======================================== pretty-printer tests ..."
$interpret -s pp-test.scm
@@ -316,6 +313,10 @@ fi
$interpret -R posix -e '(delete-directory "tmpdir" #t)'
+echo "======================================== signal tests ..."
+$compile signal-tests.scm
+./a.out
+
echo "======================================== lolevel tests ..."
$interpret -s lolevel-tests.scm
$compile lolevel-tests.scm
diff --git a/tests/signal-tests.scm b/tests/signal-tests.scm
new file mode 100644
index 0000000..6f00440
--- /dev/null
+++ b/tests/signal-tests.scm
@@ -0,0 +1,85 @@
+;;;; signal-tests.scm
+
+
+#+windows
+(begin
+ (print "this test can not be run on Windows")
+ (exit))
+
+
+;;XXX not tested yet
+
+
+(use posix srfi-18 extras tcp)
+
+
+(define received1 0)
+(define received2 0)
+
+(define (tick c)
+ (write-char c)
+ (flush-output))
+
+(define (handler sig)
+ (select sig
+ ((signal/usr1)
+ (tick #\1)
+ (set! received1 (add1 received1)))
+ ((signal/usr2)
+ (tick #\2)
+ (set! received2 (add1 received2)))))
+
+(define (fini _)
+ (printf "~%child terminating, received: ~a USR1, ~a USR2~%"
+ received1 received2)
+ (exit))
+
+(define (child)
+ (print "child started")
+ (thread-start!
+ (lambda ()
+ (let-values (((i o) (tcp-accept (tcp-listen 9999))))
+ (tick #\!)
+ (assert (string=? "ok." (read-line i)))
+ (print "client connected.")
+ (close-input-port i)
+ (close-output-port o))))
+ (thread-start!
+ (lambda ()
+ (do () (#f)
+ (thread-sleep! 0.5)
+ (tick #\_))))
+ (set-signal-handler! signal/usr1 handler)
+ (set-signal-handler! signal/usr2 handler)
+ (set-signal-handler! signal/term fini)
+ (do () (#f)
+ (thread-sleep! 1)
+ (tick #\.)))
+
+(let ((pid (process-fork child))
+ (sent1 0)
+ (sent2 0))
+ (sleep 1)
+ (print "sending signals to " pid)
+ (do ((i 1000 (sub1 i)))
+ ((zero? i))
+ (thread-sleep! (/ (random 10) 1000))
+ (do ((j (random 4) (sub1 j)))
+ ((zero? j))
+ (case (random 2)
+ ((0)
+ (tick #\A)
+ (set! sent1 (add1 sent1))
+ (process-signal pid signal/usr1))
+ ((1)
+ (tick #\B)
+ (set! sent2 (add1 sent2))
+ (process-signal pid signal/usr2)))))
+ (printf "~%signals sent: ~a USR1, ~a USR2~%" sent1 sent2)
+ (print "connecting ...")
+ (let-values (((i o) (tcp-connect "localhost" 9999)))
+ (display "ok.\n" o)
+ (close-input-port i)
+ (close-output-port o)
+ (sleep 1))
+ (process-signal pid))
- [Chicken-hackers] interrupts overhaul,
Felix <=