~ chicken-core (chicken-5) b7995839c0b481280bdeda117eb68bc0e78a40bf
commit b7995839c0b481280bdeda117eb68bc0e78a40bf
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Oct 27 12:08:23 2011 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Tue Nov 29 09:10:23 2011 +0100
Overhaul interrupt handling:
- EINTR handling for all read-operations from tcp, file and process streams
- signals are queued (up to a certain limit, with the usual restrictions given
by UNIX)
- added silly test-file
- csi installs SIGINT handler directly (independent of the posix unit)
- added setter for "signal-handler"
- moved some more code into "posix-common"
Squashed commit of the following (merges and fix commits omitted -- ck):
fixed incorrect option when compiling signal-test.scm
EINTR handling for process-I/O and read-line/read-string from FP
disable failing numbers/string-conv test for windows
added background threads to signal-test
- moved low-level signal handling into library
- establish SIGINT handler in csi (posix not needed)
- added internal exn category #:memory-error (unused in the moment - this
was intended for SIGSEGV handling, but ... not sure)
- added setter for "signal-handler"
- added note to manual about order of handling when signal-overrun occurs
- "signal-handler" and setter moved to "posix-common.scm"
- gave label in C_reclaim a more meaningful name
- C_raise_interrupt drops interrupts if pending stack is full
- C_i_pending_interrupts ignores timer interrupts
- EINTR handling for tcp accept/connect
- signal-tests fixes
stack signals that arrive during handling; explicit EINTR handling in stream and tcp ports (Note: what about accept/connect?)
do windows test in test-file, not in runtests.sh; added signal tests
learning about EINTR - how could this ever have worked?
use sigaction(3) instead of signal(3) where available. Patch by Alan Post, problem originally spotted by Joerg Wittenberger
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/Makefile.bsd b/Makefile.bsd
index 5eab203b..98e44fd9 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 f56bc291..cee6e741 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 1f86bc39..54634a25 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 c713b456..6e5116ac 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 b4a44d97..da612a4a 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 f2d4deeb..84dc433c 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 af170154..8169f6d0 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
@@ -1848,6 +1851,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 fa95e2f5..8846dd47 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 ba7001ab..134546d0 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -199,6 +199,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 8075c2fd..9b65ad29 100644
--- a/library.scm
+++ b/library.scm
@@ -76,12 +76,18 @@ fast_read_line_from_file(C_word str, C_word port, C_word size) {
C_FILEPTR fp = C_port_file(port);
if ((c = C_getc(fp)) == EOF)
- return C_SCHEME_END_OF_FILE;
+ return errno == EINTR ? C_fix(-1) : C_SCHEME_END_OF_FILE;
C_ungetc(c, fp);
for (i = 0; i < n; i++) {
c = C_getc(fp);
+
+ if(c == EOF && errno == EINTR) {
+ clearerr(fp);
+ return C_fix(-(i + 1));
+ }
+
switch (c) {
case '\r': if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);
case EOF: clearerr(fp);
@@ -101,7 +107,11 @@ fast_read_string_from_file(C_word dest, C_word port, C_word len, C_word pos)
size_t m = fread (buf, sizeof (char), n, fp);
- if (m < n) {
+ if(m == EOF && errno == EINTR) {
+ clearerr(fp);
+ return C_fix(-1);
+ }
+ else if (m < n) {
if (feof (fp)) {
clearerr (fp);
if (0 == m)
@@ -1736,9 +1746,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
@@ -1756,6 +1774,11 @@ EOF
(cond [(or (not len) ; error returns EOF
(eof-object? len)) ; EOF returns 0 bytes read
act]
+ ((fx< len 0) ; EINTR
+ (let ((len (fx< (fxneg len) 1)))
+ (##sys#dispatch-interrupt
+ (lambda ()
+ (loop (fx- rem len) (fx+ act len) (fx+ start len))))))
[(fx< len rem)
(loop (fx- rem len) (fx+ act len) (fx+ start len))]
[else
@@ -1781,6 +1804,11 @@ EOF
(##sys#make-string (fx* len 2))
(##sys#string-append result buffer)
#t)) ]
+ ((fx< n 0) ; EINTR
+ (let ((n (fx- (fxneg n) 1)))
+ (##sys#dispatch-interrupt
+ (lambda ()
+ (loop len limit buffer result f)))))
[f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
(##sys#string-append result (##sys#substring buffer 0 n))]
[else
@@ -3909,6 +3937,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 +4373,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 +4610,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 0f6d0a2d..a81b834e 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 89e87d34..20b5a7ae 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -488,6 +488,21 @@ EOF
(##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!))
+
+
;;; Processes
(define current-process-id (foreign-lambda int "C_getpid"))
@@ -501,4 +516,3 @@ EOF
(if (fx= epid -1)
(posix-error #:process-error 'process-wait "waiting for child process failed" pid)
(values epid enorm ecode) ) ) ) ) ) )
-
diff --git a/posixunix.scm b/posixunix.scm
index ec3df0f7..f1af0926 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:
@@ -1338,13 +1312,15 @@ EOF
(when (fx>= bufpos buflen)
(let loop ()
(let ([cnt (##core#inline "C_read" fd buf bufsiz)])
- (cond [(fx= cnt -1)
- (if (fx= _errno _ewouldblock)
- (begin
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
- (##sys#thread-yield!)
- (loop) )
- (posix-error #:file-error loc "cannot read" fd nam) )]
+ (cond ((fx= cnt -1)
+ (select errno
+ ((_ewouldblock)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+ (##sys#thread-yield!)
+ (loop) )
+ ((_eintr)
+ (##sys#dispatch-interrupt loop))
+ (else (posix-error #:file-error loc "cannot read" fd nam) )))
[(and more? (fx= cnt 0))
; When "more" keep trying, otherwise read once more
; to guard against race conditions
@@ -1445,18 +1421,21 @@ EOF
(define ##sys#custom-output-port
(lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))
(when nonblocking? (##sys#file-nonblocking! fd) )
- (letrec (
- [poke
+ (letrec ([poke
(lambda (str len)
- (let ([cnt (##core#inline "C_write" fd str len)])
- (cond [(fx= -1 cnt)
- (if (fx= _errno _ewouldblock)
- (begin
- (##sys#thread-yield!)
- (poke str len) )
- (posix-error loc #:file-error "cannot write" fd nam) ) ]
- [(fx< cnt len)
- (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
+ (let loop ()
+ (let ([cnt (##core#inline "C_write" fd str len)])
+ (cond ((fx= -1 cnt)
+ (select _errno
+ ((_ewouldblock)
+ (##sys#thread-yield!)
+ (poke str len) )
+ ((_eintr)
+ (##sys#dispatch-interrupt loop))
+ (else
+ (posix-error loc #:file-error "cannot write" fd nam) ) ) )
+ ((fx< cnt len)
+ (poke (##sys#substring str cnt len) (fx- len cnt)) ) ) ) ))]
[store
(let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
(if (fx= 0 bufsiz)
@@ -1480,8 +1459,7 @@ EOF
(set! bufpos (fx+ bufpos len))] ) )
(when (fx< 0 bufpos)
(poke buf bufpos) ) ) ) ) ) )])
- (letrec (
- [this-port
+ (letrec ([this-port
(make-output-port
(lambda (str) ; write-string
(store str) )
diff --git a/posixwin.scm b/posixwin.scm
index 2dd5a30b..bc61b7e7 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1262,25 +1262,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 09b1393b..d0e14258 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>
@@ -164,6 +165,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
@@ -446,6 +449,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: */
@@ -695,6 +701,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;
@@ -718,7 +725,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;
@@ -750,6 +757,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);
@@ -784,7 +792,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;
}
@@ -982,7 +990,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
}
@@ -2650,7 +2660,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);
@@ -2836,7 +2846,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) {
@@ -3944,7 +3954,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);
}
@@ -3953,8 +3968,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);
}
@@ -4202,16 +4222,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();
+ }
}
}
@@ -4235,11 +4264,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;
@@ -9173,3 +9214,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 4dfe579d..4731c01f 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/runtests.sh b/tests/runtests.sh
index 9c3f7cf1..d54c9bca 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 00000000..6f004401
--- /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))
Trap