3 files changed, 17 insertions, 1 deletions
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index a15cc8ed32..d443159cb3 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -30,6 +30,7 @@ module Control.Exception.Base (
         NonTermination(..),
         NestedAtomically(..),
         BlockedIndefinitelyOnMVar(..),
+        FixIOException (..),
         BlockedIndefinitelyOnSTM(..),
         AllocationLimitExceeded(..),
         CompactionFailed(..),
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 9203f46828..020bc067df 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -33,6 +33,7 @@ module GHC.IO.Exception (
 
   ArrayException(..),
   ExitCode(..),
+  FixIOException (..),
 
   ioException,
   ioError,
@@ -268,6 +269,15 @@ instance Show ArrayException where
         . (if not (null s) then showString ": " . showString s
                            else id)
 
+-- | @since TODO
+data FixIOException = FixIOException
+
+-- | @since TODO
+instance Exception FixIOException
+
+instance Show FixIOException where
+  showsPrec _ FixIOException = showString "cyclic evaluation in fixIO"
+
 -- -----------------------------------------------------------------------------
 -- The ExitCode type
 
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index fde5bb66e5..68817247d2 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -400,10 +400,15 @@ withBinaryFile name mode = bracket (openBinaryFile name mode) hClose
 -- ---------------------------------------------------------------------------
 -- fixIO
 
+-- | The implementation of 'mfix' for 'IO'. If the function passed
+-- to 'fixIO' inspects its argument, the resulting action will throw
+-- 'FixIOException'.
 fixIO :: (a -> IO a) -> IO a
 fixIO k = do
     m <- newEmptyMVar
-    ans <- unsafeDupableInterleaveIO (readMVar m)
+    ans <- unsafeDupableInterleaveIO
+             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
+                                    throwIO FixIOException)
     result <- k ans
     putMVar m result
     return result