Re: [Chicken-users] replace signal with sigaction

[Jörg F . Wittenberger]

Hi Alan,

sorry for the delay.

On Sep 30 2011, Alan Post wrote:

> I have ammended this patch to include a HAVE_SIGACTION define,
> to preserve the existing functionality on w32 systems.

So far I did not yet include this update.  The attached patch
is against what I just found in git.  This git-update I did not
test yet.  But I don't want you to wait even longer.

The attached diff has been created by the following simple script.
(Which has brought up the manifest-question in the other thread.)

You might simply want to give it a try.  But be warned: it will
bring in all from (a) to (d) as described before.  However it
might be worth at least for reference in case I mess it too much
up with my comments below.

Best Regards
/Jörg


The diff script:

#!/bin/sh

LOCAL=chicken-askemos
ORIG=chicken-core

LINE=""

difffile () {
diff -uN $ORIG/$1 $LOCAL/$1
}

dodiff () {
read LINE
while [ "$LINE" != "" ]
do
 case $LINE in
  runtime.c) difffile $LINE;;
  *.c) : ;;
  *.h) difffile $LINE;;
  *.import.scm) ;;
  *.scm) difffile $LINE;;
 esac
 read LINE
done
}

dodiff < $LOCAL/distribution/manifest

Now let's desect the the diff.

--- chicken-core/llrbtree.scm   1970-01-01 01:00:00.000000000 +0100
+++ chicken-askemos/llrbtree.scm        2011-09-27 16:53:16.000000000 +0200
+;; #!/usr/bin/csi
+;; (C) 2008, 2010 Jörg F. Wittenberger.

This file would be new.  It's a syntactic implementation of llrb trees.

Expands into either a pure or an allocation free implementation.
(With slightly different APIs.)  Used in the modified scheduler.

See below for runtime.c for the "extern" declarations.  Those would have to
go to chicken.h

--- chicken-core/library.scm    2011-09-30 16:41:10.000000000 +0200
+++ chicken-askemos/library.scm 2011-09-29 20:16:42.000000000 +0200
@@ -36,8 +36,10 @@
        ##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 #<<EOF
+extern int C_signals_pending();
+extern int C_signal_n_pending(int signum);
#include <string.h>
#include <ctype.h>
#include <errno.h>
@@ -3747,15 +3749,6 @@
(define get-call-chain ##sys#get-call-chain)

Those "extern" declarations should actually go into chicken.h eventually.

Don't miss the relocation the first "Interrupt handling" in the patch
here.  It can be confusing to find the same heading twice in the
source and no good reason.

@@ -4316,14 +4309,45 @@

;;; Interrupt-handling:

+(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))))))))

This would be the low level dispatch from recorded signals to the handler. 
This handler is not yet compatible with the normal signal handler. The 
"handler" receives the signal number "n" and the count "c" of times the 
signal has been seen since the last dispatch.

Please excuse the lazy style of the implementation. It just ought to run at 
least.

