[Chicken-users] How are exceptions propagated?

[F. Wittenberger]

Hi all,

this is once again a slightly complicated test case.  Again I understand
all calls for a simpler version.  Just I have a hard time to find one.

For that matter the test case includes three tests.  Called as
$ ./tts 2
it will execute the "test2", which is - to my understanding - just a
simplified version of "test".  However this one runs fine.  It will loop
printing (until ^C is pressed):

$ ./tts 2
JT #<thread: hang>
hang handler #<condition: (join-timeout-exception)> #f #f
...

The other test is worse.  It requires you to telnet (or something) to
port 3033 and then just wait (or complete a line within 2'').  When it
reaches the timeout, it will print a little more about it's progress.
But see:

$ ./tts 1
Listening on port 3033, please connect to start the test!
JT #<thread: echo>
connection exception #<condition: (join-timeout-exception)> #f #f
echo handler #<condition: (join-timeout-exception)> #f #f
terminating connection
Listening on port 3033, please connect to start the test!
primordial exception #<condition: (join-timeout-exception)> state blocked

-- eventually the exception handler in the primordial thread will catch
a join-timeout-exception.  Even worse: the thread-state (printed as
"state blocked") of the thread, which the primordial is supposed to
join, is "blocked" - this would be ok, if thread-join! where called with
timeout.  But it is not.  [For the curious: put a loop around the
exception handler in "test2" and find it looping, catching
join-timeout-exception without any other visible activity.]

NOW:  How did that one get there?  Why not in "test2"?  What's the
difference?


But there's still the 3rd case.  This is a middle ground between the
above two tests - and should shed some light on the trouble I have to
come up with a simple test.  "test3" will call "echo2", which is a copy
of "echo" with one, even inner, exception handler removed! - No more
unexpected exceptions in primordial thread.  (Fine for the test case,
but I need nested exception handlers.)

$ ./tts 3
Listening on port 3033, please connect to start the test!
JT #<thread: echo>
connection exception #<condition: (join-timeout-exception)> #f #f
echo server exception #<condition: (join-timeout-exception)> #f #f
Listening on port 3033, please connect to start the test!
echo server exception #<condition: (exn i/o net)> can not write to
socket - Broken pipe (5)
Listening on port 3033, please connect to start the test!


Best regards

/Jörg

Here the source with comments to make it as comprehensible as I can.
Thanks for taking your time.

---- %< tts.scm ----
(declare (uses srfi-18 tcp extras))

;; Checking thread termination.

(define (logerr . args)
  (apply format (current-error-port) args)
  (flush-output (current-error-port)))

;; At your discretion chose thread-terminate! or thread-signal! to
;; teminate the thread after the timeout.  This should be irrelevant.

(define (with-timeout timeout thunk)
  (let ((thread (thread-start! (make-thread thunk
                                            ;; (string-append
(thread-name (current-thread)) "-worker")
                                            ))))
    (handle-exceptions
     ex
     (cond
      ((join-timeout-exception? ex)
       (thread-terminate! thread)
       ; (thread-signal! thread '(timeout-object))
       (logerr "JT ~a\n" (current-thread))
       (raise ex))
      (else (raise ex)))
     (thread-join! thread timeout))))

;; A overly stupid "echo" service for a single connection.

(define connection-handler
  (lambda (in out peer)
    (let loop ()
      (let ((r
             (handle-exceptions
              ex (begin
                   (logerr "connection exception ~a ~a ~a\n"
                           ex
                           ((condition-property-accessor 'exn 'message) ex)
                           ((condition-property-accessor 'exn 'arguments) ex))
                   (raise ex))

;; The only important thing about that one is, that it will raise a
;; join-timeout-exception here after 2 seconds inactivity on the port.
;;
;; This is supposed to be caught as a "connection exception" and
reraised.

                (with-timeout 2 (lambda () (read-line in))))))

        (format out "Read ~a\n" r)
        (flush-output out)
        (loop)))))

;; A TCP service, which serves stupid "echo" on port 3033.  This is
;; supposed to loop endlessly.

(define (echo)
  (define listener (tcp-listen 3033))
  (let loop ()
    (handle-exceptions
     ex
     (begin (logerr "echo server exception ~a ~a ~a\n"
                    ex
                    ((condition-property-accessor 'exn 'message) ex)
                    ((condition-property-accessor 'exn 'arguments) ex)))
     (logerr "Listening on port 3033, please connect to start the test!
\n")
     (receive
      (in out) (tcp-accept listener)
      (handle-exceptions
       ex (begin
            (logerr "echo handler ~a ~a ~a\n"
                    ex
                    ((condition-property-accessor 'exn 'message) ex)
                    ((condition-property-accessor 'exn 'arguments) ex)))

;; Once the connection-handler has terminated on exception, the
;; exception is to be logged again with "echo handler" tag.

       (connection-handler in out 'dummy))

;; Then we should have handles this join-timeout-exception and
;; continue.  Print "erminating connection" and loop to listen again.

      (logerr "terminating connection\n")
      (close-input-port in)
      (close-output-port out)))
    (loop)))

(define (test)
  (define t2 (thread-start! (make-thread echo 'echo)))
  (handle-exceptions

;; Since t2, i.e. "echo" loops endlessly and handles all exceptions,
;; the primordial thread shall never see an exception.

   ex (begin (logerr "primordial exception ~a state ~a\n" ex
(thread-state t2)) (exit 0))
   (thread-join! t2)))

;; Here is the simplified version, which I'd like to produce.

;; Instead of the lengthy connection-handler we have "hang-here"
;; hanging on something:

(define (hang-here)
  (define m (make-mutex 'hang-up))
  (mutex-lock! m)
  (mutex-lock! m))

;; Instead of the lengthy "echo" server we call the hang.

(define (call-hang)
  (handle-exceptions
   ex (begin
        (logerr "hang handler ~a ~a ~a\n"
                ex
                ((condition-property-accessor 'exn 'message) ex)
                ((condition-property-accessor 'exn 'arguments) ex)))
   (with-timeout 1 hang-here))
  (call-hang))

(define (test2)
  (define t2 (thread-start! (make-thread call-hang 'hang)))
  (handle-exceptions
   ex (begin (logerr "primordial exception ~a state ~a\n" ex
(thread-state t2)) (exit 0))
   (thread-join! t2)))

;; Now a middle ground:

(define (echo2)
  (define listener (tcp-listen 3033))
  (let loop ()
    (handle-exceptions
     ex
     (begin (logerr "echo server exception ~a ~a ~a\n"
                    ex
                    ((condition-property-accessor 'exn 'message) ex)
                    ((condition-property-accessor 'exn 'arguments) ex)))
     (logerr "Listening on port 3033, please connect to start the test!
\n")
     (receive
      (in out) (tcp-accept listener)

;; This time we terminate the connection without comments and leave
;; the port for the finalizers to close.

      (connection-handler in out 'dummy)
      (logerr "terminating connection\n")
      (close-input-port in)
      (close-output-port out)))
    (loop)))

(define (test3)
  (define t2 (thread-start! (make-thread echo2 'echo)))
  (handle-exceptions

;; Since t2, i.e. "echo2" loops endlessly and handles all exceptions,
;; the primordial thread shall never see an exception.

   ex (begin (logerr "primordial exception ~a state ~a\n" ex
(thread-state t2)) (exit 0))
   (thread-join! t2)))

(print (if (null? (cdr (argv)))
           (print "Call: " (car (argv)) " [1|2|3]")
           (case (eval (call-with-input-string (cadr (argv)) read))
             ((1) (test))
             ((2) (test2))
             ((3) (test3)))))