Permalink
Browse files

use MVar to define fixIO, for thread-safety (see #5421)

  • Loading branch information...
1 parent 2e445e5 commit 2cc5a65eb6463bb92b84cc4416a410ab80cda950 @simonmar simonmar committed Nov 4, 2011
Showing with 17 additions and 6 deletions.
  1. +2 −2 Foreign.hs
  2. +15 −4 System/IO.hs
View
@@ -45,11 +45,11 @@ import Foreign.Storable
import Foreign.Marshal
import GHC.IO (IO)
-import qualified System.IO.Unsafe (unsafePerformIO)
+import qualified GHC.IO (unsafePerformIO)
{-# DEPRECATED unsafePerformIO "Use System.IO.Unsafe.unsafePerformIO instead; This function will be removed in the next release" #-}
{-# INLINE unsafePerformIO #-}
unsafePerformIO :: IO a -> a
-unsafePerformIO = System.IO.Unsafe.unsafePerformIO
+unsafePerformIO = GHC.IO.unsafePerformIO
View
@@ -253,12 +253,12 @@ import GHC.IO.Handle.FD
import qualified GHC.IO.FD as FD
import GHC.IO.Handle
import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn )
-import GHC.IORef
import GHC.IO.Exception ( userError )
import GHC.IO.Encoding
import GHC.Num
import Text.Read
import GHC.Show
+import GHC.MVar
#endif
#ifdef __HUGS__
@@ -462,15 +462,26 @@ withBinaryFile name mode = bracket (openBinaryFile name mode) hClose
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
fixIO :: (a -> IO a) -> IO a
fixIO k = do
- ref <- newIORef (throw NonTermination)
- ans <- unsafeInterleaveIO (readIORef ref)
+ m <- newEmptyMVar
+ ans <- unsafeInterleaveIO (takeMVar m)
result <- k ans
- writeIORef ref result
+ putMVar m result
return result
-- NOTE: we do our own explicit black holing here, because GHC's lazy
-- blackholing isn't enough. In an infinite loop, GHC may run the IO
-- computation a few times before it notices the loop, which is wrong.
+--
+-- NOTE2: the explicit black-holing with an IORef ran into trouble
+-- with multiple threads (see #5421), so now we use an MVar. I'm
+-- actually wondering whether we should use readMVar rather than
+-- takeMVar, just in case it ends up being executed multiple times,
+-- but even then it would have to be masked to protect against async
+-- exceptions. Ugh. What we really need here is an IVar, or an
+-- atomic readMVar, or even STM. All these seem like overkill.
+--
+-- See also System.IO.Unsafe.unsafeFixIO.
+--
#endif
#if defined(__NHC__)

0 comments on commit 2cc5a65

Please sign in to comment.