X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIOBase.lhs;h=e149ae523a4b090cd013362d0a10a1f0b124fe7b;hb=06427ada7eac4e6686fe0e37b16c7385f0ea4822;hp=233148b0eaffffa011ccb91673cacb6e5820d0c8;hpb=aaf764b3ad8b1816d68b5f27299eac125f08e1a5;p=haskell-directory.git

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index 233148b..e149ae5 100644
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -14,21 +14,49 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.IOBase where
-
+-- #hide
+module GHC.IOBase(
+    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, 
+    unsafePerformIO, unsafeInterleaveIO,
+  
+	-- To and from from ST
+    stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
+
+	-- References
+    IORef(..), newIORef, readIORef, writeIORef, 
+    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+    MVar(..),
+
+    	-- Handles, file descriptors,
+    FilePath,  
+    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, 
+    isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
+  
+    	-- Buffers
+    Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),
+    bufferIsWritable, bufferEmpty, bufferFull, 
+
+    	-- Exceptions
+    Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
+    stackOverflow, heapOverflow, throw, throwIO, ioException, 
+    IOError, IOException(..), IOErrorType(..), ioError, userError,
+    ExitCode(..) 
+  ) where
+	
 import GHC.ST
 import GHC.Arr	-- to derive Ix class
 import GHC.Enum -- to derive Enum class
 import GHC.STRef
 import GHC.Base
-import GHC.Num	-- To get fromInteger etc, needed because of -fno-implicit-prelude
+--  import GHC.Num	-- To get fromInteger etc, needed because of -fno-implicit-prelude
 import Data.Maybe  ( Maybe(..) )
 import GHC.Show
 import GHC.List
 import GHC.Read
+import Foreign.C.Types (CInt)
 
 #ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Dynamic
+import {-# SOURCE #-} GHC.Dynamic
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -128,6 +156,9 @@ ioToST (IO m) = (ST m)
 unsafeIOToST        :: IO a -> ST s a
 unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s
 
+unsafeSTToIO :: ST s a -> IO a
+unsafeSTToIO (ST m) = IO (unsafeCoerce# m)
+
 -- ---------------------------------------------------------------------------
 -- Unsafe IO operations
 
@@ -185,7 +216,7 @@ help of 'unsafePerformIO'.  So be careful!
 -}
 {-# NOINLINE unsafePerformIO #-}
 unsafePerformIO	:: IO a -> a
-unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
+unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
 
 -- Why do we NOINLINE unsafePerformIO?  See the comment with
 -- GHC.ST.runST.  Essentially the issue is that the IO computation
@@ -193,6 +224,22 @@ unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 -- not at all.  If we let the compiler see the application of the IO
 -- to realWorld#, it might float out part of the IO.
 
+-- Why is there a call to 'lazy' in unsafePerformIO?
+-- If we don't have it, the demand analyser discovers the following strictness
+-- for unsafePerformIO:  C(U(AV))
+-- But then consider
+--	unsafePerformIO (\s -> let r = f x in 
+--			       case writeIORef v r s of (# s1, _ #) ->
+--			       (# s1, r #)
+-- The strictness analyser will find that the binding for r is strict,
+-- (becuase of uPIO's strictness sig), and so it'll evaluate it before 
+-- doing the writeIORef.  This actually makes tests/lib/should_run/memo002
+-- get a deadlock!  
+--
+-- Solution: don't expose the strictness of unsafePerformIO,
+--	     by hiding it with 'lazy'
+
+
 {-|
 'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
 When passed a value of type @IO a@, the 'IO' will only be performed
@@ -296,7 +343,7 @@ instance Eq Handle where
  (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2
  _ == _ = False 
 
-type FD = Int -- XXX ToDo: should be CInt
+type FD = CInt
 
 data Handle__
   = Handle__ {
@@ -396,6 +443,9 @@ isWritableHandleType WriteHandle     = True
 isWritableHandleType ReadWriteHandle = True
 isWritableHandleType _	       	     = False
 
+isReadWriteHandleType ReadWriteHandle{} = True
+isReadWriteHandleType _                 = False
+
 -- | File and directory names are values of type 'String', whose precise
 -- meaning is operating system dependent. Files can be opened, yielding a
 -- handle which can then be used to operate on the contents of that file.
@@ -572,6 +622,10 @@ data Exception
 	-- ^The current thread was waiting to retry an atomic memory transaction
 	-- that could never become possible to complete because there are no other
 	-- threads referring to any of teh TVars involved.
+  | NestedAtomically
+	-- ^The runtime detected an attempt to nest one STM transaction
+	-- inside another one, presumably due to the use of 
+	-- 'unsafePeformIO' with 'atomically'.
   | Deadlock
 	-- ^There are no runnable threads, so the program is
 	-- deadlocked.  The 'Deadlock' exception is
@@ -706,10 +760,11 @@ instance Show Exception where
   showsPrec _ (RecConError err)	         = showString err
   showsPrec _ (RecUpdError err)	         = showString err
   showsPrec _ (AssertionFailed err)      = showString err
-  showsPrec _ (DynException _err)        = showString "unknown exception"
+  showsPrec _ (DynException err)         = showString "exception :: " . showsTypeRep (dynTypeRep err)
   showsPrec _ (AsyncException e)	 = shows e
   showsPrec _ (BlockedOnDeadMVar)	 = showString "thread blocked indefinitely"
   showsPrec _ (BlockedIndefinitely)	 = showString "thread blocked indefinitely"
+  showsPrec _ (NestedAtomically)	 = showString "Control.Concurrent.STM.atomically was nested"
   showsPrec _ (NonTermination)           = showString "<<loop>>"
   showsPrec _ (Deadlock)                 = showString "<<deadlock>>"
 
@@ -729,6 +784,7 @@ instance Eq Exception where
   AsyncException e1   == AsyncException e2   = e1 == e2
   BlockedOnDeadMVar   == BlockedOnDeadMVar   = True
   NonTermination      == NonTermination      = True
+  NestedAtomically    == NestedAtomically    = True
   Deadlock            == Deadlock            = True
   _                   == _                   = False
 
@@ -760,8 +816,8 @@ throw exception = raise# exception
 -- Although 'throwIO' has a type that is an instance of the type of 'throw', the
 -- two functions are subtly different:
 --
--- > throw e   `seq` return ()  ===> throw e
--- > throwIO e `seq` return ()  ===> return ()
+-- > throw e   `seq` x  ===> throw e
+-- > throwIO e `seq` x  ===> x
 --
 -- The first example will cause the exception @e@ to be raised,
 -- whereas the second one won\'t.  In fact, 'throwIO' will only cause