Re: [Chicken-users] replace signal with sigaction

[Jörg F . Wittenberger]

Now let's see how we can use those modifications.

This code is far from what I'd like it to be.

It starts out with the idea, that it tries to resemble the
process-wait API as it stands.

However in the presence of green threads I feel that the API
is not the best we could have.  This translates into the weird
code to be presented.

Note that this code must be compiled with (disable-interrupts).

;; To take the load off the OS, we keep our internal table
;; of child processes.  This simplifies the waitpit call too.

(define processes-running (make-hash-table fx= number-hash))

;; Only for introspection: to cons up all the children's state:
;; (running-processes-fold cons '())
;; List entries:
;;  (<pid>)               => running
;;  (<pid> <thread> ...)  => those thread waiting
;;  (<pid> <bool> <int>)  => terminated, but no thread so far did waitforit
;;
;; Also handy for debugging.

(define (running-processes-fold f i)
 (hash-table-fold processes-running (lambda (k v i) (f v i)) i))

(define-foreign-variable C_interrupts_enabled bool "C_interrupts_enabled")
(define (chicken-simple-enable-interrupts!) (set! C_interrupts_enabled #t))

;; fork the child and register it
;; Aside: You don't want to just fork if you have threads.  And you
;; don't want the install an exception handler just for the fork.

(define (save-fork)
 (chicken-disable-interrupts!)
 (let ((ie (##sys#fudge 14))
        (pid ((foreign-lambda int "fork"))))
   (case pid
     ((0) (set! processes-running (make-hash-table fx= number-hash)))
     ((-1) (if ie (chicken-simple-enable-interrupts!)))
     (else (hash-table-set! processes-running pid (list pid))
            (if ie (chicken-simple-enable-interrupts!))))
   pid))


;; Now a tentatively replacement for process-wait.  I'm not using
;; That anywhere.   Falls back to the state of affairs in pid=0

(define (alt-process-wait pid nohang)
 (if (<= pid 0)
     (process-wait pid nohang
     (if nohang
         (process-test-pid pid)
         (process-wait-for-pid pid))))

#|

 NB:  Even though the above mimics the API it is different.

 What would have to fix the remaining race conditions wrt.
 multiple green thread waiting for the same process:
 Change the API: Refer to the process by means of a process
 structure.  That one would hold the entry we keep in the 
 processes-running table.  Threads would wait on that struct
 and we could happily remove it from the table
 right in process-waitpid-signal-pending! before we enable
 the waiting threads.

 Sadly that's not practical because of the weird API.

 Therefore we really mimic what an OS would do.

|#


(define (process-waitpid-signal-pending! e f s)
 (let ((t (cdr e)))
   (set-cdr! e (list f s))
   (for-each
    (lambda (t)
      (if (and (thread? t) (eq? (##sys#slot t 3) 'blocked))
           (##sys#thread-unblock! t)
           ))
    t)))

(define (process-waitpid nohang)
 (let loop ()
   (receive
    (p f s) (##sys#process-wait -1 nohang) ; wait for any child process
    (if (fx> p 0)
         (let ((e (hash-table-ref/default processes-running p #f)))
           (if e
               (process-waitpid-signal-pending! e f s)
               (hash-table-set! processes-running p (list p f s)))
           (loop))))))


(define (process-signal/chld signum) (process-waitpid #t))

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

(define (process-wait-for-pid pid)
 (##sys#check-exact pid 'process-wait-for-pid)
 (let ((e (hash-table-ref/default processes-running pid #f)))
   (if (and e (pair? (cdr e)) (not (thread? (cadr e))))
        (begin
          (hash-table-delete! processes-running pid)
          (apply values e))
        (receive
         (p f s) (##sys#process-wait pid #t)
         (if (fx= p 0)
             (let ((ct (current-thread)))
               (set-cdr! e (cons ct (cdr e)))
               (##sys#call-with-current-continuation
                (lambda (return)
                  (##sys#setslot ct 3 'blocked)
                  (##sys#setslot ct 1 (lambda () (return #t)))
                  (##sys#schedule)))
               (hash-table-delete! processes-running pid)
               (apply values e))
             (begin
               (if e (process-waitpid-signal-pending! e f s))
               (if (fx= p -1)
                   (values -1 #f s)
                   (values p f s))))))))

(define (process-test-pid pid)
 (##sys#check-exact pid 'process-test-pid)
 (let ((gone (hash-table-ref/default processes-running pid #f)))
   (if (and gone (pair? (cdr gone)) (not (thread? (cadr gone))))
        (begin
          (hash-table-delete! processes-running pid)
          (apply values gone))
        (receive
         (p f s) (##sys#process-wait pid #t)
         (if (and gone (fx= p pid))
             (process-waitpid-signal-pending! gone f s))
         (if (fx= p -1)
             (values pid #f s)
             (values p f s))))))