From: wolfgang <unknown>
Date: Sat, 25 Jan 2003 15:54:51 +0000 (+0000)
Subject: [project @ 2003-01-25 15:54:51 by wolfgang]
X-Git-Tag: nhc98-1-18-release~749
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4e62d8842ce3fb33590bd73da2f4262dbfa37024;p=ghc-base.git

[project @ 2003-01-25 15:54:51 by wolfgang]
This commit fixes many bugs and limitations in the threaded RTS.
There are still some issues remaining, though.

The following bugs should have been fixed:

- [+] "safe" calls could cause crashes
- [+] yieldToReturningWorker/grabReturnCapability
    -     It used to deadlock.
- [+] couldn't wake blocked workers
    -     Calls into the RTS could go unanswered for a long time, and
          that includes ordinary callbacks in some circumstances.
- [+] couldn't block on an MVar and expect to be woken up by a signal
      handler
    -     Depending on the exact situation, the RTS shut down or
          blocked forever and ignored the signal.
- [+] The locking scheme in RtsAPI.c didn't work
- [+] run_thread label in wrong place (schedule())
- [+] Deadlock in GHC.Handle
    -     if a signal arrived at the wrong time, an mvar was never
          filled again
- [+] Signals delivered to the "wrong" thread were ignored or handled
      too late.

Issues:
*) If GC can move TSO objects (I don't know - can it?), then ghci
will occasionally crash when calling foreign functions, because the
parameters are stored on the TSO stack.

*) There is still a race condition lurking in the code
(both threaded and non-threaded RTS are affected):
If a signal arrives after the check for pending signals in
schedule(), but before the call to select() in awaitEvent(),
select() will be called anyway. The signal handler will be
executed much later than expected.

*) For Win32, GHC doesn't yet support non-blocking IO, so while a
thread is waiting for IO, no call-ins can happen. If the RTS is
blocked in awaitEvent, it uses a polling loop on Win32, so call-ins
should work (although the polling loop looks ugly).

*) Deadlock detection is disabled for the threaded rts, because I
don't know how to do it properly in the presence of foreign call-ins
from foreign threads.
This causes the tests conc031, conc033 and conc034 to fail.

*) "safe" is currently treated as "threadsafe". Implementing "safe" in
a way that blocks other Haskell threads is more difficult than was
thought at first. I think it could be done with a few additional lines
of code, but personally, I'm strongly in favour of abolishing the
distinction.

*) Running finalizers at program termination is inefficient - there
are two OS threads passing messages back and forth for every finalizer
that is run. Also (just as in the non-threaded case) the finalizers
are run in parallel to any remaining haskell threads and to any
foreign call-ins that might still happen.
---

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 5259469..c7ebee0 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -131,8 +131,11 @@ withHandle' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   (h',v)  <- catch (act h_) 
-		(\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+   (h',v)  <- catchException (act h_) 
+		(\ err -> putMVar m h_ >>
+		          case err of
+		              IOException ex -> ioError (augmentIOError ex fun h h_)
+		              _ -> throw err)
    checkBufferInvariants h'
    putMVar m h'
    return v
@@ -146,8 +149,11 @@ withHandle_' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   v  <- catch (act h_) 
-	    (\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+   v  <- catchException (act h_) 
+		(\ err -> putMVar m h_ >>
+		          case err of
+		              IOException ex -> ioError (augmentIOError ex fun h h_)
+		              _ -> throw err)
    checkBufferInvariants h_
    putMVar m h_
    return v
@@ -162,8 +168,11 @@ withHandle__' fun h m act =
    block $ do
    h_ <- takeMVar m
    checkBufferInvariants h_
-   h'  <- catch (act h_)
-	    (\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+   h'  <- catchException (act h_)
+		(\ err -> putMVar m h_ >>
+		          case err of
+		              IOException ex -> ioError (augmentIOError ex fun h h_)
+		              _ -> throw err)
    checkBufferInvariants h'
    putMVar m h'
    return ()