;; Bug in chicken 4 (current git master): when thread-wait-for-i/o!
;; gets interrupted, then from within the signal handler, calls
;; thread-wait-for-i/o! again, and before the second call returns, the
;; other end of the pipe/connection waited on by the first
;; thread-wait-for-i/o! closes the connection, chicken throws an
;; error.
;;
;; To test, write to io-problem.scm; run:
;;
;; csc -O3 -d3 -C -pthread -L -pthread io-problem.scm && ./io-problem
;;
;; ...and press ^C within 5 seconds.
;;
;; XXX this test case should be 10 lines long.

(declare (disable-interrupts))
(use (srfi 18) posix)

#>
#include 
#include 
#include 

static void *C_wait_a_bit(void *ptr)
{
    int fd = *((int*) ptr);
    free(ptr);
    printf("C_wait_a_bit: sleeping for 5 seconds...\n");
    sleep(5);
    close(fd); /* Lazy: don't even bother writing to it */
    return NULL;
}

<#
;; Some chicken-4.11-specific evil.  This is not the part that breaks
;; (the test doesn't get to it, as long as you press ^C)
(define %close-or-loop
  (foreign-primitive ((int fd)
                      (scheme-object loop))
      "char buf[1]; int bytes_read;
       /* This depends on fd being non-blocking. */
       while ((bytes_read = read(fd, buf, 1)) < 0 && errno == EINTR);
       if (bytes_read < 0 && errno == EAGAIN) {
           /* This part is rather radically different in Chicken 4.11
              than it was in 4.10.  I'm sure this would need to change
              fairly often (every couple of years). */
           C_av[0] = loop; /* Re-use arg-vector */
           /* C_av[1] is still C_k */
           C_av[2] = C_fix(fd);
           ((C_proc)C_fast_retrieve_proc(loop))(3, C_av);
       } else {
           /* The other end is closed without writing anything */
           assert(bytes_read <= 0);
           close(fd);
           C_kontinue(C_k, C_SCHEME_UNDEFINED);
       }"))

;; Have the current Chicken thread wait until a pthreads thread has
;; sent us some data through a pipe, and then close the file
;; descriptor of our end.  This needs to be resilient against EINTR,
;; and expects fd to have non-blocking semantics.
(: %wait-and-close (fixnum -> void))
(define (%wait-and-close fd)
  (print "%wait-and-close: " (current-thread) " waiting for " fd)
  (thread-wait-for-i/o! fd #:input)
  (%close-or-loop fd %wait-and-close))

(: make-cleanup-thread (-> fixnum))
(define (make-cleanup-thread)
  (let ((%make-cleanup-thread
         (foreign-primitive ((int fd))
             "pthread_t thread;
              int *ptr = malloc(sizeof(int));
              if (ptr == NULL) { errno = ENOMEM; return(C_SCHEME_FALSE); }
              *ptr = fd;
              C_r=C_SCHEME_FALSE;
              /* NB: pthread functions return (positive) error numbers on error */
              if ((errno = pthread_create(&thread, NULL, &C_wait_a_bit, ptr)) != 0)
                  close(fd);
              else if ((errno = pthread_detach(thread)) == 0)
                  C_r=C_SCHEME_TRUE;")))
    (receive (readfd writefd) (create-pipe)
      (file-control readfd fcntl/setfl open/nonblock)
      (or (%make-cleanup-thread writefd)
          (let ((err (%strerror %errno)))
            (##core#inline "close" readfd)
            (error '%make-cleanup-thread err)))
      readfd)))

(define cleanup-fd #f)

;; Replacing ##sys#user-interrupt-hook with this version fixes the
;; problem.
(define (my/user-interrupt-hook)
  (define (break) (##sys#signal-hook #:user-interrupt #f))
  (##sys#setslot ##sys#primordial-thread 1 break))

(let ((handler (lambda (_)
                 ;; Start a second pthreads thread, that will close a
                 ;; file descriptor after 5 seconds
                 (print "##sys#user-interrupt-hook from " (current-thread))
                 (set! cleanup-fd (make-cleanup-thread))
                 ;; (my/user-interrupt-hook)
                 (##sys#user-interrupt-hook)
                 )))
  (set-signal-handler! signal/int handler)
  (set-signal-handler! signal/term handler))

(define (exit-handler)
  (when cleanup-fd
    (condition-case
        (begin
          (print "Exit handler: " (current-thread) " calling %wait-and-close for fd " cleanup-fd)
          ;; Wait using thread-wait-for-i/o! 
          (%wait-and-close cleanup-fd))
      ((user-interrupt) (exit-handler)))))
(on-exit exit-handler)

(let loop ()
  ;; Make a C_wait_a_bit thread, which will close the write end of the
  ;; pipe pointed to by fd after 5 seconds.
  (let ((fd (make-cleanup-thread)))
    (print (current-thread) " waiting for fd " fd)
    (thread-wait-for-i/o! fd input:))
  (loop))

;; This doesn't work, as it really does have to be a real thread, not
;; a chicken one, that closes the file descriptor behind our back:

;; (receive (readfd writefd) (create-pipe)
;;   (file-control readfd fcntl/setfl open/nonblock)
;;   (thread-start! (lambda ()
;;                    (thread-sleep! 3)
;;                    (file-close writefd)))
;;   (thread-wait-for-i/o! readfd input:))