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

2 files changed, 17 insertions, 6 deletions

diff --git a/libraries/base/Foreign.hs b/libraries/base/Foreign.hs
index fc32835d56..caad10442e 100644
--- a/libraries/base/Foreign.hs
+++ b/libraries/base/Foreign.hs
@@ -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
 
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index 9cd96eb0ea..1fbdaf5cd8 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -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__)