X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FIO.hs;h=aed2eb76d21de1b35aa534841c19b4d58b5fe834;hb=2a0be3763d07b0796ddbfb582d95492325f60e3e;hp=d189ac1fceebae18a3dc624a1aa13301e816508d;hpb=50001a0d33c6c8c12e7dbffc3b2ce7e325383cb7;p=ghc-base.git

diff --git a/System/IO.hs b/System/IO.hs
index d189ac1..aed2eb7 100644
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -93,7 +93,7 @@ module System.IO (
 
     -- ** Terminal operations
 
-#if !defined(__HUGS__) && !defined(__NHC__)
+#if !defined(__NHC__)
     hIsTerminalDevice,	 	-- :: Handle -> IO Bool
 
     hSetEcho,			-- :: Handle -> Bool -> IO ()
@@ -143,12 +143,11 @@ module System.IO (
 
 #if !defined(__NHC__)
     openBinaryFile,	       -- :: FilePath -> IOMode -> IO Handle
-#endif
-
-#if !defined(__HUGS__) && !defined(__NHC__)
     hSetBinaryMode,	       -- :: Handle -> Bool -> IO ()
     hPutBuf,		       -- :: Handle -> Ptr a -> Int -> IO ()
     hGetBuf,		       -- :: Handle -> Ptr a -> Int -> IO Int
+#endif
+#if !defined(__NHC__) && !defined(__HUGS__)
     hPutBufNonBlocking,	       -- :: Handle -> Ptr a -> Int -> IO Int
     hGetBufNonBlocking,	       -- :: Handle -> Ptr a -> Int -> IO Int
 #endif
@@ -171,6 +170,9 @@ import GHC.Show
 #ifdef __HUGS__
 import Hugs.IO
 import Hugs.IOExts
+import Hugs.IORef
+import Hugs.Prelude	( throw, Exception(NonTermination) )
+import System.IO.Unsafe	( unsafeInterleaveIO )
 #endif
 
 #ifdef __NHC__
@@ -375,9 +377,18 @@ hPrint hdl 	=  hPutStrLn hdl . show
 -- ---------------------------------------------------------------------------
 -- fixIO
 
-#ifdef __GLASGOW_HASKELL__
-fixIO 		:: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+fixIO :: (a -> IO a) -> IO a
+fixIO k = do
+    ref <- newIORef (throw NonTermination)
+    ans <- unsafeInterleaveIO (readIORef ref)
+    result <- k ans
+    writeIORef ref 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.
 #endif
 
 -- $locking