[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-users] How are exceptions propagated?
From: |
F. Wittenberger |
Subject: |
[Chicken-users] How are exceptions propagated? |
Date: |
Thu, 07 Aug 2008 23:05:56 +0200 |
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)))))
- [Chicken-users] How are exceptions propagated?,
F. Wittenberger <=