[Chicken-users] process-wait

[Jörg F . Wittenberger]

For quite some time I've been wondering why my app runs only about
twice as fast on chicken compared to rscheme (given the benchmark
style performance of chicken code).

strace was my friend to pin this down to process-wait.  From the
manual: "Suspends the current process...Note that suspending the
current process implies that all threads are suspended as well."
Too bad, my app spent it's time waiting for irrelevant processes,
not running useful threads as I'd like it to.

This shouldn't be too hard to fix, I thought - and wrote the code
I'll paste and comment.  (With the intention that this might
go into the posix unit eventually.)  Once the issues I have are
resolved, that is.  However those are harder than I expected:
(Side note: even with bad the code here my app feels much
better, since the "coughing" is gone.)

[NB: this has been /has to be/ compiled with disable-interrupts.
I'm running chicken 4.7.3.]

The idea is to convert (process-wait pid #f) into
(process-wait pid #t) and block the current tread only
when the first result is zero.

For the time being I defined two procedures
process-test-pid as replacement for (process-wait pid #t)
and
process-wait-for-pid as replacement for (process-wait pid #f)
Just to make plain clear what I expect the to do.

(define process-waiting-list '())

(define (process-wait-for-pid pid)
 (##sys#check-exact pid 'process-wait-for-pid)
 (let ((gone (assq pid process-waiting-list)))
   (if gone
        (begin
          (set! process-waiting-list (##sys#delq gone process-waiting-list))
          ;;(format (current-error-port) "wait-for-pid ~a\n" gone)
          (apply values gone))
        (receive
         (p f s) (##sys#process-wait pid #t)
         ;;(format (current-error-port) "process-wait-for-pid ~a: <= ~a\n" pid 
p)
         (if (fx= p 0)
             (begin
               (##sys#call-with-current-continuation
                (lambda (return)
                  (let ((ct (current-thread)))
                    (set! process-waiting-list (cons (cons pid ct) 
process-waiting-list))
                    (##sys#setslot ct 3 'blocked)
                    (##sys#setslot ct 1 (lambda () (return #t)))
                    (##sys#schedule))))
               (process-wait-for-pid pid))
             (if (fx= p -1)
                 (posix-error #:process-error 'process-wait "waiting for 
child process failed" pid)
                 (values p f s)))))))

I'm sure this could be done better, it should be possible to
avoid the second lookup in the assoc list after the thread
has been unblocked.  I'm just unsure how to set this up.

(define (process-test-pid pid)
 (##sys#check-exact pid 'process-test-pid)
 (let ((gone (assq pid process-waiting-list)))
   (if gone
        (begin
          (set! process-waiting-list (##sys#delq gone process-waiting-list))
          ;;(format (current-error-port) "testpid ~a\n" gone)
          (apply values gone))
        (receive
         (p f s) (##sys#process-wait pid #t)
         ;;(format (current-error-port) "process-test-pid ~a: <= ~a\n" pid p)
         (if (fx= p -1)
             (values pid #f s)
             (values p f s))))))

Here the p==-1 case needs some cleanup: maybe it better raised an
exception?  This way it returns some useless "terminated abnormally"
value, which should not hurt things.

Now there's one thing left: unblock the waiting thread when a child
exits:


(define (process-signal/chld signum)
 ;;(chicken-disable-interrupts!)
 (let loop ()
   (receive
    (p f s) (##sys#process-wait -1 signum)      ; wait for any child process
    ;;(format (current-error-port) "~a: ~a\n" p process-waiting-list)
    (if (fx> p 0)
         (let ((e (assq p process-waiting-list)))
           (if e
               (let ((t (cdr e)))
                 ;; We would better pass the results right here and delq from 
the list.
                 (set-cdr! e (list f s))
                 (if (thread? t)
                     (if (eq? (##sys#slot t 3) 'blocked)
                         (begin
                           ;;(format (current-error-port) "enable schld hdlr ~a 
~a\n" p t)
                           (##sys#thread-unblock! t))
                         ;;(format (current-error-port) "schld hdlr ~a ~a 
is ~a\n" p t (##sys#slot t 3))
                         )))
               (set! process-waiting-list (cons (list p f s) 
process-waiting-list)))
           (loop))
         ;;(chicken-enable-interrupts!)
         ))))

(set-signal-handler! signal/chld process-signal/chld)

So far my idea.

This happens to work (and uncommenting those format-calls will
show no unexpected things).

For a while, that is. :-(

Then the chicken process enters a tight loop.  Not eating memory,
not printing trace or debug information.
Not even responding to *any* signal except SIGKILL.

Strace again shows nothing strange either (besides to my surprise
waitpid not showing up while it obviously returns).
Except one notable thing: when the cpu usage goes to 100% the last
entries are always two SIGCHLD in a row.

However this sequence does not always have this effect.  About 70%
will go through.

To work around I commented the set-signal-handler! out and added:

(define helpme
 (thread-start! (lambda () (let loop () (process-signal/chld 42) 
(thread-sleep! 1) (loop)))))

Nomen est omen: helpme please, I'd assume that the signal handler
would be the better solution.  But how do I find out why it will
not work?

Ah, one more surprise in the strace:

10:56:43 write(2, "process-wait-for-pid 30940: <= 3"..., 37) = 37 <0.000041>

So I read as (process-wait 30940 #t) has returned "3" as first result.
This is really beyond my mental capacity.  How is that possible?

For completeness: I also had some use for a "get-rid-of-pid",
a three strikes way to be sure it's gone:


(define (get-rid-of-pid pid)
 (##sys#check-exact pid 'get-rid-of-pid)
 (let loop ((turn 1))
   (let ((gone (assq pid process-waiting-list)))
     (if gone
          #t ;; (set! process-waiting-list (##sys#delq gone 
process-waiting-list))
          (receive
           (p f s) (##sys#process-wait pid #t)
           ;;(format (current-error-port) "get-rid-of-pid(~a) ~a <= ~a\n" 
turn pid p)
           (if (eqv? p 0)
               ;; three stikes
               (cond
                ((fx>= turn 8)
                 (process-signal pid signal/term)
                 (thread-sleep! turn)
                 (loop (+ turn turn)))
                ((fx>= turn 16)
                 (process-signal pid signal/kill)
                 (thread-sleep! turn)
                 (loop (+ turn turn)))
                ((fx>= turn 64) #f)  ; give up
                (else
                 (thread-sleep! turn)
                 (loop (+ turn turn))))
               (if (fx> p 0)
                   (set! process-waiting-list (cons (list p f s) 
process-waiting-list)))))))))

Might be useful too.

Best regards and thanks for any help&hint.

/Jörg
............