Index: debian/changelog
===================================================================
--- debian/changelog
+++ debian/changelog
@@ -1,5 +1,11 @@
+chicken (4.7.3-0.2sig) unstable; urgency=low
+
+ * Experimental: try to change signal handling.
+
+ -- Joerg F. Wittenberger
Mon, 02 Sep 2011 13:33:00 +0200
+
chicken (4.7.3-0.1) unstable; urgency=low
* New upstream version
-- Joerg F. Wittenberger Mon, 19 Aug 2011 21:21:00 +0200
Index: library.scm
===================================================================
--- library.scm
+++ library.scm
@@ -34,12 +34,15 @@
current-print-length setter-tag read-marks
##sys#print-exit
##sys#format-here-doc-warning)
(not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
- ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#step-hook)
+ ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#async-interrupt-hook ##sys#step-hook)
(foreign-declare #<
#include
#include
#include
#include
@@ -3734,19 +3737,10 @@
ct))
(define get-call-chain ##sys#get-call-chain)
-;;; Interrupt handling:
-
-(define (##sys#user-interrupt-hook)
- (define (break) (##sys#signal-hook #:user-interrupt #f))
- (if (eq? ##sys#current-thread ##sys#primordial-thread)
- (break)
- (##sys#setslot ##sys#primordial-thread 1 break) ) )
-
-
;;; Default handlers
(define ##sys#break-on-error (##sys#fudge 25))
(define-foreign-variable _ex_software int "EX_SOFTWARE")
@@ -4301,19 +4295,51 @@
(let ((ct ##sys#current-thread))
(##sys#setslot ct 1 (lambda () (return (##core#undefined))))
(##sys#schedule) ) ) ) )
-;;; Interrupt-handling:
+;;; Interrupt handling:
+
+(define ##sys#signals-peek (foreign-lambda bool "C_signals_peek"))
+(define ##sys#signals-pending (foreign-lambda int "C_signals_pending"))
+(define ##sys#signal-num-pending (foreign-lambda int "C_signal_n_pending" int))
+
+(define (##sys#handle-signals pending handler)
+ (let retry ((pending pending))
+ (if (fx> pending 0)
+ (let loop ((pending pending) (n 0))
+ (cond
+ ((fx= pending 0) (retry (##sys#signals-pending)))
+ (((foreign-lambda* bool ((int p) (int n)) "return(p & (1 << n));")
+ pending n)
+ (let ((c (##sys#signal-num-pending n)))
+ (if (fx> c 0) (handler n c)))
+ (loop ((foreign-lambda* int ((int p) (int n)) "return(p & ~(1 << n));")
+ pending n)
+ (fx+ n 1)))
+ (else (loop pending (fx+ n 1))))))))
+
+(define (##sys#user-interrupt-hook)
+ (define (break) (##sys#signal-hook #:user-interrupt #f))
+ (if (eq? ##sys#current-thread ##sys#primordial-thread)
+ (break)
+ (##sys#setslot ##sys#primordial-thread 1 break) ) )
(define ##sys#context-switch (##core#primitive "C_context_switch"))
+
+(define (##sys#async-interrupt-hook pending) #f) ; irgnore all
(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) ) ) )
-
+ ;; ((##sys#signals-pending) =>
+ ;; (lambda (pending)
+ ;; (let ((ct ##sys#current-thread))
+ ;; (##sys#setslot ct 1 (let ((cont (##sys#slot ct 1)))
+ ;; (lambda () (##sys#async-interrupt-hook pending) (cont)))) )
+ ;; (##sys#context-switch state)))
+ (else (##sys#context-switch state) ) ) )
;;; Accessing "errno":
(define-foreign-variable ##sys#errno int "errno")
Index: posixunix.scm
===================================================================
--- posixunix.scm
+++ posixunix.scm
@@ -931,18 +931,28 @@
(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) ) ) ) ) )
+ (oldhook reason state) ) ) ) )
+|#
+ (set! ##sys#async-interrupt-hook
+ (lambda (pending)
+ (##sys#handle-signals
+ pending
+ (lambda (signum count)
+ (let ((h (##sys#slot sigvector signum)))
+ (if h (h signum)))))))
+ )
(define set-signal-mask!
(lambda (sigs)
(##sys#check-list sigs 'set-signal-mask!)
(##core#inline "C_sigemptyset" 0)
Index: runtime.c
===================================================================
--- runtime.c
+++ runtime.c
@@ -429,10 +429,12 @@
timer_accumulated_gc_ms,
interrupt_time,
last_interrupt_latency;
static C_TLS LF_LIST *lf_list;
static C_TLS int signal_mapping_table[ NSIG ];
+static C_TLS int signal_pending_table[ NSIG ],
+ signal_pending;
static C_TLS int
locative_table_size,
locative_table_count,
live_finalizer_count,
allocated_finalizer_count,
@@ -699,10 +701,12 @@
last_interrupt_latency = 0;
C_interrupts_enabled = 1;
C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;
memset(signal_mapping_table, 0, sizeof(int) * NSIG);
+ memset(signal_pending_table, 0, sizeof(int) * NSIG);
+ signal_pending = 0;
initialize_symbol_table();
C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";
error_location = C_SCHEME_FALSE;
C_pre_gc_hook = NULL;
C_post_gc_hook = NULL;
@@ -981,14 +985,34 @@
/* This is called from POSIX signals: */
void global_signal_handler(int signum)
{
+ ++(signal_pending_table[ signum ]);
+ signal_pending |= 1 << signum;
C_raise_interrupt(signal_mapping_table[ signum ]);
signal(signum, global_signal_handler);
}
+int C_signals_peek()
+{
+ return signal_pending;
+}
+
+int C_signals_pending()
+{
+ int n = signal_pending;
+ signal_pending = 0;
+ return n;
+}
+
+int C_signal_n_pending(int signum)
+{
+ int n = signal_pending_table[ signum ];
+ signal_pending_table[ signum ] = 0;
+ return n;
+}
/* Align memory to page boundary */
static void *align_to_page(void *mem)
{
@@ -4285,10 +4309,11 @@
int sig = C_unfix(signum);
if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
else {
signal_mapping_table[ sig ] = C_unfix(reason);
+ C_signal_n_pending(sig);
C_signal(sig, global_signal_handler);
}
return C_SCHEME_UNDEFINED;
}
Index: scheduler.scm
===================================================================
--- scheduler.scm
+++ scheduler.scm
@@ -407,10 +407,12 @@
(##sys#update-thread-state-buffer ct)
;; Put current thread on ready-queue:
(when (or (eq? cts 'running) (eq? cts 'ready)) ; should ct really be 'ready? - normally not.
(##sys#setislot ct 13 #f) ; clear timeout-unblock flag
(##sys#add-to-waiting-queue ct) )
+ (let ((signals (##sys#signals-pending)))
+ (if (fx> signals 0) (##sys#async-interrupt-hook signals)))
;; Fetch and activate next ready thread:
(let loop ([nt (##sys#remove-from-ready-queue)])
(cond
[(not nt)
;; For fairness it ought to be better to release the queue