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