+(define (##sys#async-interrupt-hook pending) #f) ; irgnore all

This hook might by a missnomer. It's going to be called whenever the C 
program has received a signal. (Whereby implicitely signals created from 
the chicken core itself would be synchroneous signals.)

We have the hook, but at this time there is no good implementation for 
single threaded stuff. To come sooner or later.


Next we must "un-hook" the posix-unit.  Otherwise the signal handler is run
without memory...

What we hook in here is API compatible with the state of affairs.
But: it deliberately drops the "count" value and calls the handler
just once.  Call it count times for reliable delivery!

--- chicken-core/posixunix.scm  2011-09-24 20:19:00.000000000 +0200
+++ chicken-askemos/posixunix.scm       2011-09-27 16:53:16.000000000 +0200
@@ -934,6 +934,7 @@
      (##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)])
@@ -941,7 +942,16 @@
            (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)




Runtime.c is going to be your big trouble.  Avoid the timers to become
long instead of double.  I try to edit the diff.  Comments below.

--- chicken-core/runtime.c      2011-09-24 20:19:00.000000000 +0200
+++ chicken-askemos/runtime.c   2011-09-29 17:04:27.000000000 +0200
@@ -431,6 +431,8 @@
  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,
@@ -701,6 +703,8 @@
  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;
@@ -983,10 +987,26 @@

void global_signal_handler(int signum)
{
-  C_raise_interrupt(signal_mapping_table[ signum ]);
+  int seen = signal_pending;
+  ++(signal_pending_table[ signum ]);
+  signal_pending |= 1 << signum;
+  if(!seen) C_raise_interrupt(signal_mapping_table[ signum ]);
  signal(signum, global_signal_handler);
}

+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 */

@@ -4278,11 +4300,17 @@
C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word 
reason)
{
  int sig = C_unfix(signum);
-
-  if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
-  else {
+  struct sigaction new, old;
+  new.sa_flags = 0;
+  sigemptyset(&new.sa_mask);
+
+  if(reason == C_SCHEME_FALSE) {
+    new.sa_handler = SIG_IGN;
+    C_sigaction(sig, &new, &old);
+  } else {
    signal_mapping_table[ sig ] = C_unfix(reason);
-    C_signal(sig, global_signal_handler);
+    new.sa_handler = global_signal_handler;
+    C_sigaction(sig, &new, &old);
  }

  return C_SCHEME_UNDEFINED;


The Scheduler is where you need to find a good place to hook in. The 
attached code is not perfect: thread-wait-for-/o should deliver a 
meaningful return value if the file descriptor turns bad. But that would 
incure so many more changes that I'm living for the time being with an 
exception being raised. Much better than re-selecting if the client thread 
just does not wants to unregister the fd.

The changes to scheduler.scm and srfi-18.scm have been done in two steps:
1)  The implementation details of the timeout and fd set where scattered all
 over.  Those have been abstracted into their own functions.
2)  The implementation has been replaces without touching the rest.
 (A former version had cond-expand -able versions for the original linear
  list rbtree and llrbtree.  But once I've got bored of them.)

No: three steps, later I've been debugging some mutex problem.

The original ##sys#schedule from chicken I never fully understood. (And 
Felix once told me that he's not fully satisfied either.) Hence that's been 
cleaned up. The new version allows us much better to adjust the scheduling 
policy. Something we just need here wrt. signals.


(define (##sys#schedule)
 (let* ([ct ##sys#current-thread]
         [cts (##sys#slot ct 3)] )
   (dbg "scheduling, current: " ct ", ready: " ##sys#ready-queue-head " 
waiting: " ##sys#waiting-queue-head)
   (##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) )

   ;; HERE is IMHO a good place to run the signal handler.

   ;; But: it's not the only one.

   (##sys#async-interrupt-hook (##sys#signals-pending))



   ;; 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
        ;; further down (commented out).  However at least for my
        ;; test, releasing it here will improve performance by about
        ;; 5%.  (Probably due to the fact that fewer threads are alive
        ;; on average.)
        ;(##sys#release-waiting-queue)

        ;; Unblock threads blocked by I/O:
        (unless (##sys#fd-list-empty?)
           (##sys#unblock-threads-for-i/o) )    ;;; HERE IS THE 2nd!  Done 
there.

        ;; Unblock threads waiting for timeout:
        (unless (##sys#timeout-list-empty?)
           (##sys#unblock-threads-for-timeout!))

        (if (##sys#ready-queue-empty?)
            (##sys#release-waiting-queue))

        (if (and (##sys#fd-list-empty?) (##sys#ready-queue-empty?))
            (if (##sys#timeout-list-empty?)
                (##sys#signal-hook #:runtime-error "deadlock")
                ;; Sleep for the number of milliseconds of next thread
                ;; to wake up and force primordial thread if
                ;; interupted.
                (if (let ([tmo (int-priority-queue-index (timeout-queue-next))])
                      (and (not (##core#inline "C_msleep" (fxmax 0 (- tmo 
(##sys#scheduler-time)))))
                           (foreign-value "C_signal_interrupted_p" bool) ) )
                    ;; I can't see why whe should run the primordial here.
                    ;; Better schedule again.
                    ;;(##sys#force-primordial)
                    (##sys#async-interrupt-hook (##sys#signals-pending)))))

        (loop (##sys#remove-from-ready-queue)) ]
      [(eq? (##sys#slot nt 3) 'ready)
        (dbg "switching to " nt)
        (set! ##sys#current-thread nt)
        (##sys#setslot nt 3 'running)
        (##sys#restore-thread-state-buffer nt)
        (##core#inline "C_set_initial_timer_interrupt_period" (##sys#slot nt 9))
        ((##sys#slot nt 1))]
      [else (loop (##sys#remove-from-ready-queue))] ) ) ))


You see: it handles the signals as the last thing before it actually 
schedules. Hence: signals come before any next thread.

We can probably hardly do better, if we want them to run just after
garbage collection.

Further down there might be some hint towards solutions for your EINTR 
problem.

I just fixed that yesterday after you gave me that hint.

However that one overlaps with the fdlist as llrb-tree change.
You get the idea:  (##sys#async-interrupt-hook (##sys#signals-pending)
is called when (foreign-value "C_signal_interrupted_p" bool) holds true.

Aside: this handles bad fd's too.

+(define (##sys#unblock-threads-for-i/o) + (dbg "fd-list: " 
(fd-list-node-fold + (lambda (n i) (cons (cons (int-priority-queue-index n) 
(int-priority-queue-value n)) i)) + '() + ##sys#fd-list)) + (let* ([n (if 
(and (##sys#ready-queue-empty?) (##sys#waiting-queue-empty?)) ; wait + (if 
(##sys#timeout-list-empty?) + (fdset-select-wait ##sys#fd-list-leftmost) + 
(fdset-select-timeout + ##sys#fd-list-leftmost + (let ([tmo 
(int-priority-queue-index (timeout-queue-next))] + [now 
(##sys#scheduler-time)]) + (fxmax 0 (- tmo now))) )) + 
(fdset-select-timeout ##sys#fd-list-leftmost 0)) + ] ) ; otherwise 
immediate timeout. + (dbg n " fds ready") + (cond [(eq? n 0)] + [(eq? -1 n) 
+ (cond + (error-bad-file + (let ((node 
((##sys#call-with-current-continuation + (lambda (exit) + 
(fd-list-node-for-each + (lambda (node) + (define fd 
(int-priority-queue-index node)) + (dbg "check bad " fd) + (if 
((foreign-lambda* + bool ((integer fd)) + "struct stat buf;" + "int i = ( 
(fstat(fd, &buf) == -1 && errno == EBADF) ? 1 : 0);" + "return(i);") + fd) 
+ (exit (lambda () node)))) + ##sys#fd-list) + (exit (lambda () #f))))))) + 
(if node + (let ((fd (int-priority-queue-index node)) + (ts 
(int-priority-queue-value node))) + (dbg "bad is " fd) + 
(##sys#fd-list-clear-entry! node) + (for-each + #;(lambda (thread) + 
(thread-signal! + thread + (##sys#make-structure + 'condition + '(exn i/o) 
;; better? '(exn i/o net) + (list '(exn . message) "bad file descriptor" + 
'(exn . arguments) (list fd) + '(exn . location) thread) ))) + (lambda (t) 
+ (let* ((p (##sys#slot t 11)) ) + (when (and (pair? p) + (eq? fd (car p)) 
+ (not (##sys#slot t 13) ) ) ; not unblocked by timeout + 
(##sys#thread-unblock! t) ) )) + ts))))) + ((foreign-value 
"C_signal_interrupted_p" bool) + (##sys#async-interrupt-hook 
(##sys#signals-pending)) + (##sys#unblock-threads-for-i/o)) + (else 
(##sys#force-primordial))) ] + [(fx> n 0) + (for-each + (lambda (e) 
(##sys#fd-list-clear-entry! e)) + (##sys#call-with-current-continuation + 
(lambda (exit) + (fd-list-node-fold + (lambda (node init) + (define fd 
(int-priority-queue-index node)) + (define threads 
(int-priority-queue-value node)) + (if (zero? n) (exit init) + (let* ([inf 
(##core#inline "C_fd_test_input" fd)] + [outf (##core#inline 
"C_fd_test_output" fd)] ) + (dbg "fd " fd " ready: input=" inf ", output=" 
outf) + (if (or inf outf) + (begin + (for-each + (lambda (t) + (let* ((p 
(##sys#slot t 11)) ) + (when (and (pair? p) + (eq? fd (car p)) + (not 
(##sys#slot t 13) ) ) ; not unblocked by timeout + 
(##sys#remove-from-timeout-list t) + (##sys#setislot t 11 #f) + 
(##sys#thread-basic-unblock! t) ) )) + threads) + (set! n (sub1 n)) + (cons 
node init)) + init)))) + '() + ##sys#fd-list)))) ] ) ) )

;;; Get list of all threads that are ready or waiting for timeout or 
waiting for I/O:
;

diff
Description: diff