[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] interrupts overhaul
|
From: |
Alan Post |
|
Subject: |
Re: [Chicken-hackers] interrupts overhaul |
|
Date: |
Thu, 13 Oct 2011 12:15:00 -0600 |
I've just tested this with a program that does fork/exec+signal
handling, and it worked without my having to change my code.
I have more testing I want to do, and I'l submit some minor
tweaks to the patch below. Please excuse a bit of a delay,
this is a relatively complicated patch to test.
So far, it is essentially working.
-Alan
On Thu, Oct 13, 2011 at 07:35:05AM -0400, Felix wrote:
> 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 mailing list
> address@hidden
> https://lists.nongnu.org/mailman/listinfo/chicken-hackers
--
.i ma'a lo bradi cu penmi gi'e du