diff options
68 files changed, 6804 insertions, 4034 deletions
diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index e171285b3e..2d9cf5786b 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -100,9 +100,8 @@ import GHC.Exception import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield, threadDelay, forkIO, childHandler ) import qualified GHC.Conc -import GHC.IOBase ( IO(..) ) -import GHC.IOBase ( unsafeInterleaveIO ) -import GHC.IOBase ( newIORef, readIORef, writeIORef ) +import GHC.IO ( IO(..), unsafeInterleaveIO ) +import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base import System.Posix.Types ( Fd ) @@ -113,7 +112,6 @@ import Control.Monad ( when ) #ifdef mingw32_HOST_OS import Foreign.C import System.IO -import GHC.Handle #endif #endif diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs index 3513bbd997..521b4996bb 100644 --- a/libraries/base/Control/Concurrent/MVar.hs +++ b/libraries/base/Control/Concurrent/MVar.hs @@ -40,7 +40,7 @@ import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, #endif #ifdef __GLASGOW_HASKELL__ -import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, +import GHC.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer ) #endif diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs index 9e7a4c9d9c..6430c9a21f 100644 --- a/libraries/base/Control/Exception.hs +++ b/libraries/base/Control/Exception.hs @@ -138,7 +138,7 @@ import Control.Exception.Base #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO hiding ( onException, finally ) import Data.Maybe #else import Prelude hiding (catch) diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index b803b5eaab..f32b2f72e1 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -106,9 +106,10 @@ module Control.Exception.Base ( #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO hiding (finally,onException) +import GHC.IO.Exception +import GHC.Exception import GHC.Show -import GHC.IOBase import GHC.Exception hiding ( Exception ) import GHC.Conc #endif @@ -382,7 +383,7 @@ catch :: Exception e -> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> IO a #if __GLASGOW_HASKELL__ -catch = GHC.IOBase.catchException +catch = GHC.IO.catchException #elif __HUGS__ catch m h = Hugs.Exception.catchException m h' where h' e = case fromException e of diff --git a/libraries/base/Control/Monad/ST.hs b/libraries/base/Control/Monad/ST.hs index b77966484f..cae255fa6f 100644 --- a/libraries/base/Control/Monad/ST.hs +++ b/libraries/base/Control/Monad/ST.hs @@ -57,7 +57,7 @@ unsafeInterleaveST = #ifdef __GLASGOW_HASKELL__ import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) import GHC.Base ( RealWorld ) -import GHC.IOBase ( stToIO, unsafeIOToST, unsafeSTToIO ) +import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) #endif instance MonadFix (ST s) where diff --git a/libraries/base/Control/OldException.hs b/libraries/base/Control/OldException.hs index 7469908328..ae25fdc0ce 100644 --- a/libraries/base/Control/OldException.hs +++ b/libraries/base/Control/OldException.hs @@ -134,13 +134,15 @@ module Control.OldException ( import GHC.Base import GHC.Num import GHC.Show -import GHC.IOBase ( IO ) -import qualified GHC.IOBase as New +import GHC.IO ( IO ) +import GHC.IO.Handle.FD ( stdout ) +import qualified GHC.IO as New +import qualified GHC.IO.Exception as New import GHC.Conc hiding (setUncaughtExceptionHandler, getUncaughtExceptionHandler) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Foreign.C.String ( CString, withCString ) -import GHC.Handle ( stdout, hFlush ) +import GHC.IO.Handle ( hFlush ) #endif #ifdef __HUGS__ diff --git a/libraries/base/Data/HashTable.hs b/libraries/base/Data/HashTable.hs index 48ecb0bbc3..c292a7c029 100644 --- a/libraries/base/Data/HashTable.hs +++ b/libraries/base/Data/HashTable.hs @@ -50,9 +50,9 @@ import GHC.Real ( fromIntegral ) import GHC.Show ( Show(..) ) import GHC.Int ( Int64 ) -import GHC.IOBase ( IO, IOArray, newIOArray, - unsafeReadIOArray, unsafeWriteIOArray, unsafePerformIO, - IORef, newIORef, readIORef, writeIORef ) +import GHC.IO +import GHC.IOArray +import GHC.IORef #else import Data.Char ( ord ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs index 70ea4b1550..44e5de192f 100644 --- a/libraries/base/Data/IORef.hs +++ b/libraries/base/Data/IORef.hs @@ -35,7 +35,9 @@ import Hugs.IORef #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.STRef -import GHC.IOBase +import GHC.IO +import GHC.IORef hiding (atomicModifyIORef) +import qualified GHC.IORef #if !defined(__PARALLEL_HASKELL__) import GHC.Weak #endif @@ -75,7 +77,7 @@ modifyIORef ref f = readIORef ref >>= writeIORef ref . f -- atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b #if defined(__GLASGOW_HASKELL__) -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s +atomicModifyIORef = GHC.IORef.atomicModifyIORef #elif defined(__HUGS__) atomicModifyIORef = plainModifyIORef -- Hugs has no preemption diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index 15dfa6a7d3..c400710b44 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -95,12 +95,14 @@ import GHC.Show (Show(..), ShowS, import GHC.Err (undefined) import GHC.Num (Integer, fromInteger, (+)) import GHC.Real ( rem, Ratio ) -import GHC.IOBase (IORef,newIORef,unsafePerformIO) +import GHC.IORef (IORef,newIORef) +import GHC.IO (IO, unsafePerformIO,block) -- These imports are so we can define Typeable instances -- It'd be better to give Typeable instances in the modules themselves -- but they all have to be compiled before Typeable -import GHC.IOBase ( IOArray, IO, MVar, Handle, block ) +import GHC.IOArray +import GHC.MVar import GHC.ST ( ST ) import GHC.STRef ( STRef ) import GHC.Ptr ( Ptr, FunPtr ) @@ -488,7 +490,7 @@ INSTANCE_TYPEABLE2((->),funTc,"->") INSTANCE_TYPEABLE1(IO,ioTc,"IO") #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) --- Types defined in GHC.IOBase +-- Types defined in GHC.MVar INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) #endif @@ -538,7 +540,9 @@ INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) #endif INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +#ifndef __GLASGOW_HASKELL__ INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") +#endif INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") diff --git a/libraries/base/Foreign/C/Error.hs b/libraries/base/Foreign/C/Error.hs index 7c48180289..ea38694612 100644 --- a/libraries/base/Foreign/C/Error.hs +++ b/libraries/base/Foreign/C/Error.hs @@ -108,7 +108,9 @@ import Foreign.Marshal.Error ( void ) import Data.Maybe #if __GLASGOW_HASKELL__ -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Handle.Types import GHC.Num import GHC.Base #elif __HUGS__ diff --git a/libraries/base/Foreign/C/String.hs b/libraries/base/Foreign/C/String.hs index e5c6c8739e..6d46a9e316 100644 --- a/libraries/base/Foreign/C/String.hs +++ b/libraries/base/Foreign/C/String.hs @@ -99,7 +99,7 @@ import Data.Word import GHC.List import GHC.Real import GHC.Num -import GHC.IOBase +import GHC.IO import GHC.Base #else import Data.Char ( chr, ord ) diff --git a/libraries/base/Foreign/C/Types.hs b/libraries/base/Foreign/C/Types.hs index 0304b1580a..44101fc872 100644 --- a/libraries/base/Foreign/C/Types.hs +++ b/libraries/base/Foreign/C/Types.hs @@ -69,7 +69,7 @@ module Foreign.C.Types #ifndef __NHC__ -import {-# SOURCE #-} Foreign.Storable +import Foreign.Storable import Data.Bits ( Bits(..) ) import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Word ( Word8, Word16, Word32, Word64 ) diff --git a/libraries/base/Foreign/Concurrent.hs b/libraries/base/Foreign/Concurrent.hs index 096f22602e..a09c06f0c2 100644 --- a/libraries/base/Foreign/Concurrent.hs +++ b/libraries/base/Foreign/Concurrent.hs @@ -28,7 +28,7 @@ module Foreign.Concurrent ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase ( IO ) +import GHC.IO ( IO ) import GHC.Ptr ( Ptr ) import GHC.ForeignPtr ( ForeignPtr ) import qualified GHC.ForeignPtr diff --git a/libraries/base/Foreign/ForeignPtr.hs b/libraries/base/Foreign/ForeignPtr.hs index 59fcf82d77..9edd436f88 100644 --- a/libraries/base/Foreign/ForeignPtr.hs +++ b/libraries/base/Foreign/ForeignPtr.hs @@ -78,7 +78,7 @@ import Foreign.Storable ( Storable(sizeOf) ) #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO import GHC.Num import GHC.Err ( undefined ) import GHC.ForeignPtr diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs index 19cce12581..574e6a43a9 100644 --- a/libraries/base/Foreign/Marshal/Alloc.hs +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -40,7 +40,8 @@ import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) #ifdef __GLASGOW_HASKELL__ import Foreign.ForeignPtr ( FinalizerPtr ) -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception import GHC.Real import GHC.Ptr import GHC.Err diff --git a/libraries/base/Foreign/Marshal/Array.hs b/libraries/base/Foreign/Marshal/Array.hs index 2297a4ddd2..bac13cd828 100644 --- a/libraries/base/Foreign/Marshal/Array.hs +++ b/libraries/base/Foreign/Marshal/Array.hs @@ -68,7 +68,7 @@ import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes) import Foreign.Marshal.Utils (copyBytes, moveBytes) #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase +import GHC.IO import GHC.Num import GHC.List import GHC.Err diff --git a/libraries/base/Foreign/Marshal/Error.hs b/libraries/base/Foreign/Marshal/Error.hs index 3d72956fa3..5bc2f34e80 100644 --- a/libraries/base/Foreign/Marshal/Error.hs +++ b/libraries/base/Foreign/Marshal/Error.hs @@ -37,7 +37,8 @@ import System.IO.Error #endif import GHC.Base import GHC.Num -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception #endif -- exported functions diff --git a/libraries/base/Foreign/Marshal/Pool.hs b/libraries/base/Foreign/Marshal/Pool.hs index 540c16441a..9c07558a3d 100644 --- a/libraries/base/Foreign/Marshal/Pool.hs +++ b/libraries/base/Foreign/Marshal/Pool.hs @@ -48,8 +48,8 @@ module Foreign.Marshal.Pool ( import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) import GHC.Exception ( throw ) -import GHC.IOBase ( IO, IORef, newIORef, readIORef, writeIORef, - block, unblock, catchAny ) +import GHC.IO ( IO, block, unblock, catchAny ) +import GHC.IORef ( IORef, newIORef, readIORef, writeIORef ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) #else diff --git a/libraries/base/Foreign/Marshal/Utils.hs b/libraries/base/Foreign/Marshal/Utils.hs index 4aa0e74cb2..85d802e409 100644 --- a/libraries/base/Foreign/Marshal/Utils.hs +++ b/libraries/base/Foreign/Marshal/Utils.hs @@ -53,7 +53,7 @@ import Foreign.C.Types ( CSize ) import Foreign.Marshal.Alloc ( malloc, alloca ) #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase +import GHC.IO import GHC.Real ( fromIntegral ) import GHC.Num import GHC.Base diff --git a/libraries/base/Foreign/Ptr.hs b/libraries/base/Foreign/Ptr.hs index 7c83326e40..f6fac7d550 100644 --- a/libraries/base/Foreign/Ptr.hs +++ b/libraries/base/Foreign/Ptr.hs @@ -50,7 +50,7 @@ module Foreign.Ptr ( #ifdef __GLASGOW_HASKELL__ import GHC.Ptr -import GHC.IOBase +import GHC.IO import GHC.Base import GHC.Num import GHC.Read diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs index dfcafa618a..65b4193ae6 100644 --- a/libraries/base/Foreign/Storable.hs +++ b/libraries/base/Foreign/Storable.hs @@ -47,7 +47,7 @@ import GHC.Int import GHC.Word import GHC.Ptr import GHC.Err -import GHC.IOBase +import GHC.IO import GHC.Base #else import Data.Int diff --git a/libraries/base/Foreign/Storable.hs-boot b/libraries/base/Foreign/Storable.hs-boot deleted file mode 100644 index c83715bf5d..0000000000 --- a/libraries/base/Foreign/Storable.hs-boot +++ /dev/null @@ -1,22 +0,0 @@ - -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module Foreign.Storable where - -import GHC.Base -import GHC.Int -import GHC.Word - -class Storable a - -instance Storable Int8 -instance Storable Int16 -instance Storable Int32 -instance Storable Int64 -instance Storable Word8 -instance Storable Word16 -instance Storable Word32 -instance Storable Word64 -instance Storable Float -instance Storable Double - diff --git a/libraries/base/GHC/Conc.lhs b/libraries/base/GHC/Conc.lhs index b53bf54b91..2d623081b0 100644 --- a/libraries/base/GHC/Conc.lhs +++ b/libraries/base/GHC/Conc.lhs @@ -50,17 +50,6 @@ module GHC.Conc , threadWaitRead -- :: Int -> IO () , threadWaitWrite -- :: Int -> IO () - -- * MVars - , MVar(..) - , newMVar -- :: a -> IO (MVar a) - , newEmptyMVar -- :: IO (MVar a) - , takeMVar -- :: MVar a -> IO a - , putMVar -- :: MVar a -> a -> IO () - , tryTakeMVar -- :: MVar a -> IO (Maybe a) - , tryPutMVar -- :: MVar a -> a -> IO Bool - , isEmptyMVar -- :: MVar a -> IO Bool - , addMVarFinalizer -- :: MVar a -> IO () -> IO () - -- * TVars , STM(..) , atomically -- :: STM a -> IO a @@ -78,6 +67,7 @@ module GHC.Conc , unsafeIOToSTM -- :: IO a -> STM a -- * Miscellaneous + , withMVar #ifdef mingw32_HOST_OS , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) @@ -121,11 +111,17 @@ import Control.Monad import Data.Maybe import GHC.Base -import {-# SOURCE #-} GHC.Handle -import GHC.IOBase +import {-# SOURCE #-} GHC.IO.Handle ( hFlush ) +import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout ) +import GHC.IO +import GHC.IO.Exception +import GHC.Exception +import GHC.IORef +import GHC.MVar import GHC.Num ( Num(..) ) import GHC.Real ( fromIntegral ) #ifndef mingw32_HOST_OS +import GHC.IOArray import GHC.Arr ( inRange ) #endif #ifdef mingw32_HOST_OS @@ -136,10 +132,8 @@ import GHC.Ptr ( plusPtr, FunPtr(..) ) import GHC.Read ( Read ) import GHC.Enum ( Enum ) #endif -import GHC.Exception ( SomeException(..), throw ) import GHC.Pack ( packCString# ) import GHC.Ptr ( Ptr(..) ) -import GHC.STRef import GHC.Show ( Show(..), showString ) import Data.Typeable import GHC.Err @@ -599,111 +593,19 @@ writeTVar (TVar tvar#) val = STM $ \s1# -> \end{code} -%************************************************************************ -%* * -\subsection[mvars]{M-Structures} -%* * -%************************************************************************ - -M-Vars are rendezvous points for concurrent threads. They begin -empty, and any attempt to read an empty M-Var blocks. When an M-Var -is written, a single blocked thread may be freed. Reading an M-Var -toggles its state from full back to empty. Therefore, any value -written to an M-Var may only be read once. Multiple reads and writes -are allowed, but there must be at least one read between any two -writes. +MVar utilities \begin{code} ---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) - --- |Create an 'MVar' which is initially empty. -newEmptyMVar :: IO (MVar a) -newEmptyMVar = IO $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - --- |Create an 'MVar' which contains the supplied value. -newMVar :: a -> IO (MVar a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- |Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', --- the 'MVar' is left empty. --- --- There are two further important properties of 'takeMVar': --- --- * 'takeMVar' is single-wakeup. That is, if there are multiple --- threads blocked in 'takeMVar', and the 'MVar' becomes full, --- only one thread will be woken up. The runtime guarantees that --- the woken thread completes its 'takeMVar' operation. --- --- * When multiple threads are blocked on an 'MVar', they are --- woken up in FIFO order. This is useful for providing --- fairness properties of abstractions built using 'MVar's. --- -takeMVar :: MVar a -> IO a -takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# - --- |Put a value into an 'MVar'. If the 'MVar' is currently full, --- 'putMVar' will wait until it becomes empty. --- --- There are two further important properties of 'putMVar': --- --- * 'putMVar' is single-wakeup. That is, if there are multiple --- threads blocked in 'putMVar', and the 'MVar' becomes empty, --- only one thread will be woken up. The runtime guarantees that --- the woken thread completes its 'putMVar' operation. --- --- * When multiple threads are blocked on an 'MVar', they are --- woken up in FIFO order. This is useful for providing --- fairness properties of abstractions built using 'MVar's. --- -putMVar :: MVar a -> a -> IO () -putMVar (MVar mvar#) x = IO $ \ s# -> - case putMVar# mvar# x s# of - s2# -> (# s2#, () #) - --- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function --- returns immediately, with 'Nothing' if the 'MVar' was empty, or --- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', --- the 'MVar' is left empty. -tryTakeMVar :: MVar a -> IO (Maybe a) -tryTakeMVar (MVar m) = IO $ \ s -> - case tryTakeMVar# m s of - (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty - (# s', _, a #) -> (# s', Just a #) -- MVar is full - --- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function --- attempts to put the value @a@ into the 'MVar', returning 'True' if --- it was successful, or 'False' otherwise. -tryPutMVar :: MVar a -> a -> IO Bool -tryPutMVar (MVar mvar#) x = IO $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) - --- |Check whether a given 'MVar' is empty. --- --- Notice that the boolean value returned is just a snapshot of --- the state of the MVar. By the time you get to react on its result, --- the MVar may have been filled (or emptied) - so be extremely --- careful when using this operation. Use 'tryTakeMVar' instead if possible. -isEmptyMVar :: MVar a -> IO Bool -isEmptyMVar (MVar mv#) = IO $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) - --- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and --- "System.Mem.Weak" for more about finalizers. -addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = - IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + block $ do + a <- takeMVar m + b <- catchAny (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a + return b \end{code} - %************************************************************************ %* * \subsection{Thread waiting} @@ -898,10 +800,6 @@ delayTime (DelaySTM t _) = t type USecs = Word64 --- XXX: move into GHC.IOBase from Data.IORef? -atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s - foreign import ccall unsafe "getUSecOfDay" getUSecOfDay :: IO USecs @@ -1408,14 +1306,4 @@ setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler getUncaughtExceptionHandler :: IO (SomeException -> IO ()) getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler - - -withMVar :: MVar a -> (a -> IO b) -> IO b -withMVar m io = - block $ do - a <- takeMVar m - b <- catchAny (unblock (io a)) - (\e -> do putMVar m a; throw e) - putMVar m a - return b \end{code} diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hs index 7587d94e71..af115b8642 100644 --- a/libraries/base/GHC/ConsoleHandler.hs +++ b/libraries/base/GHC/ConsoleHandler.hs @@ -34,10 +34,13 @@ import Prelude -- necessary to get dependencies right import Foreign import Foreign.C -import GHC.IOBase +import GHC.IO.FD +import GHC.IO.Exception +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals import GHC.Conc -import GHC.Handle -import Control.Exception (onException) +import Control.Concurrent.MVar +import Data.Typeable data Handler = Default @@ -134,19 +137,16 @@ foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone" flushConsole :: Handle -> IO () flushConsole h = - wantReadableHandle "flushConsole" h $ \ h_ -> - throwErrnoIfMinus1Retry_ "flushConsole" - (flush_console_fd (fromIntegral (haFD h_))) + wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} -> + case cast dev of + Nothing -> ioException $ + IOError (Just h) IllegalOperation "flushConsole" + "handle is not a file descriptor" Nothing Nothing + Just fd -> do + throwErrnoIfMinus1Retry_ "flushConsole" $ + flush_console_fd (fromIntegral (fdFD fd)) foreign import ccall unsafe "consUtils.h flush_input_console__" flush_console_fd :: CInt -> IO CInt --- XXX Copied from Control.Concurrent.MVar -modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b -modifyMVar m io = - block $ do - a <- takeMVar m - (a',b) <- unblock (io a) `onException` putMVar m a - putMVar m a' - return b #endif /* mingw32_HOST_OS */ diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 25dc0fad0b..f3601ba0a5 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -42,7 +42,8 @@ import Data.Typeable import GHC.Show import GHC.List ( null ) import GHC.Base -import GHC.IOBase +import GHC.IO +import GHC.IORef import GHC.STRef ( STRef(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Err diff --git a/libraries/base/GHC/Handle.hs b/libraries/base/GHC/Handle.hs index c962edce3d..5d231eab32 100644 --- a/libraries/base/GHC/Handle.hs +++ b/libraries/base/GHC/Handle.hs @@ -1,11 +1,4 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} -{-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_HADDOCK hide #-} - -#undef DEBUG_DUMP -#undef DEBUG - ----------------------------------------------------------------------------- -- | -- Module : GHC.Handle @@ -16,31 +9,32 @@ -- Stability : internal -- Portability : non-portable -- --- This module defines the basic operations on I\/O \"handles\". +-- Backwards-compatibility interface -- ----------------------------------------------------------------------------- -- #hide -module GHC.Handle ( + +module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle.Base instead" #-} ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, - newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, - fillReadBuffer, fillReadBufferWithoutBlocking, - readRawBuffer, readRawBufferPtr, - readRawBufferNoBlock, readRawBufferPtrNoBlock, - writeRawBuffer, writeRawBufferPtr, - -#ifndef mingw32_HOST_OS - unlockFile, -#endif +-- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, +-- flushWriteBufferOnly, flushWriteBuffer, +-- flushReadBuffer, +-- fillReadBuffer, fillReadBufferWithoutBlocking, +-- readRawBuffer, readRawBufferPtr, +-- readRawBufferNoBlock, readRawBufferPtrNoBlock, +-- writeRawBuffer, writeRawBufferPtr, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle', - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode, + IOMode(..), openFile, openBinaryFile, +-- fdToHandle_stat, + fdToHandle, fdToHandle', + hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead_, + hSetBuffering, hSetBinaryMode, hFlush, hDuplicate, hDuplicateTo, hClose, hClose_help, @@ -53,1791 +47,9 @@ module GHC.Handle ( hShow, -#ifdef DEBUG_DUMP - puts, -#endif - ) where -import Control.Monad -import Data.Maybe -import Foreign -import Foreign.C -import System.IO.Error -import System.Posix.Internals -import System.Posix.Types - -import GHC.Real - -import GHC.Arr -import GHC.Base -import GHC.Read ( Read ) -import GHC.List -import GHC.IOBase -import GHC.Exception -import GHC.Enum -import GHC.Num ( Integer, Num(..) ) -import GHC.Show -#if defined(DEBUG_DUMP) -import GHC.Pack -#endif - -import GHC.Conc - --- ----------------------------------------------------------------------------- --- TODO: - --- hWaitForInput blocks (should use a timeout) - --- unbuffered hGetLine is a bit dodgy - --- hSetBuffering: can't change buffering on a stream, --- when the read buffer is non-empty? (no way to flush the buffer) - --- --------------------------------------------------------------------------- --- Are files opened by default in text or binary mode, if the user doesn't --- specify? - -dEFAULT_OPEN_IN_BINARY_MODE :: Bool -dEFAULT_OPEN_IN_BINARY_MODE = False - --- --------------------------------------------------------------------------- --- Creating a new handle - -newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle -newFileHandle filepath finalizer hc = do - m <- newMVar hc - addMVarFinalizer m (finalizer m) - return (FileHandle filepath m) - --- --------------------------------------------------------------------------- --- Working with Handles - -{- -In the concurrent world, handles are locked during use. This is done -by wrapping an MVar around the handle which acts as a mutex over -operations on the handle. - -To avoid races, we use the following bracketing operations. The idea -is to obtain the lock, do some operation and replace the lock again, -whether the operation succeeded or failed. We also want to handle the -case where the thread receives an exception while processing the IO -operation: in these cases we also want to relinquish the lock. - -There are three versions of @withHandle@: corresponding to the three -possible combinations of: - - - the operation may side-effect the handle - - the operation may return a result - -If the operation generates an error or an exception is raised, the -original handle is always replaced [ this is the case at the moment, -but we might want to revisit this in the future --SDM ]. --} - -{-# INLINE withHandle #-} -withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act -withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act - -withHandle' :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h' - putMVar m h' - return v - -{-# INLINE withHandle_ #-} -withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a -withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act -withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act - -withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h_ - putMVar m h_ - return v - -withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () -withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act -withAllHandles__ fun h@(DuplexHandle _ r w) act = do - withHandle__' fun h r act - withHandle__' fun h w act - -withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) - -> IO () -withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkBufferInvariants h' - putMVar m h' - return () - -augmentIOError :: IOException -> String -> Handle -> IOException -augmentIOError ioe@IOError{ ioe_filename = fp } fun h - = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } - where filepath - | Just _ <- fp = fp - | otherwise = case h of - FileHandle path _ -> Just path - DuplexHandle path _ _ -> Just path - --- --------------------------------------------------------------------------- --- Wrapper for write operations. - -wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantWritableHandle fun h@(FileHandle _ m) act - = wantWritableHandle' fun h m act -wantWritableHandle fun h@(DuplexHandle _ _ m) act - = wantWritableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkWritableHandle - -wantWritableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantWritableHandle' fun h m act - = withHandle_' fun h m (checkWritableHandle act) - -checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkWritableHandle act handle_ - = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - ReadHandle -> ioe_notWritable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - new_buf <- - if not (bufferIsWritable buf) - then do b <- flushReadBuffer (haFD handle_) buf - return b{ bufState=WriteBuffer } - else return buf - writeIORef ref new_buf - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for read operations. - -wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantReadableHandle fun h@(FileHandle _ m) act - = wantReadableHandle' fun h m act -wantReadableHandle fun h@(DuplexHandle _ m _) act - = wantReadableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkReadableHandle - -wantReadableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantReadableHandle' fun h m act - = withHandle_' fun h m (checkReadableHandle act) - -checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkReadableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef ref new_buf{ bufState=ReadBuffer } - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for seek operations. - -wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = - ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing Nothing) -wantSeekableHandle fun h@(FileHandle _ m) act = - withHandle_' fun h m (checkSeekableHandle act) - -checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a -checkSeekableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ - | otherwise -> ioe_notSeekable_notBin - --- ----------------------------------------------------------------------------- --- Handy IOErrors - -ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, - ioe_notSeekable, ioe_notSeekable_notBin :: IO a - -ioe_closedHandle = ioException - (IOError Nothing IllegalOperation "" - "handle is closed" Nothing Nothing) -ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing Nothing) -ioe_notReadable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing Nothing) -ioe_notWritable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing Nothing) -ioe_notSeekable = ioException - (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing Nothing) -ioe_notSeekable_notBin = ioException - (IOError Nothing IllegalOperation "" - "seek operations on text-mode handles are not allowed on this platform" - Nothing Nothing) - -ioe_finalizedHandle :: FilePath -> Handle__ -ioe_finalizedHandle fp = throw - (IOError Nothing IllegalOperation "" - "handle is finalized" Nothing (Just fp)) - -ioe_bufsiz :: Int -> IO a -ioe_bufsiz n = ioException - (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) - -- 9 => should be parens'ified. - --- ----------------------------------------------------------------------------- --- Handle Finalizers - --- For a duplex handle, we arrange that the read side points to the write side --- (and hence keeps it alive if the read side is alive). This is done by --- having the haOtherSide field of the read side point to the read side. --- The finalizer is then placed on the write side, and the handle only gets --- finalized once, when both sides are no longer required. - --- NOTE about finalized handles: It's possible that a handle can be --- finalized and then we try to use it later, for example if the --- handle is referenced from another finalizer, or from a thread that --- has become unreferenced and then resurrected (arguably in the --- latter case we shouldn't finalize the Handle...). Anyway, --- we try to emit a helpful message which is better than nothing. - -stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () -stdHandleFinalizer fp m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - putMVar m (ioe_finalizedHandle fp) - -handleFinalizer :: FilePath -> MVar Handle__ -> IO () -handleFinalizer fp m = do - handle_ <- takeMVar m - case haType handle_ of - ClosedHandle -> return () - _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return () - -- ignore errors and async exceptions, and close the - -- descriptor anyway... - hClose_handle_ handle_ - return () - putMVar m (ioe_finalizedHandle fp) - --- --------------------------------------------------------------------------- --- Grimy buffer operations - -checkBufferInvariants :: Handle__ -> IO () -#ifdef DEBUG -checkBufferInvariants h_ = do - let ref = haBuffer h_ - Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref - if not ( - size > 0 - && r <= w - && w <= size - && ( r /= w || (r == 0 && w == 0) ) - && ( state /= WriteBuffer || r == 0 ) - && ( state /= WriteBuffer || w < size ) -- write buffer is never full - ) - then error "buffer invariant violation" - else return () -#else -checkBufferInvariants _ = return () -#endif - -newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer -newEmptyBuffer b state size - = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } - -allocateBuffer :: Int -> BufferState -> IO Buffer -allocateBuffer sz@(I# size) state = IO $ \s -> - -- We sometimes need to pass the address of this buffer to - -- a "safe" foreign call, hence it must be immovable. - case newPinnedByteArray# size s of { (# s', b #) -> - (# s', newEmptyBuffer b state sz #) } - -writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int -writeCharIntoBuffer slab (I# off) (C# c) - = IO $ \s -> case writeCharArray# slab off c s of - s' -> (# s', I# (off +# 1#) #) - -readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) -readCharFromBuffer slab (I# off) - = IO $ \s -> case readCharArray# slab off s of - (# s', c #) -> (# s', (C# c, I# (off +# 1#)) #) - -getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) -getBuffer fd state = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state - ioref <- newIORef buffer - is_tty <- fdIsTTY fd - - let buffer_mode - | is_tty = LineBuffering - | otherwise = BlockBuffering Nothing - - return (ioref, buffer_mode) - -mkUnBuffer :: IO (IORef Buffer) -mkUnBuffer = do - buffer <- allocateBuffer 1 ReadBuffer - newIORef buffer - --- flushWriteBufferOnly flushes the buffer iff it contains pending write data. -flushWriteBufferOnly :: Handle__ -> IO () -flushWriteBufferOnly h_ = do - let fd = haFD h_ - ref = haBuffer h_ - buf <- readIORef ref - new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd (haIsStream h_) buf - else return buf - writeIORef ref new_buf - --- flushBuffer syncs the file with the buffer, including moving the --- file pointer backwards in the case of a read buffer. -flushBuffer :: Handle__ -> IO () -flushBuffer h_ = do - let ref = haBuffer h_ - buf <- readIORef ref - - flushed_buf <- - case bufState buf of - ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf - - writeIORef ref flushed_buf - --- When flushing a read buffer, we seek backwards by the number of --- characters in the buffer. The file descriptor must therefore be --- seekable: attempting to flush the read buffer on an unseekable --- handle is not allowed. - -flushReadBuffer :: FD -> Buffer -> IO Buffer -flushReadBuffer fd buf - | bufferEmpty buf = return buf - | otherwise = do - let off = negate (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") -# endif - throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek fd (fromIntegral off) sEEK_CUR) - return buf{ bufWPtr=0, bufRPtr=0 } - -flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer -flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = - seq fd $ do -- strictness hack - let bytes = w - r -#ifdef DEBUG_DUMP - puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") -#endif - if bytes == 0 - then return (buf{ bufRPtr=0, bufWPtr=0 }) - else do - res <- writeRawBuffer "flushWriteBuffer" fd is_stream b - (fromIntegral r) (fromIntegral bytes) - let res' = fromIntegral res - if res' < bytes - then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) - else return buf{ bufRPtr=0, bufWPtr=0 } - -fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line is_stream buf b w size - --- For a line buffer, we just get the first chunk of data to arrive, --- and don't wait for the whole buffer to be full (but we *do* wait --- until some data arrives). This isn't really line buffering, but it --- appears to be what GHC has done for a long time, and I suspect it --- is more useful than line buffering in most cases. - -fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int - -> IO Buffer -fillReadBufferLoop fd is_line is_stream buf b w size = do - let bytes = size - w - if bytes == 0 -- buffer full? - then return buf{ bufRPtr=0, bufWPtr=w } - else do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") -#endif - res <- readRawBuffer "fillReadBuffer" fd is_stream b - (fromIntegral w) (fromIntegral bytes) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") -#endif - if res' == 0 - then if w == 0 - then ioe_EOF - else return buf{ bufRPtr=0, bufWPtr=w } - else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line is_stream buf b (w+res') size - else return buf{ bufRPtr=0, bufWPtr=w+res' } - - -fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer -fillReadBufferWithoutBlocking fd is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n") -#endif - res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b - 0 (fromIntegral size) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n") -#endif - return buf{ bufRPtr=0, bufWPtr=res' } - --- Low level routines for reading/writing to (raw)buffers: - -#ifndef mingw32_HOST_OS - -{- -NOTE [nonblock]: - -Unix has broken semantics when it comes to non-blocking I/O: you can -set the O_NONBLOCK flag on an FD, but it applies to the all other FDs -attached to the same underlying file, pipe or TTY; there's no way to -have private non-blocking behaviour for an FD. See bug #724. - -We fix this by only setting O_NONBLOCK on FDs that we create; FDs that -come from external sources or are exposed externally are left in -blocking mode. This solution has some problems though. We can't -completely simulate a non-blocking read without O_NONBLOCK: several -cases are wrong here. The cases that are wrong: - - * reading/writing to a blocking FD in non-threaded mode. - In threaded mode, we just make a safe call to read(). - In non-threaded mode we call select() before attempting to read, - but that leaves a small race window where the data can be read - from the file descriptor before we issue our blocking read(). - * readRawBufferNoBlock for a blocking FD - -NOTE [2363]: - -In the threaded RTS we could just make safe calls to read()/write() -for file descriptors in blocking mode without worrying about blocking -other threads, but the problem with this is that the thread will be -uninterruptible while it is blocked in the foreign call. See #2363. -So now we always call fdReady() before reading, and if fdReady -indicates that there's no data, we call threadWaitRead. - --} - -readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBuffer loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- throwErrnoIfMinus1 loc - (unsafe_fdReady (fromIntegral fd) 0 0 0) - if r /= 0 - then read - else do threadWaitRead (fromIntegral fd); read - where - do_read call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitRead (fromIntegral fd)) - read = if threaded then safe_read else unsafe_read - unsafe_read = do_read (read_rawBuffer fd buf off len) - safe_read = do_read (safe_read_rawBuffer fd buf off len) - -readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- throwErrnoIfMinus1 loc - (unsafe_fdReady (fromIntegral fd) 0 0 0) - if r /= 0 - then read - else do threadWaitRead (fromIntegral fd); read - where - do_read call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitRead (fromIntegral fd)) - read = if threaded then safe_read else unsafe_read - unsafe_read = do_read (read_off fd buf off len) - safe_read = do_read (safe_read_off fd buf off len) - -readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0 - if r /= 0 then safe_read - else return 0 - -- XXX see note [nonblock] - where - do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0) - unsafe_read = do_read (read_rawBuffer fd buf off len) - safe_read = do_read (safe_read_rawBuffer fd buf off len) - -readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtrNoBlock loc fd is_nonblock buf off len - | is_nonblock = unsafe_read -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0 - if r /= 0 then safe_read - else return 0 - -- XXX see note [nonblock] - where - do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0) - unsafe_read = do_read (read_off fd buf off len) - safe_read = do_read (safe_read_off fd buf off len) - -writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_nonblock buf off len - | is_nonblock = unsafe_write -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0 - if r /= 0 - then write - else do threadWaitWrite (fromIntegral fd); write - where - do_write call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitWrite (fromIntegral fd)) - write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_rawBuffer fd buf off len) - safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len) - -writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_nonblock buf off len - | is_nonblock = unsafe_write -- unsafe is ok, it can't block - | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0 - if r /= 0 - then write - else do threadWaitWrite (fromIntegral fd); write - where - do_write call = throwErrnoIfMinus1RetryMayBlock loc call - (threadWaitWrite (fromIntegral fd)) - write = if threaded then safe_write else unsafe_write - unsafe_write = do_write (write_off fd buf off len) - safe_write = do_write (safe_write_off (fromIntegral fd) buf off len) - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "fdReady" - unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt - -#else /* mingw32_HOST_OS.... */ - -readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBuffer loc fd is_stream buf off len - | threaded = blockingReadRawBuffer loc fd is_stream buf off len - | otherwise = asyncReadRawBuffer loc fd is_stream buf off len - -readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtr loc fd is_stream buf off len - | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len - | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len - -writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -writeRawBuffer loc fd is_stream buf off len - | threaded = blockingWriteRawBuffer loc fd is_stream buf off len - | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len - -writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -writeRawBufferPtr loc fd is_stream buf off len - | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len - | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len - --- ToDo: we don't have a non-blocking primitve read on Win32 -readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt -readRawBufferNoBlock = readRawBuffer - -readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt -readRawBufferPtrNoBlock = readRawBufferPtr --- Async versions of the read/write primitives, for the non-threaded RTS - -asyncReadRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -asyncReadRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncReadRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt - -> IO CInt -asyncReadRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncWriteRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -asyncWriteRawBuffer loc fd is_stream buf off len = do - (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) off buf - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - -asyncWriteRawBufferPtr :: String -> FD -> Bool -> CString -> Int -> CInt - -> IO CInt -asyncWriteRawBufferPtr loc fd is_stream buf off len = do - (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) - (fromIntegral len) (buf `plusPtr` off) - if l == (-1) - then - ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) - else return (fromIntegral l) - --- Blocking versions of the read/write primitives, for the threaded RTS - -blockingReadRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -blockingReadRawBuffer loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_recv_rawBuffer fd buf off len -blockingReadRawBuffer loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_read_rawBuffer fd buf off len - -blockingReadRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt - -> IO CInt -blockingReadRawBufferPtr loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_recv_off fd buf off len -blockingReadRawBufferPtr loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_read_off fd buf off len - -blockingWriteRawBuffer :: String -> CInt -> Bool -> RawBuffer -> Int -> CInt - -> IO CInt -blockingWriteRawBuffer loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_send_rawBuffer fd buf off len -blockingWriteRawBuffer loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_write_rawBuffer fd buf off len - -blockingWriteRawBufferPtr :: String -> CInt -> Bool -> CString -> Int -> CInt - -> IO CInt -blockingWriteRawBufferPtr loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - safe_send_off fd buf off len -blockingWriteRawBufferPtr loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - safe_write_off fd buf off len - --- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. --- These calls may block, but that's ok. - -foreign import ccall safe "__hscore_PrelHandle_recv" - safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_recv" - safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_send" - safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_send" - safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - -#endif - -foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool - -foreign import ccall safe "__hscore_PrelHandle_read" - safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_read" - safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_write" - safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_write" - safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt - --- --------------------------------------------------------------------------- --- Standard Handles - --- Three handles are allocated during program initialisation. The first --- two manage input or output from the Haskell program's standard input --- or output channel respectively. The third manages output to the --- standard error channel. These handles are initially open. - -fd_stdin, fd_stdout, fd_stderr :: FD -fd_stdin = 0 -fd_stdout = 1 -fd_stderr = 2 - --- | A handle managing input from the Haskell program's standard input channel. -stdin :: Handle -stdin = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - (buf, bmode) <- getBuffer fd_stdin ReadBuffer - mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode - --- | A handle managing output to the Haskell program's standard output channel. -stdout :: Handle -stdout = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - (buf, bmode) <- getBuffer fd_stdout WriteBuffer - mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode - --- | A handle managing output to the Haskell program's standard error channel. -stderr :: Handle -stderr = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on standard handles, because it may - -- confuse other applications attached to the same TTY/pipe - -- see Note [nonblock] - buf <- mkUnBuffer - mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering - --- --------------------------------------------------------------------------- --- Opening and Closing Files - -addFilePathToIOError :: String -> FilePath -> IOException -> IOException -addFilePathToIOError fun fp ioe - = ioe{ ioe_location = fun, ioe_filename = Just fp } - --- | Computation 'openFile' @file mode@ allocates and returns a new, open --- handle to manage the file @file@. It manages input if @mode@ --- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', --- and both input and output if mode is 'ReadWriteMode'. --- --- If the file does not exist and it is opened for output, it should be --- created as a new file. If @mode@ is 'WriteMode' and the file --- already exists, then it should be truncated to zero length. --- Some operating systems delete empty files, so there is no guarantee --- that the file will exist following an 'openFile' with @mode@ --- 'WriteMode' unless it is subsequently written to successfully. --- The handle is positioned at the end of the file if @mode@ is --- 'AppendMode', and otherwise at the beginning (in which case its --- internal position is 0). --- The initial buffer mode is implementation-dependent. --- --- This operation may fail with: --- --- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; --- --- * 'isDoesNotExistError' if the file does not exist; or --- --- * 'isPermissionError' if the user does not have permission to open the file. --- --- Note: if you will be working with files containing binary data, you'll want to --- be using 'openBinaryFile'. -openFile :: FilePath -> IOMode -> IO Handle -openFile fp im = - catch - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) - (\e -> ioError (addFilePathToIOError "openFile" fp e)) - --- | Like 'openFile', but open the file in binary mode. --- On Windows, reading a file in text mode (which is the default) --- will translate CRLF to LF, and writing will translate LF to CRLF. --- This is usually what you want with text files. With binary files --- this is undesirable; also, as usual under Microsoft operating systems, --- text mode treats control-Z as EOF. Binary mode turns off all special --- treatment of end-of-line and end-of-file characters. --- (See also 'hSetBinaryMode'.) - -openBinaryFile :: FilePath -> IOMode -> IO Handle -openBinaryFile fp m = - catch - (openFile' fp m True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) - -openFile' :: String -> IOMode -> Bool -> IO Handle -openFile' filepath mode binary = - withCString filepath $ \ f -> - - let - oflags1 = case mode of - ReadMode -> read_flags -#ifdef mingw32_HOST_OS - WriteMode -> write_flags .|. o_TRUNC -#else - WriteMode -> write_flags -#endif - ReadWriteMode -> rw_flags - AppendMode -> append_flags - - binary_flags - | binary = o_BINARY - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - in do - - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) - - stat@(fd_type,_,_) <- fdStat fd - - h <- fdToHandle_stat fd (Just stat) - False -- set_non_blocking - True -- is_non_blocking - False -- is_socket - filepath mode binary - `catchAny` \e -> do c_close fd; throw e - -- NB. don't forget to close the FD if fdToHandle' fails, otherwise - -- this FD leaks. - -- ASSERT: if we just created the file, then fdToHandle' won't fail - -- (so we don't need to worry about removing the newly created file - -- in the event of an error). - -#ifndef mingw32_HOST_OS - -- we want to truncate() if this is an open in WriteMode, but only - -- if the target is a RegularFile. ftruncate() fails on special files - -- like /dev/null. - if mode == WriteMode && fd_type == RegularFile - then throwErrnoIf (/=0) "openFile" - (c_ftruncate fd 0) - else return 0 -#endif - return h - - -std_flags, output_flags, read_flags, write_flags, rw_flags, - append_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY -rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND - --- --------------------------------------------------------------------------- --- fdToHandle - -fdToHandle_stat :: FD - -> Maybe (FDType, CDev, CIno) - -> Bool -- set_non_blocking - -> Bool -- is_non_blocking - -> Bool -- is_socket - -> FilePath - -> IOMode - -> Bool - -> IO Handle - -fdToHandle_stat fd mb_stat set_non_blocking is_non_blocking is_socket - filepath mode binary = do - -#ifdef mingw32_HOST_OS - -- On Windows, the is_stream flag indicates that the Handle is a socket - let is_stream = is_socket -#else - when set_non_blocking $ setNonBlockingFD fd - -- turn on non-blocking mode - - -- On Unix, the is_stream flag indicates that the FD is in non-blocking mode - let is_stream = is_non_blocking || set_non_blocking -#endif - - let (ha_type, write) = - case mode of - ReadMode -> ( ReadHandle, False ) - WriteMode -> ( WriteHandle, True ) - ReadWriteMode -> ( ReadWriteHandle, True ) - AppendMode -> ( AppendHandle, True ) - - -- open() won't tell us if it was a directory if we only opened for - -- reading, so check again. - (fd_type,dev,ino) <- - case mb_stat of - Just x -> return x - Nothing -> fdStat fd - - case fd_type of - Directory -> - ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing Nothing) - - -- regular files need to be locked - RegularFile -> do -#ifndef mingw32_HOST_OS - -- On Windows we use explicit exclusion via sopen() to implement - -- this locking (see __hscore_open()); on Unix we have to - -- implment it in the RTS. - r <- lockFile fd dev ino (fromBool write) - when (r == -1) $ - ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing Nothing) -#endif - mkFileHandle fd is_stream filepath ha_type binary - - Stream - -- only *Streams* can be DuplexHandles. Other read/write - -- Handles must share a buffer. - | ReadWriteHandle <- ha_type -> - mkDuplexHandle fd is_stream filepath binary - | otherwise -> - mkFileHandle fd is_stream filepath ha_type binary - - RawDevice -> - mkFileHandle fd is_stream filepath ha_type binary - --- | Old API kept to avoid breaking clients -fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool - -> IO Handle -fdToHandle' fd mb_type is_socket filepath mode binary - = do - let mb_stat = case mb_type of - Nothing -> Nothing - -- fdToHandle_stat will do the stat: - Just RegularFile -> Nothing - -- no stat required for streams etc.: - Just other -> Just (other,0,0) - fdToHandle_stat fd mb_stat - is_socket -- set_non_blocking - False -- is_non_blocking - is_socket -- is_socket - filepath mode binary - -fdToHandle :: FD -> IO Handle -fdToHandle fd = do - mode <- fdGetMode fd - let fd_str = "<file descriptor: " ++ show fd ++ ">" - fdToHandle_stat fd Nothing - False -- set_non_blocking - False -- is_non_blocking - False -- is_socket (guess XXX) - fd_str mode True{-bin mode-} - -#ifndef mingw32_HOST_OS -foreign import ccall unsafe "lockFile" - lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt - -foreign import ccall unsafe "unlockFile" - unlockFile :: CInt -> IO CInt -#endif - -mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode - -> IO Handle -mkStdHandle fd filepath ha_type buf bmode = do - spares <- newIORef BufferListNil - newFileHandle filepath (stdHandleFinalizer filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haIsStream = False, -- means FD is blocking on Unix - haBufferMode = bmode, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd is_stream filepath ha_type binary = do - (buf, bmode) <- getBuffer fd (initBufferState ha_type) - -#ifdef mingw32_HOST_OS - -- On Windows, if this is a read/write handle and we are in text mode, - -- turn off buffering. We don't correctly handle the case of switching - -- from read mode to write mode on a buffered text-mode handle, see bug - -- \#679. - bmode2 <- case ha_type of - ReadWriteHandle | not binary -> return NoBuffering - _other -> return bmode -#else - let bmode2 = bmode -#endif - - spares <- newIORef BufferListNil - newFileHandle filepath (handleFinalizer filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = bmode2, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd is_stream filepath binary = do - (w_buf, w_bmode) <- getBuffer fd WriteBuffer - w_spares <- newIORef BufferListNil - let w_handle_ = - Handle__ { haFD = fd, - haType = WriteHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = w_bmode, - haBuffer = w_buf, - haBuffers = w_spares, - haOtherSide = Nothing - } - write_side <- newMVar w_handle_ - - (r_buf, r_bmode) <- getBuffer fd ReadBuffer - r_spares <- newIORef BufferListNil - let r_handle_ = - Handle__ { haFD = fd, - haType = ReadHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = r_bmode, - haBuffer = r_buf, - haBuffers = r_spares, - haOtherSide = Just write_side - } - read_side <- newMVar r_handle_ - - addMVarFinalizer write_side (handleFinalizer filepath write_side) - return (DuplexHandle filepath read_side write_side) - -initBufferState :: HandleType -> BufferState -initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer - --- --------------------------------------------------------------------------- --- Closing a handle - --- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the --- computation finishes, if @hdl@ is writable its buffer is flushed as --- for 'hFlush'. --- Performing 'hClose' on a handle that has already been closed has no effect; --- doing so is not an error. All other operations on a closed handle will fail. --- If 'hClose' fails for any reason, any further operations (apart from --- 'hClose') on the handle will still fail as if @hdl@ had been successfully --- closed. - -hClose :: Handle -> IO () -hClose h@(FileHandle _ m) = do - mb_exc <- hClose' h m - case mb_exc of - Nothing -> return () - Just e -> throwIO e -hClose h@(DuplexHandle _ r w) = do - mb_exc1 <- hClose' h w - mb_exc2 <- hClose' h r - case (do mb_exc1; mb_exc2) of - Nothing -> return () - Just e -> throwIO e - -hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) -hClose' h m = withHandle' "hClose" h m $ hClose_help - --- hClose_help is also called by lazyRead (in PrelIO) when EOF is read --- or an IO error occurs on a lazy stream. The semi-closed Handle is --- then closed immediately. We have to be careful with DuplexHandles --- though: we have to leave the closing to the finalizer in that case, --- because the write side may still be in use. -hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException) -hClose_help handle_ = - case haType handle_ of - ClosedHandle -> return (handle_,Nothing) - _ -> do flushWriteBufferOnly handle_ -- interruptible - hClose_handle_ handle_ - -hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) -hClose_handle_ handle_ = do - let fd = haFD handle_ - - -- close the file descriptor, but not when this is the read - -- side of a duplex handle. - -- If an exception is raised by the close(), we want to continue - -- to close the handle and release the lock if it has one, then - -- we return the exception to the caller of hClose_help which can - -- raise it if necessary. - maybe_exception <- - case haOtherSide handle_ of - Nothing -> (do - throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_HOST_OS - (closeFd (haIsStream handle_) fd) -#else - (c_close fd) -#endif - return Nothing - ) - `catchException` \e -> return (Just e) - - Just _ -> return Nothing - - -- free the spare buffers - writeIORef (haBuffers handle_) BufferListNil - writeIORef (haBuffer handle_) noBuffer - -#ifndef mingw32_HOST_OS - -- unlock it - unlockFile fd -#endif - - -- we must set the fd to -1, because the finalizer is going - -- to run eventually and try to close/unlock it. - return (handle_{ haFD = -1, - haType = ClosedHandle - }, - maybe_exception) - -{-# NOINLINE noBuffer #-} -noBuffer :: Buffer -noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer - ------------------------------------------------------------------------------ --- Detecting and changing the size of a file - --- | For a handle @hdl@ which attached to a physical file, --- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes. - -hFileSize :: Handle -> IO Integer -hFileSize handle = - withHandle_ "hFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - r <- fdFileSize (haFD handle_) - if r /= -1 - then return r - else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing Nothing) - - --- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. - -hSetFileSize :: Handle -> Integer -> IO () -hSetFileSize handle size = - withHandle_ "hSetFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - throwErrnoIf (/=0) "hSetFileSize" - (c_ftruncate (haFD handle_) (fromIntegral size)) - return () - --- --------------------------------------------------------------------------- --- Detecting the End of Input - --- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns --- 'True' if no further input can be taken from @hdl@ or for a --- physical file, if the current I\/O position is equal to the length of --- the file. Otherwise, it returns 'False'. --- --- NOTE: 'hIsEOF' may block, because it is the same as calling --- 'hLookAhead' and checking for an EOF exception. - -hIsEOF :: Handle -> IO Bool -hIsEOF handle = - catch - (do hLookAhead handle; return False) - (\e -> if isEOFError e then return True else ioError e) - --- | The computation 'isEOF' is identical to 'hIsEOF', --- except that it works only on 'stdin'. - -isEOF :: IO Bool -isEOF = hIsEOF stdin - --- --------------------------------------------------------------------------- --- Looking ahead - --- | Computation 'hLookAhead' returns the next character from the handle --- without removing it from the input buffer, blocking until a character --- is available. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hLookAhead :: Handle -> IO Char -hLookAhead handle = - wantReadableHandle "hLookAhead" handle hLookAhead' - -hLookAhead' :: Handle__ -> IO Char -hLookAhead' handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - buf <- readIORef ref - - -- fill up the read buffer if necessary - new_buf <- if bufferEmpty buf - then fillReadBuffer fd True (haIsStream handle_) buf - else return buf - - writeIORef ref new_buf - - (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) - return c - --- --------------------------------------------------------------------------- --- Buffering Operations - --- Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. See GHC.IOBase for definition and --- further explanation of what the type represent. - --- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for --- handle @hdl@ on subsequent reads and writes. --- --- If the buffer mode is changed from 'BlockBuffering' or --- 'LineBuffering' to 'NoBuffering', then --- --- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; --- --- * if @hdl@ is not writable, the contents of the buffer is discarded. --- --- This operation may fail with: --- --- * 'isPermissionError' if the handle has already been used for reading --- or writing and the implementation does not allow the buffering mode --- to be changed. - -hSetBuffering :: Handle -> BufferMode -> IO () -hSetBuffering handle mode = - withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> do - {- Note: - - we flush the old buffer regardless of whether - the new buffer could fit the contents of the old buffer - or not. - - allow a handle's buffering to change even if IO has - occurred (ANSI C spec. does not allow this, nor did - the previous implementation of IO.hSetBuffering). - - a non-standard extension is to allow the buffering - of semi-closed handles to change [sof 6/98] - -} - flushBuffer handle_ - - let state = initBufferState (haType handle_) - new_buf <- - case mode of - -- we always have a 1-character read buffer for - -- unbuffered handles: it's needed to - -- support hLookAhead. - NoBuffering -> allocateBuffer 1 ReadBuffer - LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n - | otherwise -> allocateBuffer n state - writeIORef (haBuffer handle_) new_buf - - -- for input terminals we need to put the terminal into - -- cooked or raw mode depending on the type of buffering. - is_tty <- fdIsTTY (haFD handle_) - when (is_tty && isReadableHandleType (haType handle_)) $ - case mode of -#ifndef mingw32_HOST_OS - -- 'raw' mode under win32 is a bit too specialised (and troublesome - -- for most common uses), so simply disable its use here. - NoBuffering -> setCooked (haFD handle_) False -#else - NoBuffering -> return () -#endif - _ -> setCooked (haFD handle_) True - - -- throw away spare buffers, they might be the wrong size - writeIORef (haBuffers handle_) BufferListNil - - return (handle_{ haBufferMode = mode }) - --- ----------------------------------------------------------------------------- --- hFlush - --- | The action 'hFlush' @hdl@ causes any items buffered for output --- in handle @hdl@ to be sent immediately to the operating system. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; --- --- * 'isPermissionError' if a system resource limit would be exceeded. --- It is unspecified whether the characters in the buffer are discarded --- or retained under these circumstances. - -hFlush :: Handle -> IO () -hFlush handle = - wantWritableHandle "hFlush" handle $ \ handle_ -> do - buf <- readIORef (haBuffer handle_) - if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef (haBuffer handle_) flushed_buf - else return () - - --- ----------------------------------------------------------------------------- --- Repositioning Handles - -data HandlePosn = HandlePosn Handle HandlePosition - -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - -instance Show HandlePosn where - showsPrec p (HandlePosn h pos) = - showsPrec p h . showString " at position " . shows pos - - -- HandlePosition is the Haskell equivalent of POSIX' off_t. - -- We represent it as an Integer on the Haskell side, but - -- cheat slightly in that hGetPosn calls upon a C helper - -- that reports the position back via (merely) an Int. -type HandlePosition = Integer - --- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of --- @hdl@ as a value of the abstract type 'HandlePosn'. - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = do - posn <- hTell handle - return (HandlePosn handle posn) - --- | If a call to 'hGetPosn' @hdl@ returns a position @p@, --- then computation 'hSetPosn' @p@ sets the position of @hdl@ --- to the position it held at the time of the call to 'hGetPosn'. --- --- This operation may fail with: --- --- * 'isPermissionError' if a system resource limit would be exceeded. - -hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i - --- --------------------------------------------------------------------------- --- hSeek - --- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: -data SeekMode - = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. - | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ - -- from the current position. - | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ - -- from the end of the file. - deriving (Eq, Ord, Ix, Enum, Read, Show) - -{- Note: - - when seeking using `SeekFromEnd', positive offsets (>=0) means - seeking at or past EOF. - - - we possibly deviate from the report on the issue of seeking within - the buffer and whether to flush it or not. The report isn't exactly - clear here. --} - --- | Computation 'hSeek' @hdl mode i@ sets the position of handle --- @hdl@ depending on @mode@. --- The offset @i@ is given in terms of 8-bit bytes. --- --- If @hdl@ is block- or line-buffered, then seeking to a position which is not --- in the current buffer will first cause any items in the output buffer to be --- written to the device, and then cause the input buffer to be discarded. --- Some handles may not be seekable (see 'hIsSeekable'), or only support a --- subset of the possible positioning operations (for instance, it may only --- be possible to seek to the end of a tape, or to a positive offset from --- the beginning or current position). --- It is not possible to set a negative I\/O position, or for --- a physical file, an I\/O position beyond the current end-of-file. --- --- This operation may fail with: --- --- * 'isPermissionError' if a system resource limit would be exceeded. - -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset = - wantSeekableHandle "hSeek" handle $ \ handle_ -> do -# ifdef DEBUG_DUMP - puts ("hSeek " ++ show (mode,offset) ++ "\n") -# endif - let ref = haBuffer handle_ - buf <- readIORef ref - let r = bufRPtr buf - w = bufWPtr buf - fd = haFD handle_ - - let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (haFD handle_) (fromIntegral offset) whence) - - whence :: CInt - whence = case mode of - AbsoluteSeek -> sEEK_SET - RelativeSeek -> sEEK_CUR - SeekFromEnd -> sEEK_END - - if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf - writeIORef ref new_buf - do_seek - else do - - if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef ref buf{ bufRPtr = r + fromIntegral offset } - else do - - new_buf <- flushReadBuffer (haFD handle_) buf - writeIORef ref new_buf - do_seek - - -hTell :: Handle -> IO Integer -hTell handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#if defined(mingw32_HOST_OS) - -- urgh, on Windows we have to worry about \n -> \r\n translation, - -- so we can't easily calculate the file position using the - -- current buffer size. Just flush instead. - flushBuffer handle_ -#endif - let fd = haFD handle_ - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 sEEK_CUR) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return real_posn - --- ----------------------------------------------------------------------------- --- Handle Properties - --- A number of operations return information about the properties of a --- handle. Each of these operations returns `True' if the handle has --- the specified property, and `False' otherwise. - -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - withHandle_ "hIsOpen" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return False - SemiClosedHandle -> return False - _ -> return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - withHandle_ "hIsClosed" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return True - _ -> return False - -{- not defined, nor exported, but mentioned - here for documentation purposes: - - hSemiClosed :: Handle -> IO Bool - hSemiClosed h = do - ho <- hIsOpen h - hc <- hIsClosed h - return (not (ho || hc)) --} - -hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _ _) = return True -hIsReadable handle = - withHandle_ "hIsReadable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isReadableHandleType htype) - -hIsWritable :: Handle -> IO Bool -hIsWritable (DuplexHandle _ _ _) = return True -hIsWritable handle = - withHandle_ "hIsWritable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isWritableHandleType htype) - --- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode --- for @hdl@. - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = - withHandle_ "hGetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> - -- We're being non-standard here, and allow the buffering - -- of a semi-closed handle to be queried. -- sof 6/98 - return (haBufferMode handle_) -- could be stricter.. - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - withHandle_ "hIsSeekable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> return False - _ -> do t <- fdType (haFD handle_) - return ((t == RegularFile || t == RawDevice) - && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) - --- ----------------------------------------------------------------------------- --- Changing echo status (Non-standard GHC extensions) - --- | Set the echoing status of a handle connected to a terminal. - -hSetEcho :: Handle -> Bool -> IO () -hSetEcho handle on = do - isT <- hIsTerminalDevice handle - if not isT - then return () - else - withHandle_ "hSetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> setEcho (haFD handle_) on - --- | Get the echoing status of a handle connected to a terminal. - -hGetEcho :: Handle -> IO Bool -hGetEcho handle = do - isT <- hIsTerminalDevice handle - if not isT - then return False - else - withHandle_ "hGetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> getEcho (haFD handle_) - --- | Is the handle connected to a terminal? - -hIsTerminalDevice :: Handle -> IO Bool -hIsTerminalDevice handle = do - withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> fdIsTTY (haFD handle_) - --- ----------------------------------------------------------------------------- --- hSetBinaryMode - --- | Select binary mode ('True') or text mode ('False') on a open handle. --- (See also 'openBinaryFile'.) - -hSetBinaryMode :: Handle -> Bool -> IO () -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (haFD handle_) bin) - return handle_{haIsBin=bin} - -foreign import ccall unsafe "__hscore_setmode" - setmode :: CInt -> Bool -> IO CInt - --- ----------------------------------------------------------------------------- --- Duplicating a Handle - --- | Returns a duplicate of the original handle, with its own buffer. --- The two Handles will share a file pointer, however. The original --- handle's buffer is flushed, including discarding any input data, --- before the handle is duplicated. - -hDuplicate :: Handle -> IO Handle -hDuplicate h@(FileHandle path m) = do - new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing) - newFileHandle path (handleFinalizer path) new_h_ -hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing) - new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w)) - new_r <- newMVar new_r_ - addMVarFinalizer new_w (handleFinalizer path new_w) - return (DuplexHandle path new_r new_w) - -dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__ - -> IO (Handle__, Handle__) -dupHandle h other_side h_ = do - -- flush the buffer first, so we don't have to copy its contents - flushBuffer h_ - new_fd <- case other_side of - Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_) - Just r -> withHandle_' "dupHandle" h r (return . haFD) - dupHandle_ other_side h_ new_fd - -dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__ - -> IO (Handle__, Handle__) -dupHandleTo other_side hto_ h_ = do - flushBuffer h_ - -- Windows' dup2 does not return the new descriptor, unlike Unix - throwErrnoIfMinus1 "dupHandleTo" $ - c_dup2 (haFD h_) (haFD hto_) - dupHandle_ other_side h_ (haFD hto_) - -dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD - -> IO (Handle__, Handle__) -dupHandle_ other_side h_ new_fd = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_)) - ioref <- newIORef buffer - ioref_buffers <- newIORef BufferListNil - - let new_handle_ = h_{ haFD = new_fd, - haBuffer = ioref, - haBuffers = ioref_buffers, - haOtherSide = other_side } - return (h_, new_handle_) - --- ----------------------------------------------------------------------------- --- Replacing a Handle - -{- | -Makes the second handle a duplicate of the first handle. The second -handle will be closed first, if it is not already. - -This can be used to retarget the standard Handles, for example: - -> do h <- openFile "mystdout" WriteMode -> hDuplicateTo h stdout --} - -hDuplicateTo :: Handle -> Handle -> IO () -hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do - withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do - _ <- hClose_help h2_ - withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_) -hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do - withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do - _ <- hClose_help w2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) - withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do - _ <- hClose_help r2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) -hDuplicateTo h1 _ = - ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" - "handles are incompatible" Nothing Nothing) - --- --------------------------------------------------------------------------- --- showing Handles. --- --- | 'hShow' is in the 'IO' monad, and gives more comprehensive output --- than the (pure) instance of 'Show' for 'Handle'. - -hShow :: Handle -> IO String -hShow h@(FileHandle path _) = showHandle' path False h -hShow h@(DuplexHandle path _ _) = showHandle' path True h - -showHandle' :: String -> Bool -> Handle -> IO String -showHandle' filepath is_duplex h = - withHandle_ "showHandle" h $ \hdl_ -> - let - showType | is_duplex = showString "duplex (read-write)" - | otherwise = shows (haType hdl_) - in - return - (( showChar '{' . - showHdl (haType hdl_) - (showString "loc=" . showString filepath . showChar ',' . - showString "type=" . showType . showChar ',' . - showString "binary=" . shows (haIsBin hdl_) . showChar ',' . - showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) - ) "") - where - - showHdl :: HandleType -> ShowS -> ShowS - showHdl ht cont = - case ht of - ClosedHandle -> shows ht . showString "}" - _ -> cont - - showBufMode :: Buffer -> BufferMode -> ShowS - showBufMode buf bmo = - case bmo of - NoBuffering -> showString "none" - LineBuffering -> showString "line" - BlockBuffering (Just n) -> showString "block " . showParen True (shows n) - BlockBuffering Nothing -> showString "block " . showParen True (shows def) - where - def :: Int - def = bufSize buf - --- --------------------------------------------------------------------------- --- debugging - -#if defined(DEBUG_DUMP) -puts :: String -> IO () -puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) - return () -#endif - --- ----------------------------------------------------------------------------- --- utils - -throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt -throwErrnoIfMinus1RetryOnBlock loc f on_block = - do - res <- f - if (res :: CInt) == -1 - then do - err <- getErrno - if err == eINTR - then throwErrnoIfMinus1RetryOnBlock loc f on_block - else if err == eWOULDBLOCK || err == eAGAIN - then do on_block - else throwErrno loc - else return res - --- ----------------------------------------------------------------------------- --- wrappers to platform-specific constants: - -foreign import ccall unsafe "__hscore_supportsTextMode" - tEXT_MODE_SEEK_ALLOWED :: Bool - -foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int -foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt -foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt -foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt +import GHC.IO.IOMode +import GHC.IO.Handle +import GHC.IO.Handle.Internals +import GHC.IO.Handle.FD diff --git a/libraries/base/GHC/Handle.hs-boot b/libraries/base/GHC/Handle.hs-boot deleted file mode 100644 index 7ace1d85b3..0000000000 --- a/libraries/base/GHC/Handle.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module GHC.Handle where - -import GHC.IOBase - -stdout :: Handle -stderr :: Handle -hFlush :: Handle -> IO () diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs index 231244bc9b..fef57dafda 100644 --- a/libraries/base/GHC/IO.hs +++ b/libraries/base/GHC/IO.hs @@ -1,974 +1,387 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} - -#undef DEBUG_DUMP - ----------------------------------------------------------------------------- -- | -- Module : GHC.IO --- Copyright : (c) The University of Glasgow, 1992-2001 +-- Copyright : (c) The University of Glasgow 1994-2002 -- License : see libraries/base/LICENSE -- --- Maintainer : libraries@haskell.org +-- Maintainer : cvs-ghc@haskell.org -- Stability : internal --- Portability : non-portable +-- Portability : non-portable (GHC Extensions) -- --- String I\/O functions +-- Definitions for the 'IO' monad and its friends. -- ----------------------------------------------------------------------------- -- #hide -module GHC.IO ( - hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - commitBuffer', -- hack, see below - hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, - memcpy_ba_baoff, - memcpy_ptr_baoff, - memcpy_baoff_ba, - memcpy_baoff_ptr, - ) where - -import Foreign -import Foreign.C - -import System.IO.Error -import Data.Maybe -import Control.Monad -#ifndef mingw32_HOST_OS -import System.Posix.Internals -#endif +module GHC.IO ( + IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + + FilePath, + + catchException, catchAny, throwIO, + block, unblock, blocked, + onException, finally, evaluate + ) where -import GHC.Enum import GHC.Base -import GHC.IOBase -import GHC.Handle -- much of the real stuff is in here -import GHC.Real -import GHC.Num -import GHC.Show -import GHC.List +import GHC.ST +import GHC.Exception +import Data.Maybe -#ifdef mingw32_HOST_OS -import GHC.Conc -#endif +import {-# SOURCE #-} GHC.IO.Exception ( userError ) -- --------------------------------------------------------------------------- --- Simple input operations +-- The IO Monad --- If hWaitForInput finds anything in the Handle's buffer, it --- immediately returns. If not, it tries to read from the underlying --- OS handle. Notice that for buffered Handles connected to terminals --- this means waiting until a complete line is available. +{- +The IO Monad is just an instance of the ST monad, where the state is +the real world. We use the exception mechanism (in GHC.Exception) to +implement IO exceptions. --- | Computation 'hWaitForInput' @hdl t@ --- waits until input is available on handle @hdl@. --- It returns 'True' as soon as input is available on @hdl@, --- or 'False' if no input is available within @t@ milliseconds. --- --- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. --- --- NOTE for GHC users: unless you use the @-threaded@ flag, --- @hWaitForInput t@ where @t >= 0@ will block all other Haskell --- threads for the duration of the call. It behaves like a --- @safe@ foreign call in this respect. - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hWaitForInput" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref - - if not (bufferEmpty buf) - then return True - else do - - if msecs < 0 - then do buf' <- fillReadBuffer (haFD handle_) True - (haIsStream handle_) buf - writeIORef ref buf' - return True - else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ - fdReady (haFD handle_) 0 {- read -} - (fromIntegral msecs) - (fromIntegral $ fromEnum $ haIsStream handle_) - if r /= 0 then do -- Call hLookAhead' to throw an EOF - -- exception if appropriate - hLookAhead' handle_ - return True - else return False - -foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt +NOTE: The IO representation is deeply wired in to various parts of the +system. The following list may or may not be exhaustive: --- --------------------------------------------------------------------------- --- hGetChar +Compiler - types of various primitives in PrimOp.lhs --- | Computation 'hGetChar' @hdl@ reads a character from the file or --- channel managed by @hdl@, blocking until a character is available. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \handle_ -> do - - let fd = haFD handle_ - ref = haBuffer handle_ - - buf <- readIORef ref - if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do - - -- buffer is empty. - case haBufferMode handle_ of - LineBuffering -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - hGetcBuffered fd ref new_buf - BlockBuffering _ -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - -- ^^^^ - -- don't wait for a completely full buffer. - hGetcBuffered fd ref new_buf - NoBuffering -> do - -- make use of the minimal buffer we already have - let !raw = bufBuf buf - r <- readRawBuffer "hGetChar" fd (haIsStream handle_) raw 0 1 - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char -hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w } - = do (c, r) <- readCharFromBuffer b r0 - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c +RTS - forceIO (StgMiscClosures.hc) + - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast + (Exceptions.hc) + - raiseAsync (Schedule.c) --- --------------------------------------------------------------------------- --- hGetLine +Prelude - GHC.IO.lhs, and several other places including + GHC.Exception.lhs. --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. +Libraries - parts of hslibs/lang. --- | Computation 'hGetLine' @hdl@ reads a line from the file or --- channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file is encountered when reading --- the /first/ character of the line. --- --- If 'hGetLine' encounters end-of-file at any other point while reading --- in a line, it is treated as a line terminator and the (partial) --- line is returned. - -hGetLine :: Handle -> IO String -hGetLine h = do - m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) - case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - -hGetLineBuffered :: Handle__ -> IO String -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - -hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String] - -> IO String -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' - in do - (eol, off) <- loop raw0 r0 - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw0 r0 off - - -- if eol == True, then off is the offset of the '\n' - -- otherwise off == w and the buffer is now empty. - if eol - then do if (w == off + 1) - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - let str = concat (reverse (xs:xss)) - if not (null str) - then return str - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf (xs:xss) - -maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer) -maybeFillReadBuffer fd is_line is_stream buf - = catch - (do buf' <- fillReadBuffer fd is_line is_stream buf - return (Just buf') - ) - (\e -> do if isEOFError e - then return Nothing - else ioError e) - - -unpack :: RawBuffer -> Int -> Int -> IO [Char] -unpack _ _ 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' - - -hGetLineUnBuffered :: Handle -> IO String -hGetLineUnBuffered h = do - c <- hGetChar h - if c == '\n' then - return "" - else do - l <- getRest - return (c:l) - where - getRest = do - c <- - catch - (hGetChar h) - (\ err -> do - if isEOFError err then - return '\n' - else - ioError err) - if c == '\n' then - return "" - else do - s <- getRest - return (c:s) +--SDM +-} --- ----------------------------------------------------------------------------- --- hGetContents +{-| +A value of type @'IO' a@ is a computation which, when performed, +does some I\/O before returning a value of type @a@. --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. +There is really only one way to \"perform\" an I\/O action: bind it to +@Main.main@ in your program. When your program is run, the I\/O will +be performed. It isn't possible to perform I\/O from an arbitrary +function, unless that function is itself in the 'IO' monad and called +at some point, directly or indirectly, from @Main.main@. --- | Computation 'hGetContents' @hdl@ returns the list of characters --- corresponding to the unread portion of the channel or file managed --- by @hdl@, which is put into an intermediate state, /semi-closed/. --- In this state, @hdl@ is effectively closed, --- but items are read from @hdl@ on demand and accumulated in a special --- list returned by 'hGetContents' @hdl@. --- --- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: --- --- * if 'hClose' is applied to it; --- --- * if an I\/O error occurs when reading an item from the handle; --- --- * or once the entire contents of the handle has been read. --- --- Once a semi-closed handle becomes closed, the contents of the --- associated list becomes fixed. The contents of this final list is --- only partially specified: it will contain at least all the items of --- the stream that were evaluated prior to the handle becoming closed. --- --- Any I\/O errors encountered while a handle is semi-closed are simply --- discarded. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetContents :: Handle -> IO String -hGetContents handle = - withHandle "hGetContents" handle $ \handle_ -> - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) - --- Note that someone may close the semi-closed handle (or change its --- buffering), so each time these lazy read functions are pulled on, --- they have to check whether the handle has indeed been closed. - -lazyRead :: Handle -> IO String -lazyRead handle = - unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing Nothing) - -lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) -lazyRead' h handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - - -- even a NoBuffering handle can have a char in the buffer... - -- (see hLookAhead) - buf <- readIORef ref - if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do - - case haBufferMode handle_ of - NoBuffering -> do - -- make use of the minimal buffer we already have - let !raw = bufBuf buf - r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1 - if r == 0 - then do (handle_', _) <- hClose_help handle_ - return (handle_', "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) - - LineBuffering -> lazyReadBuffered h handle_ fd ref buf - BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf - --- we never want to block during the read, so we call fillReadBuffer with --- is_line==True, which tells it to "just read what there is". -lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer - -> IO (Handle__, [Char]) -lazyReadBuffered h handle_ fd ref buf = do - catch - (do buf' <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf - lazyReadHaveBuffer h handle_ fd ref buf' - ) - -- all I/O errors are discarded. Additionally, we close the handle. - (\_ -> do (handle_', _) <- hClose_help handle_ - return (handle_', "") - ) - -lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char]) -lazyReadHaveBuffer h handle_ _ ref buf = do - more <- lazyRead h - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more - return (handle_, s) - - -unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc _ _ 0 acc = return acc -unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' +'IO' is a monad, so 'IO' actions can be combined using either the do-notation +or the '>>' and '>>=' operations from the 'Monad' class. +-} +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a + +instance Functor IO where + fmap f x = x >>= (return . f) + +instance Monad IO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return x = returnIO x + + m >>= k = bindIO m k + fail s = failIO s + +liftIO :: IO a -> State# RealWorld -> STret RealWorld a +liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r + +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) k = IO ( \ s -> + case m s of + (# new_s, a #) -> unIO (k a) new_s + ) + +thenIO :: IO a -> IO b -> IO b +thenIO (IO m) k = IO ( \ s -> + case m s of + (# new_s, _ #) -> unIO k new_s + ) + +returnIO :: a -> IO a +returnIO x = IO (\ s -> (# s, x #)) + +failIO :: String -> IO a +failIO s = IO (raiseIO# (toException (userError s))) -- --------------------------------------------------------------------------- --- hPutChar +-- Coercions between IO and ST --- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the --- file or channel managed by @hdl@. Characters may be buffered if --- buffering is enabled for @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or +-- | A monad transformer embedding strict state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO (ST m) = IO m + +ioToST :: IO a -> ST RealWorld a +ioToST (IO m) = (ST m) + +-- This relies on IO and ST having the same representation modulo the +-- constraint on the type of the state -- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = do - c `seq` return () - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - with (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 - return () - -hPutcBuffered :: Handle__ -> Bool -> Char -> IO () -hPutcBuffered handle_ is_line c = do - let ref = haBuffer handle_ - buf <- readIORef ref - let w = bufWPtr buf - w' <- writeCharIntoBuffer (bufBuf buf) w c - let new_buf = buf{ bufWPtr = w' } - if bufferFull new_buf || is_line && c == '\n' - then do - flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf - writeIORef ref flushed_buf - else do - writeIORef ref new_buf - - -hPutChars :: Handle -> [Char] -> IO () -hPutChars _ [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs +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) -- --------------------------------------------------------------------------- --- hPutStr +-- Unsafe IO operations + +{-| +This is the \"back door\" into the 'IO' monad, allowing +'IO' computation to be performed at any time. For +this to be safe, the 'IO' computation should be +free of side effects and independent of its environment. + +If the I\/O computation wrapped in 'unsafePerformIO' +performs side effects, then the relative order in which those side +effects take place (relative to the main I\/O trunk, or other calls to +'unsafePerformIO') is indeterminate. You have to be careful when +writing and compiling modules that use 'unsafePerformIO': + + * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ + that calls 'unsafePerformIO'. If the call is inlined, + the I\/O may be performed more than once. + + * Use the compiler flag @-fno-cse@ to prevent common sub-expression + elimination being performed on the module, which might combine + two side effects that were meant to be separate. A good example + is using multiple global variables (like @test@ in the example below). + + * Make sure that the either you switch off let-floating, or that the + call to 'unsafePerformIO' cannot float outside a lambda. For example, + if you say: + @ + f x = unsafePerformIO (newIORef []) + @ + you may get only one reference cell shared between all calls to @f@. + Better would be + @ + f x = unsafePerformIO (newIORef [x]) + @ + because now it can't float outside the lambda. + +It is less well known that +'unsafePerformIO' is not type safe. For example: + +> test :: IORef [a] +> test = unsafePerformIO $ newIORef [] +> +> main = do +> writeIORef test [42] +> bang <- readIORef test +> print (bang :: [Char]) + +This program will core dump. This problem with polymorphic references +is well known in the ML community, and does not arise with normal +monadic use of references. There is no easy way to make it impossible +once you use 'unsafePerformIO'. Indeed, it is +possible to write @coerce :: a -> b@ with the +help of 'unsafePerformIO'. So be careful! +-} +unsafePerformIO :: IO a -> a +unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) + +{-| +This version of 'unsafePerformIO' is slightly more efficient, +because it omits the check that the IO is only being performed by a +single thread. Hence, when you write 'unsafeDupablePerformIO', +there is a possibility that the IO action may be performed multiple +times (on a multiprocessor), and you should therefore ensure that +it gives the same results each time. +-} +{-# NOINLINE unsafeDupablePerformIO #-} +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with +-- GHC.ST.runST. Essentially the issue is that the IO computation +-- inside unsafePerformIO must be atomic: it must either all run, or +-- 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 unsafeDupablePerformIO? +-- If we don't have it, the demand analyser discovers the following strictness +-- for unsafeDupablePerformIO: C(U(AV)) +-- But then consider +-- unsafeDupablePerformIO (\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 unsafeDupablePerformIO, +-- 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 +when the value of the @a@ is demanded. This is used to implement lazy +file reading, see 'System.IO.hGetContents'. +-} +{-# INLINE unsafeInterleaveIO #-} +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) + +-- We believe that INLINE on unsafeInterleaveIO is safe, because the +-- state from this IO thread is passed explicitly to the interleaved +-- IO, so it cannot be floated out and shared. + +{-# INLINE unsafeDupableInterleaveIO #-} +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) + +{-| +Ensures that the suspensions under evaluation by the current thread +are unique; that is, the current thread is not evaluating anything +that is also under evaluation by another thread that has also executed +'noDuplicate'. + +This operation is used in the definition of 'unsafePerformIO' to +prevent the IO action from being executed multiple times, which is usually +undesirable. +-} +noDuplicate :: IO () +noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) --- We go to some trouble to avoid keeping the handle locked while we're --- evaluating the string argument to hPutStr, in case doing so triggers another --- I/O operation on the same handle which would lead to deadlock. The classic --- case is --- --- putStr (trace "hello" "world") --- --- so the basic scheme is this: --- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. --- --- Committing may involve simply copying the contents of the new --- buffer into the handle's buffer, flushing one or both buffers, or --- maybe just swapping the buffers over (if the handle's buffer was --- empty). See commitBuffer below. +-- ----------------------------------------------------------------------------- +-- | 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. --- | Computation 'hPutStr' @hdl s@ writes the string --- @s@ to the file or channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or --- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) - case buffer_mode of - (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care - (LineBuffering, buf) -> do - writeLines handle buf str - (BlockBuffering _, buf) -> do - writeBlocks handle buf str - - -getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) -getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} - = do - case mode of - NoBuffering -> return (mode, error "no buffer!") - _ -> do - bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) - - -writeLines :: Handle -> Buffer -> String -> IO () -writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeLines hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - if (c == '\n') - then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeLines hdl new_buf cs - else - shoveString n' cs - in - shoveString 0 s - -writeBlocks :: Handle -> Buffer -> String -> IO () -writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - shoveString n' cs - in - shoveString 0 s +type FilePath = String -- ----------------------------------------------------------------------------- --- commitBuffer handle buf sz count flush release --- --- Write the contents of the buffer 'buf' ('sz' bytes long, containing --- 'count' bytes of data) to handle (handle must be block or line buffered). --- --- Implementation: --- --- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. --- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. --- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. - -commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer - -commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do - wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' raw sz count flush release - --- Explicitly lambda-lift this function to subvert GHC's full laziness --- optimisations, which otherwise tends to float out subexpressions --- past the \handle, which is really a pessimisation in this case because --- that lambda is a one-shot lambda. --- --- Don't forget to export the function, to stop it being inlined too --- (this appears to be better than NOINLINE, because the strictness --- analyser still gets to worker-wrapper it). --- --- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 --- -commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__ - -> IO Buffer -commitBuffer' raw sz@(I# _) count@(I# _) flush release - handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do - -#ifdef DEBUG_DUMP - puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") -#endif - - old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw (fromIntegral w) raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd (haIsStream handle_) this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer - - -- release the buffer if necessary - case buf_ret of - Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do - if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret +-- Primitive catch and throwIO --- --------------------------------------------------------------------------- --- Reading/writing sequences of bytes. +{- +catchException used to handle the passing around of the state to the +action and the handler. This turned out to be a bad idea - it meant +that we had to wrap both arguments in thunks so they could be entered +as normal (remember IO returns an unboxed pair...). --- --------------------------------------------------------------------------- --- hPutBuf +Now catch# has type --- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the --- buffer @buf@ to the handle @hdl@. It returns (). --- --- This operation may fail with: --- --- * 'ResourceVanished' if the handle is a pipe or socket, and the --- reading end is closed. (If this is a POSIX system, and the program --- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered --- instead, whose default action is to terminate the program). - -hPutBuf :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO () -hPutBuf h ptr count = do hPutBuf' h ptr count True; return () - -hPutBufNonBlocking - :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO Int -- returns: number of bytes written -hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False - -hPutBuf':: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- allow blocking? - -> IO Int -hPutBuf' handle ptr count can_block - | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hPutBuf" count - | otherwise = - wantWritableHandle "hPutBuf" handle $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> - bufWrite fd ref is_stream ptr count can_block - -bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int -bufWrite fd ref is_stream ptr count can_block = - seq count $ seq fd $ do -- strictness hack - old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size } - <- readIORef ref - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ptr old_raw (fromIntegral w) ptr (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return count - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd is_stream old_buf - -- TODO: we should do a non-blocking flush here - writeIORef ref flushed_buf - -- if we can fit in the buffer, then just loop - if count < size - then bufWrite fd ref is_stream ptr count can_block - else if can_block - then do writeChunk fd is_stream (castPtr ptr) count - return count - else writeChunkNonBlocking fd is_stream ptr count - -writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO () -writeChunk fd is_stream ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO () - loop _ bytes | bytes <= 0 = return () - loop off bytes = do - r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" fd is_stream ptr - off (fromIntegral bytes) - -- write can't return 0 - loop (off + r) (bytes - r) - -writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -writeChunkNonBlocking fd -#ifndef mingw32_HOST_OS - _ -#else - is_stream -#endif - ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do -#ifndef mingw32_HOST_OS - ssize <- c_write fd (ptr `plusPtr` off) (fromIntegral bytes) - let r = fromIntegral ssize :: Int - if (r == -1) - then do errno <- getErrno - if (errno == eAGAIN || errno == eWOULDBLOCK) - then return off - else throwErrno "writeChunk" - else loop (off + r) (bytes - r) -#else - (ssize, rc) <- asyncWrite (fromIntegral fd) - (fromIntegral $ fromEnum is_stream) - (fromIntegral bytes) - (ptr `plusPtr` off) - let r = fromIntegral ssize :: Int - if r == (-1) - then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) - else loop (off + r) (bytes - r) -#endif + catch# :: IO a -> (b -> IO a) -> IO a --- --------------------------------------------------------------------------- --- hGetBuf +(well almost; the compiler doesn't know about the IO newtype so we +have to work around that in the definition of catchException below). +-} --- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ --- into the buffer @buf@ until either EOF is reached or --- @count@ 8-bit bytes have been read. --- It returns the number of bytes actually read. This may be zero if --- EOF was reached before any data was read (or if @count@ is zero). --- --- 'hGetBuf' never raises an EOF exception, instead it returns a value --- smaller than @count@. --- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBuf' will behave as if EOF was reached. - -hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBuf" count - | otherwise = - wantReadableHandle "hGetBuf" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufRead fd ref is_stream ptr 0 count - --- small reads go through the buffer, large reads are satisfied by --- taking data first from the buffer and then direct from the file --- descriptor. -bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int -bufRead fd ref is_stream ptr so_far count = - seq fd $ seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref - if bufferEmpty buf - then if count > sz -- small read? - then do rest <- readChunk fd is_stream ptr count - return (so_far + rest) - else do mb_buf <- maybeFillReadBuffer fd True is_stream buf - case mb_buf of - Nothing -> return so_far -- got nothing, we're done - Just buf' -> do - writeIORef ref buf' - bufRead fd ref is_stream ptr so_far count - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return (so_far + count) - else do - if (count < avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - if remaining < sz - then bufRead fd ref is_stream ptr' so_far' remaining - else do - - rest <- readChunk fd is_stream ptr' remaining - return (so_far' + rest) - -readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunk fd is_stream ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do - r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" fd is_stream - (castPtr ptr) off (fromIntegral bytes) - if r == 0 - then return off - else loop (off + r) (bytes - r) - - --- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ --- into the buffer @buf@ until either EOF is reached, or --- @count@ 8-bit bytes have been read, or there is no more data available --- to read immediately. +catchException :: Exception e => IO a -> (e -> IO a) -> IO a +catchException (IO io) handler = IO $ catch# io handler' + where handler' e = case fromException e of + Just e' -> unIO (handler e') + Nothing -> raise# e + +catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a +catchAny (IO io) handler = IO $ catch# io handler' + where handler' (SomeException e) = unIO (handler e) + +-- | A variant of 'throw' that can only be used within the 'IO' monad. -- --- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will --- never block waiting for data to become available, instead it returns --- only whatever data is available. To wait for data to arrive before --- calling 'hGetBufNonBlocking', use 'hWaitForInput'. +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: -- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x -- -hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count - | otherwise = - wantReadableHandle "hGetBufNonBlocking" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufReadNonBlocking fd ref is_stream ptr 0 count - -bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int - -> IO Int -bufReadNonBlocking fd ref is_stream ptr so_far count = - seq fd $ seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref - if bufferEmpty buf - then if count > sz -- large read? - then do rest <- readChunkNonBlocking fd is_stream ptr count - return (so_far + rest) - else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf - case buf' of { Buffer{ bufWPtr=w' } -> - if (w' == 0) - then return so_far - else do writeIORef ref buf' - bufReadNonBlocking fd ref is_stream ptr - so_far (min count w') - -- NOTE: new count is min count w' - -- so we will just copy the contents of the - -- buffer in the recursive call, and not - -- loop again. - } - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return (so_far + count) - else do - if (count < avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - -- we haven't attempted to read anything yet if we get to here. - if remaining < sz - then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining - else do - - rest <- readChunkNonBlocking fd is_stream ptr' remaining - return (so_far' + rest) - - -readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunkNonBlocking fd is_stream ptr bytes = do - fromIntegral `liftM` - readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream - (castPtr ptr) 0 (fromIntegral bytes) - - -- we don't have non-blocking read support on Windows, so just invoke - -- the ordinary low-level read which will block until data is available, - -- but won't wait for the whole buffer to fill. - -slurpFile :: FilePath -> IO (Ptr (), Int) -slurpFile fname = do - handle <- openFile fname ReadMode - sz <- hFileSize handle - if sz > fromIntegral (maxBound::Int) then - ioError (userError "slurpFile: file too big") - else do - let sz_i = fromIntegral sz - if sz_i == 0 then return (nullPtr, 0) else do - chunk <- mallocBytes sz_i - r <- hGetBuf handle chunk sz_i - hClose handle - return (chunk, r) - --- --------------------------------------------------------------------------- --- memcpy wrappers - -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ()) +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwIO' will only cause +-- an exception to be raised when it is used within the 'IO' monad. +-- The 'throwIO' variant should be used in preference to 'throw' to +-- raise an exception within the 'IO' monad because it guarantees +-- ordering with respect to other 'IO' operations, whereas 'throw' +-- does not. +throwIO :: Exception e => e -> IO a +throwIO e = IO (raiseIO# (toException e)) ------------------------------------------------------------------------------ --- Internal Utils - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing Nothing) +-- ----------------------------------------------------------------------------- +-- Controlling asynchronous exception delivery + +-- | Applying 'block' to a computation will +-- execute that computation with asynchronous exceptions +-- /blocked/. That is, any thread which +-- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be +-- blocked until asynchronous exceptions are enabled again. There\'s +-- no need to worry about re-enabling asynchronous exceptions; that is +-- done automatically on exiting the scope of +-- 'block'. +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @block $ forkIO ...@. This is particularly useful if you need to +-- establish an exception handler in the forked thread before any +-- asynchronous exceptions are received. +block :: IO a -> IO a + +-- | To re-enable asynchronous exceptions inside the scope of +-- 'block', 'unblock' can be +-- used. It scopes in exactly the same way, so on exit from +-- 'unblock' asynchronous exception delivery will +-- be disabled again. +unblock :: IO a -> IO a + +block (IO io) = IO $ blockAsyncExceptions# io +unblock (IO io) = IO $ unblockAsyncExceptions# io + +-- | returns True if asynchronous exceptions are blocked in the +-- current thread. +blocked :: IO Bool +blocked = IO $ \s -> case asyncExceptionsBlocked# s of + (# s', i #) -> (# s', i /=# 0# #) + +onException :: IO a -> IO b -> IO a +onException io what = io `catchException` \e -> do what + throw (e :: SomeException) + +finally :: IO a -- ^ computation to run first + -> IO b -- ^ computation to run afterward (even if an exception + -- was raised) + -> IO a -- returns the value from the first computation +a `finally` sequel = + block (do + r <- unblock a `onException` sequel + sequel + return r + ) + +-- | Forces its argument to be evaluated to weak head normal form when +-- the resultant 'IO' action is executed. It can be used to order +-- evaluation with respect to other 'IO' operations; its semantics are +-- given by +-- +-- > evaluate x `seq` y ==> y +-- > evaluate x `catch` f ==> (return $! x) `catch` f +-- > evaluate x >>= f ==> (return $! x) >>= f +-- +-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the +-- same as @(return $! x)@. A correct definition is +-- +-- > evaluate x = (return $! x) >>= return +-- +evaluate :: a -> IO a +evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) + -- NB. can't write + -- a `seq` (# s, a #) + -- because we can't have an unboxed tuple as a function argument diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs new file mode 100644 index 0000000000..bcdaabda0d --- /dev/null +++ b/libraries/base/GHC/IO/Buffer.hs @@ -0,0 +1,278 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Buffer +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Buffers used in the IO system +-- +----------------------------------------------------------------------------- + +module GHC.IO.Buffer ( + -- * Buffers of any element + Buffer(..), BufferState(..), CharBuffer, CharBufElem, + + -- ** Creation + newByteBuffer, + newCharBuffer, + newBuffer, + emptyBuffer, + + -- ** Insertion/removal + bufferRemove, + bufferAdd, + slideContents, + bufferAdjustL, + + -- ** Inspecting + isEmptyBuffer, + isFullBuffer, + isFullCharBuffer, + isWriteBuffer, + bufferElems, + bufferAvailable, + summaryBuffer, + + -- ** Operating on the raw buffer as a Ptr + withBuffer, + withRawBuffer, + + -- ** Assertions + checkBuffer, + + -- * Raw buffers + RawBuffer, + readWord8Buf, + writeWord8Buf, + RawCharBuffer, + peekCharBuf, + readCharBuf, + writeCharBuf, + readCharBufPtr, + writeCharBufPtr, + charSize, + ) where + +import GHC.Base +import GHC.IO +import GHC.Num +import GHC.Ptr +import GHC.Word +import GHC.Show +import GHC.Real +import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Storable + +-- Char buffers use either UTF-16 or UTF-32, with the endianness matching +-- the endianness of the host. +-- +-- Invariants: +-- * a Char buffer consists of *valid* UTF-16 or UTF-32 +-- * only whole characters: no partial surrogate pairs + +-- #define CHARBUF_UTF16 +#define CHARBUF_UTF32 + +-- --------------------------------------------------------------------------- +-- Raw blocks of data + +type RawBuffer e = ForeignPtr e + +readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8 +readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix + +writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO () +writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w + +#ifdef CHARBUF_UTF16 +type CharBufElem = Word16 +#else +type CharBufElem = Char +#endif + +type RawCharBuffer = RawBuffer CharBufElem + +peekCharBuf :: RawCharBuffer -> Int -> IO Char +peekCharBuf arr ix = withForeignPtr arr $ \p -> do + (c,_) <- readCharBufPtr p ix + return c + +{-# INLINE readCharBuf #-} +readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int) +readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix + +{-# INLINE writeCharBuf #-} +writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int +writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c + +{-# INLINE readCharBufPtr #-} +readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int) +#ifdef CHARBUF_UTF16 +readCharBufPtr p ix = do + c1 <- peekElemOff p ix + if (c1 < 0xd800 || c1 > 0xdbff) + then return (chr (fromIntegral c1), ix+1) + else do c2 <- peekElemOff p (ix+1) + return (unsafeChr ((fromIntegral c1 - 0xd800)*0x400 + + (fromIntegral c2 - 0xdc00) + 0x10000), ix+2) +#else +readCharBufPtr p ix = do c <- peekElemOff (castPtr p) ix; return (c, ix+1) +#endif + +{-# INLINE writeCharBufPtr #-} +writeCharBufPtr :: Ptr CharBufElem -> Int -> Char -> IO Int +#ifdef CHARBUF_UTF16 +writeCharBufPtr p ix ch + | c < 0x10000 = do pokeElemOff p ix (fromIntegral c) + return (ix+1) + | otherwise = do let c' = c - 0x10000 + pokeElemOff p ix (fromIntegral (c' `div` 0x400 + 0xd800)) + pokeElemOff p (ix+1) (fromIntegral (c' `mod` 0x400 + 0xdc00)) + return (ix+2) + where + c = ord ch +#else +writeCharBufPtr p ix ch = do pokeElemOff (castPtr p) ix ch; return (ix+1) +#endif + +charSize :: Int +#ifdef CHARBUF_UTF16 +charSize = 2 +#else +charSize = 4 +#endif + +-- --------------------------------------------------------------------------- +-- Buffers + +-- The buffer is represented by a mutable variable containing a +-- record, where the record contains the raw buffer and the start/end +-- points of the filled portion. We use a mutable variable so that +-- the common operation of writing (or reading) some data from (to) +-- the buffer doesn't need to modify, and hence copy, the handle +-- itself, it just updates the buffer. + +-- There will be some allocation involved in a simple hPutChar in +-- order to create the new Buffer structure (below), but this is +-- relatively small, and this only has to be done once per write +-- operation. + +-- | A mutable array of bytes that can be passed to foreign functions. +data Buffer e + = Buffer { + bufRaw :: !(RawBuffer e), + bufState :: BufferState, + bufSize :: !Int, -- in elements, not bytes + bufL :: !Int, -- offset of first item in the buffer + bufR :: !Int -- offset of last item + 1 + } + +#ifdef CHARBUF_UTF16 +type CharBuffer = Buffer Word16 +#else +type CharBuffer = Buffer Char +#endif + +data BufferState = ReadBuffer | WriteBuffer deriving (Eq) + +withBuffer :: Buffer e -> (Ptr e -> IO a) -> IO a +withBuffer Buffer{ bufRaw=raw } f = withForeignPtr (castForeignPtr raw) f + +withRawBuffer :: RawBuffer e -> (Ptr e -> IO a) -> IO a +withRawBuffer raw f = withForeignPtr (castForeignPtr raw) f + +isEmptyBuffer :: Buffer e -> Bool +isEmptyBuffer Buffer{ bufR=w } = w == 0 + +isFullBuffer :: Buffer e -> Bool +isFullBuffer Buffer{ bufR=w, bufSize=s } = s == w + +-- if a Char buffer does not have room for a surrogate pair, it is "full" +isFullCharBuffer :: Buffer e -> Bool +#ifdef CHARBUF_UTF16 +isFullCharBuffer buf = bufferAvailable buf < 2 +#else +isFullCharBuffer = isFullBuffer +#endif + +isWriteBuffer :: Buffer e -> Bool +isWriteBuffer buf = case bufState buf of + WriteBuffer -> True + ReadBuffer -> False + +bufferElems :: Buffer e -> Int +bufferElems Buffer{ bufR=w, bufL=r } = w - r + +bufferAvailable :: Buffer e -> Int +bufferAvailable Buffer{ bufR=w, bufSize=s } = s - w + +bufferRemove :: Int -> Buffer e -> Buffer e +bufferRemove i buf@Buffer{ bufL=r } = bufferAdjustL (r+i) buf + +bufferAdjustL :: Int -> Buffer e -> Buffer e +bufferAdjustL l buf@Buffer{ bufR=w } + | l == w = buf{ bufL=0, bufR=0 } + | otherwise = buf{ bufL=l, bufR=w } + +bufferAdd :: Int -> Buffer e -> Buffer e +bufferAdd i buf@Buffer{ bufR=w } = buf{ bufR=w+i } + +emptyBuffer :: RawBuffer e -> Int -> BufferState -> Buffer e +emptyBuffer raw sz state = + Buffer{ bufRaw=raw, bufState=state, bufR=0, bufL=0, bufSize=sz } + +newByteBuffer :: Int -> BufferState -> IO (Buffer Word8) +newByteBuffer c st = newBuffer c c st + +newCharBuffer :: Int -> BufferState -> IO CharBuffer +newCharBuffer c st = newBuffer (c * charSize) c st + +newBuffer :: Int -> Int -> BufferState -> IO (Buffer e) +newBuffer bytes sz state = do + fp <- mallocForeignPtrBytes bytes + return (emptyBuffer fp sz state) + +-- | slides the contents of the buffer to the beginning +slideContents :: Buffer Word8 -> IO (Buffer Word8) +slideContents buf@Buffer{ bufL=l, bufR=r, bufRaw=raw } = do + let elems = r - l + withRawBuffer raw $ \p -> memcpy p (p `plusPtr` l) (fromIntegral elems) + return buf{ bufL=0, bufR=elems } + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ()) + +summaryBuffer :: Buffer a -> String +summaryBuffer buf = "buf" ++ show (bufSize buf) ++ "(" ++ show (bufL buf) ++ "-" ++ show (bufR buf) ++ ")" + +-- INVARIANTS on Buffers: +-- * r <= w +-- * if r == w, then r == 0 && w == 0 +-- * if state == WriteBuffer, then r == 0 +-- * a write buffer is never full. If an operation +-- fills up the buffer, it will always flush it before +-- returning. +-- * a read buffer may be full as a result of hLookAhead. In normal +-- operation, a read buffer always has at least one character of space. + +checkBuffer :: Buffer a -> IO () +checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do + check buf ( + size > 0 + && r <= w + && w <= size + && ( r /= w || (r == 0 && w == 0) ) + && ( state /= WriteBuffer || r == 0 ) + && ( state /= WriteBuffer || w < size ) -- write buffer is never full + ) + +check :: Buffer a -> Bool -> IO () +check _ True = return () +check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf) diff --git a/libraries/base/GHC/IO/BufferedIO.hs b/libraries/base/GHC/IO/BufferedIO.hs new file mode 100644 index 0000000000..a70b1d95e4 --- /dev/null +++ b/libraries/base/GHC/IO/BufferedIO.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.BufferedIO +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Class of buffered IO devices +-- +----------------------------------------------------------------------------- + +module GHC.IO.BufferedIO ( + BufferedIO(..), + readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking + ) where + +import GHC.Base +import GHC.Ptr +import Data.Word +import GHC.Num +import GHC.Real +import Data.Maybe +import GHC.IO +import GHC.IO.Device as IODevice +import GHC.IO.Device as RawIO +import GHC.IO.Buffer + +-- | The purpose of 'BufferedIO' is to provide a common interface for I/O +-- devices that can read and write data through a buffer. Devices that +-- implement 'BufferedIO' include ordinary files, memory-mapped files, +-- and bytestrings. The underlying device implementing a 'Handle' must +-- provide 'BufferedIO'. +-- +class BufferedIO dev where + -- | allocate a new buffer. The size of the buffer is at the + -- discretion of the device; e.g. for a memory-mapped file the + -- buffer will probably cover the entire file. + newBuffer :: dev -> BufferState -> IO (Buffer Word8) + + -- | reads bytes into the buffer, blocking if there are no bytes + -- available. Returns the number of bytes read (zero indicates + -- end-of-file), and the new buffer. + fillReadBuffer :: dev -> Buffer Word8 -> IO (Int, Buffer Word8) + + -- | reads bytes into the buffer without blocking. Returns the + -- number of bytes read (Nothing indicates end-of-file), and the new + -- buffer. + fillReadBuffer0 :: dev -> Buffer Word8 -> IO (Maybe Int, Buffer Word8) + + -- | Flush all the data from the supplied write buffer out to the device + flushWriteBuffer :: dev -> Buffer Word8 -> IO () + + -- | Flush data from the supplied write buffer out to the device + -- without blocking. Returns the number of bytes written and the + -- remaining buffer. + flushWriteBuffer0 :: dev -> Buffer Word8 -> IO (Int, Buffer Word8) + +-- for an I/O device, these operations will perform reading/writing +-- to/from the device. + +-- for a memory-mapped file, the buffer will be the whole file in +-- memory. fillReadBuffer sets the pointers to encompass the whole +-- file, and flushWriteBuffer will do nothing. A memory-mapped file +-- has to maintain its own file pointer. + +-- for a bytestring, again the buffer should match the bytestring in +-- memory. + +-- --------------------------------------------------------------------------- +-- Low-level read/write to/from buffers + +-- These operations make it easy to implement an instance of 'BufferedIO' +-- for an object that supports 'RawIO'. + +readBuf :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) +readBuf dev bbuf = do + let bytes = bufferAvailable bbuf + res <- withBuffer bbuf $ \ptr -> + RawIO.read dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes) + let res' = fromIntegral res + return (res', bbuf{ bufR = bufR bbuf + res' }) + -- zero indicates end of file + +readBufNonBlocking :: RawIO dev => dev -> Buffer Word8 + -> IO (Maybe Int, -- Nothing ==> end of file + -- Just n ==> n bytes were read (n>=0) + Buffer Word8) +readBufNonBlocking dev bbuf = do + let bytes = bufferAvailable bbuf + res <- withBuffer bbuf $ \ptr -> + IODevice.readNonBlocking dev (ptr `plusPtr` bufR bbuf) (fromIntegral bytes) + case res of + Nothing -> return (Nothing, bbuf) + Just n -> return (Just n, bbuf{ bufR = bufR bbuf + fromIntegral n }) + +writeBuf :: RawIO dev => dev -> Buffer Word8 -> IO () +writeBuf dev bbuf = do + let bytes = bufferElems bbuf + withBuffer bbuf $ \ptr -> + IODevice.write dev (ptr `plusPtr` bufL bbuf) (fromIntegral bytes) + +-- XXX ToDo +writeBufNonBlocking :: RawIO dev => dev -> Buffer Word8 -> IO (Int, Buffer Word8) +writeBufNonBlocking dev bbuf = do + let bytes = bufferElems bbuf + res <- withBuffer bbuf $ \ptr -> + IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) + (fromIntegral bytes) + return (res, bbuf{ bufL = bufL bbuf + res }) + diff --git a/libraries/base/GHC/IO/Device.hs b/libraries/base/GHC/IO/Device.hs new file mode 100644 index 0000000000..ab91bc0d7c --- /dev/null +++ b/libraries/base/GHC/IO/Device.hs @@ -0,0 +1,145 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Device +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Type classes for I/O providers. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Device ( + RawIO(..), + IODevice(..), + IODeviceType(..), + SeekMode(..) + ) where + +import GHC.Base +import GHC.Word +import GHC.Arr +import GHC.Enum +import GHC.Read +import GHC.Show +import GHC.Ptr +import Data.Maybe +import GHC.Num +import GHC.IO +import {-# SOURCE #-} GHC.IO.Exception ( unsupportedOperation ) + +-- | A low-level I/O provider where the data is bytes in memory. +class RawIO a where + -- | Read up to the specified number of bytes, returning the number + -- of bytes actually read. This function should only block if there + -- is no data available. If there is not enough data available, + -- then the function should just return the available data. A return + -- value of zero indicates that the end of the data stream (e.g. end + -- of file) has been reached. + read :: a -> Ptr Word8 -> Int -> IO Int + + -- | Read up to the specified number of bytes, returning the number + -- of bytes actually read, or 'Nothing' if the end of the stream has + -- been reached. + readNonBlocking :: a -> Ptr Word8 -> Int -> IO (Maybe Int) + + -- | Write the specified number of bytes. + write :: a -> Ptr Word8 -> Int -> IO () + + -- | Write up to the specified number of bytes without blocking. Returns + -- the actual number of bytes written. + writeNonBlocking :: a -> Ptr Word8 -> Int -> IO Int + + +-- | I/O operations required for implementing a 'Handle'. +class IODevice a where + -- | @ready dev write msecs@ returns 'True' if the device has data + -- to read (if @write@ is 'False') or space to write new data (if + -- @write@ is 'True'). @msecs@ specifies how long to wait, in + -- milliseconds. + -- + ready :: a -> Bool -> Int -> IO Bool + + -- | closes the device. Further operations on the device should + -- produce exceptions. + close :: a -> IO () + + -- | returns 'True' if the device is a terminal or console. + isTerminal :: a -> IO Bool + isTerminal _ = return False + + -- | returns 'True' if the device supports 'seek' operations. + isSeekable :: a -> IO Bool + isSeekable _ = return False + + -- | seek to the specified positing in the data. + seek :: a -> SeekMode -> Integer -> IO () + seek _ _ _ = ioe_unsupportedOperation + + -- | return the current position in the data. + tell :: a -> IO Integer + tell _ = ioe_unsupportedOperation + + -- | return the size of the data. + getSize :: a -> IO Integer + getSize _ = ioe_unsupportedOperation + + -- | change the size of the data. + setSize :: a -> Integer -> IO () + setSize _ _ = ioe_unsupportedOperation + + -- | for terminal devices, changes whether characters are echoed on + -- the device. + setEcho :: a -> Bool -> IO () + setEcho _ _ = ioe_unsupportedOperation + + -- | returns the current echoing status. + getEcho :: a -> IO Bool + getEcho _ = ioe_unsupportedOperation + + -- | some devices (e.g. terminals) support a "raw" mode where + -- characters entered are immediately made available to the program. + -- If available, this operations enables raw mode. + setRaw :: a -> Bool -> IO () + setRaw _ _ = ioe_unsupportedOperation + + -- | returns the 'IODeviceType' corresponding to this device. + devType :: a -> IO IODeviceType + + -- | duplicates the device, if possible. The new device is expected + -- to share a file pointer with the original device (like Unix @dup@). + dup :: a -> IO a + dup _ = ioe_unsupportedOperation + + -- | @dup2 source target@ replaces the target device with the source + -- device. The target device is closed first, if necessary, and then + -- it is made into a duplicate of the first device (like Unix @dup2@). + dup2 :: a -> a -> IO a + dup2 _ _ = ioe_unsupportedOperation + +ioe_unsupportedOperation :: IO a +ioe_unsupportedOperation = throwIO unsupportedOperation + +data IODeviceType + = Directory + | Stream + | RegularFile + | RawDevice + deriving (Eq) + +-- ----------------------------------------------------------------------------- +-- SeekMode type + +-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: +data SeekMode + = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. + | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ + -- from the current position. + | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ + -- from the end of the file. + deriving (Eq, Ord, Ix, Enum, Read, Show) diff --git a/libraries/base/GHC/IO/Encoding.hs b/libraries/base/GHC/IO/Encoding.hs new file mode 100644 index 0000000000..cf1584e4cc --- /dev/null +++ b/libraries/base/GHC/IO/Encoding.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Text codecs for I/O +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding ( + BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, + latin1, latin1_encode, latin1_decode, + utf8, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding, + mkTextEncoding, + ) where + +import GHC.Base +import GHC.IO +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +#if !defined(mingw32_HOST_OS) +import qualified GHC.IO.Encoding.Iconv as Iconv +#endif +import qualified GHC.IO.Encoding.Latin1 as Latin1 +import qualified GHC.IO.Encoding.UTF8 as UTF8 +import qualified GHC.IO.Encoding.UTF16 as UTF16 +import qualified GHC.IO.Encoding.UTF32 as UTF32 + +#if defined(mingw32_HOST_OS) +import Data.Maybe +import GHC.IO.Exception +#endif + +-- ----------------------------------------------------------------------------- + +latin1, utf8, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding + :: TextEncoding + +-- | The Latin1 (ISO8859-1) encoding. This encoding maps bytes +-- directly to the first 256 Unicode code points, and is thus not a +-- complete Unicode encoding. +latin1 = Latin1.latin1_checked + +-- | The UTF-8 unicode encoding +utf8 = UTF8.utf8 + +-- | The UTF-16 unicode encoding (a byte-order-mark should be used to +-- indicate endianness). +utf16 = UTF16.utf16 + +-- | The UTF-16 unicode encoding (litte-endian) +utf16le = UTF16.utf16le + +-- | The UTF-16 unicode encoding (big-endian) +utf16be = UTF16.utf16be + +-- | The UTF-32 unicode encoding (a byte-order-mark should be used to +-- indicate endianness). +utf32 = UTF32.utf32 + +-- | The UTF-32 unicode encoding (litte-endian) +utf32le = UTF32.utf32le + +-- | The UTF-32 unicode encoding (big-endian) +utf32be = UTF32.utf32be + +-- | The text encoding of the current locale +#if !defined(mingw32_HOST_OS) +localeEncoding = Iconv.localeEncoding +#else +localeEncoding = Latin1.latin1 +#endif + +-- | Acquire the named text encoding +mkTextEncoding :: String -> IO TextEncoding +#if !defined(mingw32_HOST_OS) +mkTextEncoding = Iconv.mkTextEncoding +#else +mkTextEncoding "UTF-8" = return utf8 +mkTextEncoding "UTF-16" = return utf16 +mkTextEncoding "UTF-16LE" = return utf16le +mkTextEncoding "UTF-16BE" = return utf16be +mkTextEncoding "UTF-32" = return utf32 +mkTextEncoding "UTF-32LE" = return utf32le +mkTextEncoding "UTF-32BE" = return utf32be +mkTextEncoding e = ioException + (IOError Nothing InvalidArgument "mkTextEncoding" + ("unknown encoding:" ++ e) Nothing Nothing) +#endif + +latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) +latin1_encode = Latin1.latin1_encode -- unchecked, used for binary +--latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode + +latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) +latin1_decode = Latin1.latin1_decode +--latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode diff --git a/libraries/base/GHC/IO/Encoding/Iconv.hs b/libraries/base/GHC/IO/Encoding/Iconv.hs new file mode 100644 index 0000000000..cca3ebce06 --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/Iconv.hs @@ -0,0 +1,212 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Iconv +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module provides text encoding/decoding using iconv +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Encoding.Iconv ( +#if !defined(mingw32_HOST_OS) + mkTextEncoding, + latin1, + utf8, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding +#endif + ) where + +#if !defined(mingw32_HOST_OS) + +#undef DEBUG_DUMP + +import Foreign +import Foreign.C +import Data.Maybe +import GHC.Base +import GHC.Word +import GHC.IO +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Num +import GHC.Show +import GHC.Real +#ifdef DEBUG_DUMP +import System.Posix.Internals +#endif + +iconv_trace :: String -> IO () + +#ifdef DEBUG_DUMP + +iconv_trace s = puts s + +puts :: String -> IO () +puts s = do withCStringLen (s++"\n") $ \(p,len) -> + c_write 1 p (fromIntegral len) + return () + +#else + +iconv_trace _ = return () + +#endif + +-- ----------------------------------------------------------------------------- +-- iconv encoders/decoders + +{-# NOINLINE latin1 #-} +latin1 :: TextEncoding +latin1 = unsafePerformIO (mkTextEncoding "Latin1") + +{-# NOINLINE utf8 #-} +utf8 :: TextEncoding +utf8 = unsafePerformIO (mkTextEncoding "UTF8") + +{-# NOINLINE utf16 #-} +utf16 :: TextEncoding +utf16 = unsafePerformIO (mkTextEncoding "UTF16") + +{-# NOINLINE utf16le #-} +utf16le :: TextEncoding +utf16le = unsafePerformIO (mkTextEncoding "UTF16LE") + +{-# NOINLINE utf16be #-} +utf16be :: TextEncoding +utf16be = unsafePerformIO (mkTextEncoding "UTF16BE") + +{-# NOINLINE utf32 #-} +utf32 :: TextEncoding +utf32 = unsafePerformIO (mkTextEncoding "UTF32") + +{-# NOINLINE utf32le #-} +utf32le :: TextEncoding +utf32le = unsafePerformIO (mkTextEncoding "UTF32LE") + +{-# NOINLINE utf32be #-} +utf32be :: TextEncoding +utf32be = unsafePerformIO (mkTextEncoding "UTF32BE") + +{-# NOINLINE localeEncoding #-} +localeEncoding :: TextEncoding +localeEncoding = unsafePerformIO (mkTextEncoding "") + +-- We hope iconv_t is a storable type. It should be, since it has at least the +-- value -1, which is a possible return value from iconv_open. +type IConv = CLong -- ToDo: (#type iconv_t) + +foreign import ccall unsafe "iconv_open" + iconv_open :: CString -> CString -> IO IConv + +foreign import ccall unsafe "iconv_close" + iconv_close :: IConv -> IO CInt + +foreign import ccall unsafe "iconv" + iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize + -> IO CSize + +haskellChar :: String +#ifdef WORDS_BIGENDIAN +haskellChar | charSize == 2 = "UTF16BE" + | otherwise = "UCS-4" +#else +haskellChar | charSize == 2 = "UTF16LE" + | otherwise = "UCS-4LE" +#endif + +char_shift :: Int +char_shift | charSize == 2 = 1 + | otherwise = 2 + +mkTextEncoding :: String -> IO TextEncoding +mkTextEncoding charset = do + return (TextEncoding { + mkTextDecoder = newIConv charset haskellChar iconvDecode, + mkTextEncoder = newIConv haskellChar charset iconvEncode}) + +newIConv :: String -> String + -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) + -> IO (BufferCodec a b) +newIConv from to fn = + withCString from $ \ from_str -> + withCString to $ \ to_str -> do + iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ iconv_open to_str from_str + let iclose = do throwErrnoIfMinus1 "Iconv.close" $ iconv_close iconvt + return () + return BufferCodec{ + encode = fn iconvt, + close = iclose + } + +iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem + -> IO (Buffer Word8, Buffer CharBufElem) +iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift + +iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8 + -> IO (Buffer CharBufElem, Buffer Word8) +iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0 + +iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int + -> IO (Buffer a, Buffer b) +iconvRecode iconv_t + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } iscale + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } oscale + = do + iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input)) + iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output)) + withRawBuffer iraw $ \ piraw -> do + withRawBuffer oraw $ \ poraw -> do + with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do + with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do + with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do + with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do + res <- iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft + new_inleft <- peek p_inleft + new_outleft <- peek p_outleft + let + new_inleft' = fromIntegral new_inleft `shiftR` iscale + new_outleft' = fromIntegral new_outleft `shiftR` oscale + new_input + | new_inleft == 0 = input { bufL = 0, bufR = 0 } + | otherwise = input { bufL = iw - new_inleft' } + new_output = output{ bufR = os - new_outleft' } + iconv_trace ("iconv res=" ++ show res) + iconv_trace ("iconvRecode after, input=" ++ show (summaryBuffer new_input)) + iconv_trace ("iconvRecode after, output=" ++ show (summaryBuffer new_output)) + if (res /= -1) + then do -- all input translated + return (new_input, new_output) + else do + errno <- getErrno + case errno of + e | e == eINVAL + || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do + iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing)) + -- Output overflow is relatively harmless, unless + -- we made no progress at all. + -- + -- Similarly, we ignore EILSEQ unless we converted no + -- characters. Sometimes iconv reports EILSEQ for a + -- character in the input even when there is no room + -- in the output; in this case we might be about to + -- change the encoding anyway, so the following bytes + -- could very well be in a different encoding. + -- This also helps with pinpointing EILSEQ errors: we + -- don't report it until the rest of the characters in + -- the buffer have been drained. + return (new_input, new_output) + + _other -> + throwErrno "iconvRecoder" + -- illegal sequence, or some other error + +#endif /* !mingw32_HOST_OS */ diff --git a/libraries/base/GHC/IO/Encoding/Latin1.hs b/libraries/base/GHC/IO/Encoding/Latin1.hs new file mode 100644 index 0000000000..60598f69c6 --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/Latin1.hs @@ -0,0 +1,118 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Latin1 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-32 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.Latin1 ( + latin1, + latin1_checked, + latin1_decode, + latin1_encode, + latin1_checked_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import Data.Maybe + +-- ----------------------------------------------------------------------------- +-- Latin1 + +latin1 :: TextEncoding +latin1 = TextEncoding { mkTextDecoder = latin1_DF, + mkTextEncoder = latin1_EF } + +latin1_DF :: IO TextDecoder +latin1_DF = return (BufferCodec latin1_decode (return ())) + +latin1_EF :: IO TextEncoder +latin1_EF = return (BufferCodec latin1_encode (return ())) + +latin1_checked :: TextEncoding +latin1_checked = TextEncoding { mkTextDecoder = latin1_DF, + mkTextEncoder = latin1_checked_EF } + +latin1_checked_EF :: IO TextEncoder +latin1_checked_EF = return (BufferCodec latin1_checked_encode (return ())) + + +latin1_decode :: DecodeBuffer +latin1_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) (ow+1) + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +latin1_encode :: EncodeBuffer +latin1_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + writeWord8Buf oraw ow (fromIntegral (ord c)) + loop ir' (ow+1) + in + loop ir0 ow0 + +latin1_checked_encode :: EncodeBuffer +latin1_checked_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + if ord c > 0xff then invalid else do + writeWord8Buf oraw ow (fromIntegral (ord c)) + loop ir' (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_encodingError + in + loop ir0 ow0 + +ioe_encodingError :: IO a +ioe_encodingError = ioException + (IOError Nothing InvalidArgument "latin1_checked_encode" + "character is out of range for this encoding" Nothing Nothing) diff --git a/libraries/base/GHC/IO/Encoding/Types.hs b/libraries/base/GHC/IO/Encoding/Types.hs new file mode 100644 index 0000000000..b857bdf4d7 --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/Types.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Types +-- Copyright : (c) The University of Glasgow, 2008-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Types for text encoding/decoding +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.Types ( + BufferCodec(..), + TextEncoding(..), + TextEncoder, TextDecoder, + EncodeBuffer, DecodeBuffer, + ) where + +import GHC.Base +import GHC.Word +import GHC.IO +import GHC.IO.Buffer + +-- ----------------------------------------------------------------------------- +-- Text encoders/decoders + +data BufferCodec from to = BufferCodec { + encode :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to), + -- ^ The @encode@ function translates elements of the buffer @from@ + -- to the buffer @to@. It should translate as many elements as possible + -- given the sizes of the buffers, including translating zero elements + -- if there is either not enough room in @to@, or @from@ does not + -- contain a complete multibyte sequence. + -- + -- @encode@ should raise an exception if, and only if, @from@ + -- begins with an illegal sequence, or the first element of @from@ + -- is not representable in the encoding of @to@. That is, if any + -- elements can be successfully translated before an error is + -- encountered, then @encode@ should translate as much as it can + -- and not throw an exception. This behaviour is used by the IO + -- library in order to report translation errors at the point they + -- actually occur, rather than when the buffer is translated. + -- + close :: IO () + -- ^ Resources associated with the encoding may now be released. + -- The @encode@ function may not be called again after calling + -- @close@. + } + +type DecodeBuffer = Buffer Word8 -> Buffer Char + -> IO (Buffer Word8, Buffer Char) + +type EncodeBuffer = Buffer Char -> Buffer Word8 + -> IO (Buffer Char, Buffer Word8) + +type TextDecoder = BufferCodec Word8 CharBufElem +type TextEncoder = BufferCodec CharBufElem Word8 + +-- | A 'TextEncoding' is a specification of a conversion scheme +-- between sequences of bytes and sequences of Unicode characters. +-- +-- For example, UTF-8 is an encoding of Unicode characters into a sequence +-- of bytes. The 'TextEncoding' for UTF-8 is 'utf_8'. +data TextEncoding + = TextEncoding { + mkTextDecoder :: IO TextDecoder, + mkTextEncoder :: IO TextEncoder + } diff --git a/libraries/base/GHC/IO/Encoding/UTF16.hs b/libraries/base/GHC/IO/Encoding/UTF16.hs new file mode 100644 index 0000000000..e3801c0937 --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/UTF16.hs @@ -0,0 +1,310 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF16 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-16 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF16 ( + utf16, + utf16_decode, + utf16_encode, + + utf16be, + utf16be_decode, + utf16be_encode, + + utf16le, + utf16le_decode, + utf16le_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe +import GHC.IORef + +#if DEBUG +import System.Posix.Internals +import Foreign.C +import GHC.Show + +puts :: String -> IO () +puts s = do withCStringLen (s++"\n") $ \(p,len) -> + c_write 1 p (fromIntegral len) + return () +#endif + +-- ----------------------------------------------------------------------------- +-- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM + +utf16 :: TextEncoding +utf16 = TextEncoding { mkTextDecoder = utf16_DF, + mkTextEncoder = utf16_EF } + +utf16_DF :: IO TextDecoder +utf16_DF = do + seen_bom <- newIORef Nothing + return (BufferCodec (utf16_decode seen_bom) (return ())) + +utf16_EF :: IO TextEncoder +utf16_EF = do + done_bom <- newIORef False + return (BufferCodec (utf16_encode done_bom) (return ())) + +utf16_encode :: IORef Bool -> EncodeBuffer +utf16_encode done_bom input + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + = do + b <- readIORef done_bom + if b then utf16_native_encode input output + else if os - ow < 2 + then return (input,output) + else do + writeIORef done_bom True + writeWord8Buf oraw ow bom1 + writeWord8Buf oraw (ow+1) bom2 + utf16_native_encode input output{ bufR = ow+2 } + +utf16_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf16_decode seen_bom + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } + output + = do + mb <- readIORef seen_bom + case mb of + Just decode -> decode input output + Nothing -> + if iw - ir < 2 then return (input,output) else do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + case () of + _ | c0 == bomB && c1 == bomL -> do + writeIORef seen_bom (Just utf16be_decode) + utf16be_decode input{ bufL= ir+2 } output + | c0 == bomL && c1 == bomB -> do + writeIORef seen_bom (Just utf16le_decode) + utf16le_decode input{ bufL= ir+2 } output + | otherwise -> do + writeIORef seen_bom (Just utf16_native_decode) + utf16_native_decode input output + + +bomB, bomL, bom1, bom2 :: Word8 +bomB = 0xfe +bomL = 0xff + +-- choose UTF-16BE by default for UTF-16 output +utf16_native_decode :: DecodeBuffer +utf16_native_decode = utf16be_decode + +utf16_native_encode :: EncodeBuffer +utf16_native_encode = utf16be_encode + +bom1 = bomB +bom2 = bomL + +-- ----------------------------------------------------------------------------- +-- UTF16LE and UTF16BE + +utf16be :: TextEncoding +utf16be = TextEncoding { mkTextDecoder = utf16be_DF, + mkTextEncoder = utf16be_EF } + +utf16be_DF :: IO TextDecoder +utf16be_DF = return (BufferCodec utf16be_decode (return ())) + +utf16be_EF :: IO TextEncoder +utf16be_EF = return (BufferCodec utf16be_encode (return ())) + + +utf16le :: TextEncoding +utf16le = TextEncoding { mkTextDecoder = utf16le_DF, + mkTextEncoder = utf16le_EF } + +utf16le_DF :: IO TextDecoder +utf16le_DF = return (BufferCodec utf16le_decode (return ())) + +utf16le_EF :: IO TextEncoder +utf16le_EF = return (BufferCodec utf16le_encode (return ())) + + + +utf16be_decode :: DecodeBuffer +utf16be_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | ir + 1 == iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + let x1 = fromIntegral c0 `shiftL` 8 + fromIntegral c1 + if validate1 x1 + then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) + loop (ir+2) (ow+1) + else if iw - ir < 4 then done ir ow else do + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 + if not (validate2 x1 x2) then invalid else do + writeCharBuf oraw ow (chr2 x1 x2) + loop (ir+4) (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +utf16le_decode :: DecodeBuffer +utf16le_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | ir + 1 == iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0 + if validate1 x1 + then do writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) + loop (ir+2) (ow+1) + else if iw - ir < 4 then done ir ow else do + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 + if not (validate2 x1 x2) then invalid else do + writeCharBuf oraw ow (chr2 x1 x2) + loop (ir+4) (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf16_decode" + "invalid UTF-16 byte sequence" Nothing Nothing) + +utf16be_encode :: EncodeBuffer +utf16be_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 2 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x < 0x10000 -> do + writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8)) + writeWord8Buf oraw (ow+1) (fromIntegral x) + loop ir' (ow+2) + | otherwise -> do + if os - ow < 4 then done ir ow else do + let + n1 = x - 0x10000 + c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) + c2 = fromIntegral (n1 `shiftR` 10) + n2 = n1 .&. 0x3FF + c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) + c4 = fromIntegral n2 + -- + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + writeWord8Buf oraw (ow+3) c4 + loop ir' (ow+4) + in + loop ir0 ow0 + +utf16le_encode :: EncodeBuffer +utf16le_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 2 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x < 0x10000 -> do + writeWord8Buf oraw ow (fromIntegral x) + writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) + loop ir' (ow+2) + | otherwise -> + if os - ow < 4 then done ir ow else do + let + n1 = x - 0x10000 + c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) + c2 = fromIntegral (n1 `shiftR` 10) + n2 = n1 .&. 0x3FF + c3 = fromIntegral (n2 `shiftR` 8 + 0xDC) + c4 = fromIntegral n2 + -- + writeWord8Buf oraw ow c2 + writeWord8Buf oraw (ow+1) c1 + writeWord8Buf oraw (ow+2) c4 + writeWord8Buf oraw (ow+3) c3 + loop ir' (ow+4) + in + loop ir0 ow0 + +chr2 :: Word16 -> Word16 -> Char +chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) + where + !x# = word2Int# a# + !y# = word2Int# b# + !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10# + !lower# = y# -# 0xDC00# +{-# INLINE chr2 #-} + +validate1 :: Word16 -> Bool +validate1 x1 = (x1 >= 0 && x1 < 0xD800) || x1 > 0xDFFF +{-# INLINE validate1 #-} + +validate2 :: Word16 -> Word16 -> Bool +validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF && + x2 >= 0xDC00 && x2 <= 0xDFFF +{-# INLINE validate2 #-} diff --git a/libraries/base/GHC/IO/Encoding/UTF32.hs b/libraries/base/GHC/IO/Encoding/UTF32.hs new file mode 100644 index 0000000000..b26aaae795 --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/UTF32.hs @@ -0,0 +1,273 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF32 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-32 Codecs for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF32 ( + utf32, + utf32_decode, + utf32_encode, + + utf32be, + utf32be_decode, + utf32be_encode, + + utf32le, + utf32le_decode, + utf32le_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe +import GHC.IORef + +-- ----------------------------------------------------------------------------- +-- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM + +utf32 :: TextEncoding +utf32 = TextEncoding { mkTextDecoder = utf32_DF, + mkTextEncoder = utf32_EF } + +utf32_DF :: IO TextDecoder +utf32_DF = do + seen_bom <- newIORef Nothing + return (BufferCodec (utf32_decode seen_bom) (return ())) + +utf32_EF :: IO TextEncoder +utf32_EF = do + done_bom <- newIORef False + return (BufferCodec (utf32_encode done_bom) (return ())) + +utf32_encode :: IORef Bool -> EncodeBuffer +utf32_encode done_bom input + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } + = do + b <- readIORef done_bom + if b then utf32_native_encode input output + else if os - ow < 4 + then return (input,output) + else do + writeIORef done_bom True + writeWord8Buf oraw ow bom0 + writeWord8Buf oraw (ow+1) bom1 + writeWord8Buf oraw (ow+2) bom2 + writeWord8Buf oraw (ow+3) bom3 + utf32_native_encode input output{ bufR = ow+4 } + +utf32_decode :: IORef (Maybe DecodeBuffer) -> DecodeBuffer +utf32_decode seen_bom + input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } + output + = do + mb <- readIORef seen_bom + case mb of + Just decode -> decode input output + Nothing -> + if iw - ir < 4 then return (input,output) else do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + case () of + _ | c0 == bom0 && c1 == bom1 && c2 == bom2 && c3 == bom3 -> do + writeIORef seen_bom (Just utf32be_decode) + utf32be_decode input{ bufL= ir+4 } output + _ | c0 == bom3 && c1 == bom2 && c2 == bom1 && c3 == bom0 -> do + writeIORef seen_bom (Just utf32le_decode) + utf32le_decode input{ bufL= ir+4 } output + | otherwise -> do + writeIORef seen_bom (Just utf32_native_decode) + utf32_native_decode input output + + +bom0, bom1, bom2, bom3 :: Word8 +bom0 = 0 +bom1 = 0 +bom2 = 0xfe +bom3 = 0xff + +-- choose UTF-32BE by default for UTF-32 output +utf32_native_decode :: DecodeBuffer +utf32_native_decode = utf32be_decode + +utf32_native_encode :: EncodeBuffer +utf32_native_encode = utf32be_encode + +-- ----------------------------------------------------------------------------- +-- UTF32LE and UTF32BE + +utf32be :: TextEncoding +utf32be = TextEncoding { mkTextDecoder = utf32be_DF, + mkTextEncoder = utf32be_EF } + +utf32be_DF :: IO TextDecoder +utf32be_DF = return (BufferCodec utf32be_decode (return ())) + +utf32be_EF :: IO TextEncoder +utf32be_EF = return (BufferCodec utf32be_encode (return ())) + + +utf32le :: TextEncoding +utf32le = TextEncoding { mkTextDecoder = utf32le_DF, + mkTextEncoder = utf32le_EF } + +utf32le_DF :: IO TextDecoder +utf32le_DF = return (BufferCodec utf32le_decode (return ())) + +utf32le_EF :: IO TextEncoder +utf32le_EF = return (BufferCodec utf32le_encode (return ())) + + + +utf32be_decode :: DecodeBuffer +utf32be_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || iw - ir < 4 = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x1 = chr4 c0 c1 c2 c3 + if not (validate x1) then invalid else do + writeCharBuf oraw ow x1 + loop (ir+4) (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +utf32le_decode :: DecodeBuffer +utf32le_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || iw - ir < 4 = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + let x1 = chr4 c3 c2 c1 c0 + if not (validate x1) then invalid else do + writeCharBuf oraw ow x1 + loop (ir+4) (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf32_decode" + "invalid UTF-32 byte sequence" Nothing Nothing) + +utf32be_encode :: EncodeBuffer +utf32be_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 4 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c0 + writeWord8Buf oraw (ow+1) c1 + writeWord8Buf oraw (ow+2) c2 + writeWord8Buf oraw (ow+3) c3 + loop ir' (ow+4) + in + loop ir0 ow0 + +utf32le_encode :: EncodeBuffer +utf32le_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ir >= iw = done ir ow + | os - ow < 4 = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c3 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c1 + writeWord8Buf oraw (ow+3) c0 + loop ir' (ow+4) + in + loop ir0 ow0 + +chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char +chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = + C# (chr# (z1# +# z2# +# z3# +# z4#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !y4# = word2Int# x4# + !z1# = uncheckedIShiftL# y1# 24# + !z2# = uncheckedIShiftL# y2# 16# + !z3# = uncheckedIShiftL# y3# 8# + !z4# = y4# +{-# INLINE chr4 #-} + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = (fromIntegral (x `shiftR` 24), + fromIntegral (x `shiftR` 16), + fromIntegral (x `shiftR` 8), + fromIntegral x) + where + x = ord c +{-# INLINE ord4 #-} + + +validate :: Char -> Bool +validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF) + where x1 = ord c +{-# INLINE validate #-} diff --git a/libraries/base/GHC/IO/Encoding/UTF8.hs b/libraries/base/GHC/IO/Encoding/UTF8.hs new file mode 100644 index 0000000000..43adff17eb --- /dev/null +++ b/libraries/base/GHC/IO/Encoding/UTF8.hs @@ -0,0 +1,242 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.UTF8 +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- UTF-8 Codec for the IO library +-- +-- Portions Copyright : (c) Tom Harper 2008-2009, +-- (c) Bryan O'Sullivan 2009, +-- (c) Duncan Coutts 2009 +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.UTF8 ( + utf8, + utf8_decode, + utf8_encode, + ) where + +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Types +import GHC.Word +import Data.Bits +import Data.Maybe + +utf8 :: TextEncoding +utf8 = TextEncoding { mkTextDecoder = utf8_DF, + mkTextEncoder = utf8_EF } + +utf8_DF :: IO TextDecoder +utf8_DF = return (BufferCodec utf8_decode (return ())) + +utf8_EF :: IO TextEncoder +utf8_EF = return (BufferCodec utf8_encode (return ())) + +utf8_decode :: DecodeBuffer +utf8_decode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + c0 <- readWord8Buf iraw ir + case c0 of + _ | c0 <= 0x7f -> do + writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) + loop (ir+1) (ow+1) + | c0 >= 0xc0 && c0 <= 0xdf -> + if iw - ir < 2 then done ir ow else do + c1 <- readWord8Buf iraw (ir+1) + if (c1 < 0x80 || c1 >= 0xc0) then invalid else do + writeCharBuf oraw ow (chr2 c0 c1) + loop (ir+2) (ow+1) + | c0 >= 0xe0 && c0 <= 0xef -> + if iw - ir < 3 then done ir ow else do + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + if not (validate3 c0 c1 c2) then invalid else do + writeCharBuf oraw ow (chr3 c0 c1 c2) + loop (ir+3) (ow+1) + | otherwise -> + if iw - ir < 4 then done ir ow else do + c1 <- readWord8Buf iraw (ir+1) + c2 <- readWord8Buf iraw (ir+2) + c3 <- readWord8Buf iraw (ir+3) + if not (validate4 c0 c1 c2 c3) then invalid else do + writeCharBuf oraw ow (chr4 c0 c1 c2 c3) + loop (ir+4) (ow+1) + where + invalid = if ir > ir0 then done ir ow else ioe_decodingError + + -- lambda-lifted, to avoid thunks being built in the inner-loop: + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + in + loop ir0 ow0 + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "utf8_decode" + "invalid UTF-8 byte sequence" Nothing Nothing) + +utf8_encode :: EncodeBuffer +utf8_encode + input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } + = let + done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) + loop !ir !ow + | ow >= os || ir >= iw = done ir ow + | otherwise = do + (c,ir') <- readCharBuf iraw ir + case ord c of + x | x <= 0x7F -> do + writeWord8Buf oraw ow (fromIntegral x) + loop ir' (ow+1) + | x <= 0x07FF -> + if os - ow < 2 then done ir ow else do + let (c1,c2) = ord2 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + loop ir' (ow+2) + | x <= 0xFFFF -> do + if os - ow < 3 then done ir ow else do + let (c1,c2,c3) = ord3 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + loop ir' (ow+3) + | otherwise -> do + if os - ow < 4 then done ir ow else do + let (c1,c2,c3,c4) = ord4 c + writeWord8Buf oraw ow c1 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c3 + writeWord8Buf oraw (ow+3) c4 + loop ir' (ow+4) + in + loop ir0 ow0 + +-- ----------------------------------------------------------------------------- +-- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8 + +ord2 :: Char -> (Word8,Word8) +ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8,Word8,Word8) +ord3 c = assert (n >= 0x0800 && n <= 0xffff) (x1,x2,x3) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +chr2 :: Word8 -> Word8 -> Char +chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# + !z2# = y2# -# 0x80# +{-# INLINE chr2 #-} + +chr3 :: Word8 -> Word8 -> Word8 -> Char +chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# + !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# + !z3# = y3# -# 0x80# +{-# INLINE chr3 #-} + +chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char +chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = + C# (chr# (z1# +# z2# +# z3# +# z4#)) + where + !y1# = word2Int# x1# + !y2# = word2Int# x2# + !y3# = word2Int# x3# + !y4# = word2Int# x4# + !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# + !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# + !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# + !z4# = y4# -# 0x80# +{-# INLINE chr4 #-} + +between :: Word8 -- ^ byte to check + -> Word8 -- ^ lower bound + -> Word8 -- ^ upper bound + -> Bool +between x y z = x >= y && x <= z +{-# INLINE between #-} + +validate3 :: Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate3 #-} +validate3 x1 x2 x3 = validate3_1 || + validate3_2 || + validate3_3 || + validate3_4 + where + validate3_1 = (x1 == 0xE0) && + between x2 0xA0 0xBF && + between x3 0x80 0xBF + validate3_2 = between x1 0xE1 0xEC && + between x2 0x80 0xBF && + between x3 0x80 0xBF + validate3_3 = x1 == 0xED && + between x2 0x80 0x9F && + between x3 0x80 0xBF + validate3_4 = between x1 0xEE 0xEF && + between x2 0x80 0xBF && + between x3 0x80 0xBF + +validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool +{-# INLINE validate4 #-} +validate4 x1 x2 x3 x4 = validate4_1 || + validate4_2 || + validate4_3 + where + validate4_1 = x1 == 0xF0 && + between x2 0x90 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_2 = between x1 0xF1 0xF3 && + between x2 0x80 0xBF && + between x3 0x80 0xBF && + between x4 0x80 0xBF + validate4_3 = x1 == 0xF4 && + between x2 0x80 0x8F && + between x3 0x80 0xBF && + between x4 0x80 0xBF diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs new file mode 100644 index 0000000000..232ed83abc --- /dev/null +++ b/libraries/base/GHC/IO/Exception.hs @@ -0,0 +1,336 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Exception +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- IO-related Exception types and functions +-- +----------------------------------------------------------------------------- + +module GHC.IO.Exception ( + BlockedOnDeadMVar(..), blockedOnDeadMVar, + BlockedIndefinitely(..), blockedIndefinitely, + Deadlock(..), + AssertionFailed(..), + AsyncException(..), stackOverflow, heapOverflow, + ArrayException(..), + ExitCode(..), + + ioException, + ioError, + IOError, + IOException(..), + IOErrorType(..), + userError, + assertError, + unsupportedOperation, + untangle, + ) where + +import GHC.Base +import GHC.List +import GHC.IO +import GHC.Show +import GHC.Read +import GHC.Exception +import Data.Maybe +import GHC.IO.Handle.Types +import Foreign.C.Types + +import Data.Typeable ( Typeable ) + +-- ------------------------------------------------------------------------ +-- Exception datatypes and operations + +-- |The thread is blocked on an @MVar@, but there are no other references +-- to the @MVar@ so it can't ever continue. +data BlockedOnDeadMVar = BlockedOnDeadMVar + deriving Typeable + +instance Exception BlockedOnDeadMVar + +instance Show BlockedOnDeadMVar where + showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" + +blockedOnDeadMVar :: SomeException -- for the RTS +blockedOnDeadMVar = toException BlockedOnDeadMVar + +----- + +-- |The thread is awiting to retry an STM transaction, but there are no +-- other references to any @TVar@s involved, so it can't ever continue. +data BlockedIndefinitely = BlockedIndefinitely + deriving Typeable + +instance Exception BlockedIndefinitely + +instance Show BlockedIndefinitely where + showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" + +blockedIndefinitely :: SomeException -- for the RTS +blockedIndefinitely = toException BlockedIndefinitely + +----- + +-- |There are no runnable threads, so the program is deadlocked. +-- The @Deadlock@ exception is raised in the main thread only. +data Deadlock = Deadlock + deriving Typeable + +instance Exception Deadlock + +instance Show Deadlock where + showsPrec _ Deadlock = showString "<<deadlock>>" + +----- + +-- |There are no runnable threads, so the program is deadlocked. +-- The @Deadlock@ exception is raised in the main thread only. +data AssertionFailed = AssertionFailed String + deriving Typeable + +instance Exception AssertionFailed + +instance Show AssertionFailed where + showsPrec _ (AssertionFailed err) = showString err + +----- + +-- |Asynchronous exceptions. +data AsyncException + = StackOverflow + -- ^The current thread\'s stack exceeded its limit. + -- Since an exception has been raised, the thread\'s stack + -- will certainly be below its limit again, but the + -- programmer should take remedial action + -- immediately. + | HeapOverflow + -- ^The program\'s heap is reaching its limit, and + -- the program should take action to reduce the amount of + -- live data it has. Notes: + -- + -- * It is undefined which thread receives this exception. + -- + -- * GHC currently does not throw 'HeapOverflow' exceptions. + | ThreadKilled + -- ^This exception is raised by another thread + -- calling 'Control.Concurrent.killThread', or by the system + -- if it needs to terminate the thread for some + -- reason. + | UserInterrupt + -- ^This exception is raised by default in the main thread of + -- the program when the user requests to terminate the program + -- via the usual mechanism(s) (e.g. Control-C in the console). + deriving (Eq, Ord, Typeable) + +instance Exception AsyncException + +-- | Exceptions generated by array operations +data ArrayException + = IndexOutOfBounds String + -- ^An attempt was made to index an array outside + -- its declared bounds. + | UndefinedElement String + -- ^An attempt was made to evaluate an element of an + -- array that had not been initialized. + deriving (Eq, Ord, Typeable) + +instance Exception ArrayException + +stackOverflow, heapOverflow :: SomeException -- for the RTS +stackOverflow = toException StackOverflow +heapOverflow = toException HeapOverflow + +instance Show AsyncException where + showsPrec _ StackOverflow = showString "stack overflow" + showsPrec _ HeapOverflow = showString "heap overflow" + showsPrec _ ThreadKilled = showString "thread killed" + showsPrec _ UserInterrupt = showString "user interrupt" + +instance Show ArrayException where + showsPrec _ (IndexOutOfBounds s) + = showString "array index out of range" + . (if not (null s) then showString ": " . showString s + else id) + showsPrec _ (UndefinedElement s) + = showString "undefined array element" + . (if not (null s) then showString ": " . showString s + else id) + +-- ----------------------------------------------------------------------------- +-- The ExitCode type + +-- We need it here because it is used in ExitException in the +-- Exception datatype (above). + +data ExitCode + = ExitSuccess -- ^ indicates successful termination; + | ExitFailure Int + -- ^ indicates program failure with an exit code. + -- The exact interpretation of the code is + -- operating-system dependent. In particular, some values + -- may be prohibited (e.g. 0 on a POSIX-compliant system). + deriving (Eq, Ord, Read, Show, Typeable) + +instance Exception ExitCode + +ioException :: IOException -> IO a +ioException err = throwIO err + +-- | Raise an 'IOError' in the 'IO' monad. +ioError :: IOError -> IO a +ioError = ioException + +-- --------------------------------------------------------------------------- +-- IOError type + +-- | The Haskell 98 type for exceptions in the 'IO' monad. +-- Any I\/O operation may raise an 'IOError' instead of returning a result. +-- For a more general type of exception, including also those that arise +-- in pure code, see 'Control.Exception.Exception'. +-- +-- In Haskell 98, this is an opaque type. +type IOError = IOException + +-- |Exceptions that occur in the @IO@ monad. +-- An @IOException@ records a more specific error type, a descriptive +-- string and maybe the handle that was used when the error was +-- flagged. +data IOException + = IOError { + ioe_handle :: Maybe Handle, -- the handle used by the action flagging + -- the error. + ioe_type :: IOErrorType, -- what it was. + ioe_location :: String, -- location. + ioe_description :: String, -- error type specific information. + ioe_errno :: Maybe CInt, -- errno leading to this error, if any. + ioe_filename :: Maybe FilePath -- filename the error is related to. + } + deriving Typeable + +instance Exception IOException + +instance Eq IOException where + (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) = + e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2 + +-- | An abstract type that contains a value for each variant of 'IOError'. +data IOErrorType + -- Haskell 98: + = AlreadyExists + | NoSuchThing + | ResourceBusy + | ResourceExhausted + | EOF + | IllegalOperation + | PermissionDenied + | UserError + -- GHC only: + | UnsatisfiedConstraints + | SystemError + | ProtocolError + | OtherError + | InvalidArgument + | InappropriateType + | HardwareFault + | UnsupportedOperation + | TimeExpired + | ResourceVanished + | Interrupted + +instance Eq IOErrorType where + x == y = getTag x ==# getTag y + +instance Show IOErrorType where + showsPrec _ e = + showString $ + case e of + AlreadyExists -> "already exists" + NoSuchThing -> "does not exist" + ResourceBusy -> "resource busy" + ResourceExhausted -> "resource exhausted" + EOF -> "end of file" + IllegalOperation -> "illegal operation" + PermissionDenied -> "permission denied" + UserError -> "user error" + HardwareFault -> "hardware fault" + InappropriateType -> "inappropriate type" + Interrupted -> "interrupted" + InvalidArgument -> "invalid argument" + OtherError -> "failed" + ProtocolError -> "protocol error" + ResourceVanished -> "resource vanished" + SystemError -> "system error" + TimeExpired -> "timeout" + UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! + UnsupportedOperation -> "unsupported operation" + +-- | Construct an 'IOError' value with a string describing the error. +-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a +-- 'userError', thus: +-- +-- > instance Monad IO where +-- > ... +-- > fail s = ioError (userError s) +-- +userError :: String -> IOError +userError str = IOError Nothing UserError "" str Nothing Nothing + +-- --------------------------------------------------------------------------- +-- Showing IOErrors + +instance Show IOException where + showsPrec p (IOError hdl iot loc s _ fn) = + (case fn of + Nothing -> case hdl of + Nothing -> id + Just h -> showsPrec p h . showString ": " + Just name -> showString name . showString ": ") . + (case loc of + "" -> id + _ -> showString loc . showString ": ") . + showsPrec p iot . + (case s of + "" -> id + _ -> showString " (" . showString s . showString ")") + +assertError :: Addr# -> Bool -> a -> a +assertError str predicate v + | predicate = v + | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) + +unsupportedOperation :: IOError +unsupportedOperation = + (IOError Nothing UnsupportedOperation "" + "Operation is not supported" Nothing Nothing) + +{- +(untangle coded message) expects "coded" to be of the form + "location|details" +It prints + location message details +-} +untangle :: Addr# -> String -> String +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + coded_str = unpackCStringUtf8# coded + + (location, details) + = case (span not_bar coded_str) of { (loc, rest) -> + case rest of + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") + } + not_bar c = c /= '|' diff --git a/libraries/base/GHC/IO/Exception.hs-boot b/libraries/base/GHC/IO/Exception.hs-boot new file mode 100644 index 0000000000..f1ba7249f6 --- /dev/null +++ b/libraries/base/GHC/IO/Exception.hs-boot @@ -0,0 +1,12 @@ +{-# OPTIONS -fno-implicit-prelude #-} +module GHC.IO.Exception where + +import GHC.Base +import GHC.Exception + +data IOException +instance Exception IOException + +type IOError = IOException +userError :: String -> IOError +unsupportedOperation :: IOError diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs new file mode 100644 index 0000000000..7ceffc3aed --- /dev/null +++ b/libraries/base/GHC/IO/FD.hs @@ -0,0 +1,630 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Raw read/write operations on file descriptors +-- +----------------------------------------------------------------------------- + +module GHC.IO.FD ( + FD(..), + openFile, mkFD, release, + setNonBlockingMode, + readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr, + stdin, stdout, stderr + ) where + +#undef DEBUG_DUMP + +import GHC.Base +import GHC.Num +import GHC.Real +import GHC.Show +import GHC.Enum +import Data.Maybe +import Control.Monad +import Data.Typeable + +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Buffer +import GHC.IO.BufferedIO +import qualified GHC.IO.Device +import GHC.IO.Device (SeekMode(..), IODeviceType(..)) +import GHC.Conc +import GHC.IO.Exception + +import Foreign +import Foreign.C +import qualified System.Posix.Internals +import System.Posix.Internals hiding (FD, setEcho, getEcho) +import System.Posix.Types +import GHC.Ptr + +-- ----------------------------------------------------------------------------- +-- The file-descriptor IO device + +data FD = FD { + fdFD :: {-# UNPACK #-} !CInt, +#ifdef mingw32_HOST_OS + -- On Windows, a socket file descriptor needs to be read and written + -- using different functions (send/recv). + fdIsSocket_ :: {-# UNPACK #-} !Int +#else + -- On Unix we need to know whether this FD has O_NONBLOCK set. + -- If it has, then we can use more efficient routines to read/write to it. + -- It is always safe for this to be off. + fdIsNonBlocking :: {-# UNPACK #-} !Int +#endif + } + deriving Typeable + +#ifdef mingw32_HOST_OS +fdIsSocket :: FD -> Bool +fdIsSocket fd = fdIsSocket_ fd /= 0 +#endif + +instance Show FD where + show fd = show (fdFD fd) + +instance GHC.IO.Device.RawIO FD where + read = fdRead + readNonBlocking = fdReadNonBlocking + write = fdWrite + writeNonBlocking = fdWriteNonBlocking + +instance GHC.IO.Device.IODevice FD where + ready = ready + close = close + isTerminal = isTerminal + isSeekable = isSeekable + seek = seek + tell = tell + getSize = getSize + setSize = setSize + setEcho = setEcho + getEcho = getEcho + setRaw = setRaw + devType = devType + dup = dup + dup2 = dup2 + +instance BufferedIO FD where + newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state + fillReadBuffer fd buf = readBuf' fd buf + fillReadBuffer0 fd buf = readBufNonBlocking fd buf + flushWriteBuffer fd buf = writeBuf' fd buf + flushWriteBuffer0 fd buf = writeBufNonBlocking fd buf + +readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8) +readBuf' fd buf = do +#ifdef DEBUG_DUMP + puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") +#endif + (r,buf') <- readBuf fd buf +#ifdef DEBUG_DUMP + puts ("after: " ++ summaryBuffer buf' ++ "\n") +#endif + return (r,buf') + +writeBuf' :: FD -> Buffer Word8 -> IO () +writeBuf' fd buf = do +#ifdef DEBUG_DUMP + puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") +#endif + writeBuf fd buf + +-- ----------------------------------------------------------------------------- +-- opening files + +-- | Open a file and make an 'FD' for it. Truncates the file to zero +-- size when the `IOMode` is `WriteMode`. Puts the file descriptor +-- into non-blocking mode on Unix systems. +openFile :: FilePath -> IOMode -> IO (FD,IODeviceType) +openFile filepath iomode = + withCString filepath $ \ f -> + + let + oflags1 = case iomode of + ReadMode -> read_flags +#ifdef mingw32_HOST_OS + WriteMode -> write_flags .|. o_TRUNC +#else + WriteMode -> write_flags +#endif + ReadWriteMode -> rw_flags + AppendMode -> append_flags + +#ifdef mingw32_HOST_OS + binary_flags = o_BINARY +#else + binary_flags = 0 +#endif + + oflags = oflags1 .|. binary_flags + in do + + -- the old implementation had a complicated series of three opens, + -- which is perhaps because we have to be careful not to open + -- directories. However, the man pages I've read say that open() + -- always returns EISDIR if the file is a directory and was opened + -- for writing, so I think we're ok with a single open() here... + fd <- throwErrnoIfMinus1Retry "openFile" + (c_open f (fromIntegral oflags) 0o666) + + (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} + False{-not a socket-} + True{-is non-blocking-} + `catchAny` \e -> do c_close fd; throwIO e + +#ifndef mingw32_HOST_OS + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + if iomode == WriteMode && fd_type == RegularFile + then setSize fD 0 + else return () +#endif + + return (fD,fd_type) + +std_flags, output_flags, read_flags, write_flags, rw_flags, + append_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +read_flags = std_flags .|. o_RDONLY +write_flags = output_flags .|. o_WRONLY +rw_flags = output_flags .|. o_RDWR +append_flags = write_flags .|. o_APPEND + + +-- | Make a 'FD' from an existing file descriptor. Fails if the FD +-- refers to a directory. If the FD refers to a file, `mkFD` locks +-- the file according to the Haskell 98 single writer/multiple reader +-- locking semantics (this is why we need the `IOMode` argument too). +mkFD :: CInt + -> IOMode + -> Maybe (IODeviceType, CDev, CIno) + -- the results of fdStat if we already know them, or we want + -- to prevent fdToHandle_stat from doing its own stat. + -- These are used for: + -- - we fail if the FD refers to a directory + -- - if the FD refers to a file, we lock it using (cdev,cino) + -> Bool -- ^ is a socket (on Windows) + -> Bool -- ^ is in non-blocking mode on Unix + -> IO (FD,IODeviceType) + +mkFD fd iomode mb_stat is_socket is_nonblock = do + + let _ = (is_socket, is_nonblock) -- warning suppression + + (fd_type,dev,ino) <- + case mb_stat of + Nothing -> fdStat fd + Just stat -> return stat + + let write = case iomode of + ReadMode -> False + _ -> True + +#ifdef mingw32_HOST_OS + let _ = (dev,ino,write,fd) -- warning suppression +#endif + + case fd_type of + Directory -> + ioException (IOError Nothing InappropriateType "openFile" + "is a directory" Nothing Nothing) + +#ifndef mingw32_HOST_OS + -- regular files need to be locked + RegularFile -> do + -- On Windows we use explicit exclusion via sopen() to implement + -- this locking (see __hscore_open()); on Unix we have to + -- implment it in the RTS. + r <- lockFile fd dev ino (fromBool write) + when (r == -1) $ + ioException (IOError Nothing ResourceBusy "openFile" + "file is locked" Nothing Nothing) +#endif + + _other_type -> return () + + return (FD{ fdFD = fd, +#ifndef mingw32_HOST_OS + fdIsNonBlocking = fromEnum is_nonblock +#else + fdIsSocket_ = fromEnum is_socket +#endif + }, + fd_type) + +-- ----------------------------------------------------------------------------- +-- Standard file descriptors + +stdFD :: CInt -> FD +stdFD fd = FD { fdFD = fd, +#ifdef mingw32_HOST_OS + fdIsSocket_ = 0 +#else + fdIsNonBlocking = 0 + -- We don't set non-blocking mode on standard handles, because it may + -- confuse other applications attached to the same TTY/pipe + -- see Note [nonblock] +#endif + } + +stdin, stdout, stderr :: FD +stdin = stdFD 0 +stdout = stdFD 1 +stderr = stdFD 2 + +-- ----------------------------------------------------------------------------- +-- Operations on file descriptors + +close :: FD -> IO () +close fd = +#ifndef mingw32_HOST_OS + (flip finally) (release fd) $ do +#endif + throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $ +#ifdef mingw32_HOST_OS + if fdIsSocket fd then + c_closesocket (fdFD fd) + else +#endif + c_close (fdFD fd) + +release :: FD -> IO () +release fd = do +#ifndef mingw32_HOST_OS + unlockFile (fdFD fd) +#endif + let _ = fd -- warning suppression + return () + +#ifdef mingw32_HOST_OS +foreign import stdcall unsafe "HsBase.h closesocket" + c_closesocket :: CInt -> IO CInt +#endif + +isSeekable :: FD -> IO Bool +isSeekable fd = do + t <- devType fd + return (t == RegularFile || t == RawDevice) + +seek :: FD -> SeekMode -> Integer -> IO () +seek fd mode off = do + throwErrnoIfMinus1Retry "seek" $ + c_lseek (fdFD fd) (fromIntegral off) seektype + return () + where + seektype :: CInt + seektype = case mode of + AbsoluteSeek -> sEEK_SET + RelativeSeek -> sEEK_CUR + SeekFromEnd -> sEEK_END + +tell :: FD -> IO Integer +tell fd = + fromIntegral `fmap` + (throwErrnoIfMinus1Retry "hGetPosn" $ + c_lseek (fdFD fd) 0 sEEK_CUR) + +getSize :: FD -> IO Integer +getSize fd = fdFileSize (fdFD fd) + +setSize :: FD -> Integer -> IO () +setSize fd size = do + throwErrnoIf (/=0) "GHC.IO.FD.setSize" $ + c_ftruncate (fdFD fd) (fromIntegral size) + return () + +devType :: FD -> IO IODeviceType +devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty + +dup :: FD -> IO FD +dup fd = do + newfd <- throwErrnoIfMinus1 "GHC.IO.FD.dup" $ c_dup (fdFD fd) + return fd{ fdFD = newfd } + +dup2 :: FD -> FD -> IO FD +dup2 fd fdto = do + -- Windows' dup2 does not return the new descriptor, unlike Unix + throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ + c_dup2 (fdFD fd) (fdFD fdto) + return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD + +setNonBlockingMode :: FD -> IO () +setNonBlockingMode fd = setNonBlockingFD (fdFD fd) + +ready :: FD -> Bool -> Int -> IO Bool +ready fd write msecs = do + r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $ + fdReady (fdFD fd) (fromIntegral $ fromEnum $ write) + (fromIntegral msecs) +#if defined(mingw32_HOST_OS) + (fromIntegral $ fromEnum $ fdIsSocket fd) +#else + 0 +#endif + return (toEnum (fromIntegral r)) + +foreign import ccall safe "fdReady" + fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + +-- --------------------------------------------------------------------------- +-- Terminal-related stuff + +isTerminal :: FD -> IO Bool +isTerminal fd = c_isatty (fdFD fd) >>= return.toBool + +setEcho :: FD -> Bool -> IO () +setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on + +getEcho :: FD -> IO Bool +getEcho fd = System.Posix.Internals.getEcho (fdFD fd) + +setRaw :: FD -> Bool -> IO () +setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw) + +-- ----------------------------------------------------------------------------- +-- Reading and Writing + +fdRead :: FD -> Ptr Word8 -> Int -> IO Int +fdRead fd ptr bytes = do + r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes) + return (fromIntegral r) + +fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int) +fdReadNonBlocking fd ptr bytes = do + r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr + 0 (fromIntegral bytes) + case r of + (-1) -> return (Nothing) + n -> return (Just (fromIntegral n)) + + +fdWrite :: FD -> Ptr Word8 -> Int -> IO () +fdWrite fd ptr bytes = do + res <- writeRawBufferPtr "GHC.IO.FD.fdWrite" fd ptr 0 (fromIntegral bytes) + let res' = fromIntegral res + if res' < bytes + then fdWrite fd (ptr `plusPtr` bytes) (bytes - res') + else return () + +-- XXX ToDo: this isn't non-blocking +fdWriteNonBlocking :: FD -> Ptr Word8 -> Int -> IO Int +fdWriteNonBlocking fd ptr bytes = do + res <- writeRawBufferPtrNoBlock "GHC.IO.FD.fdWriteNonBlocking" fd ptr 0 + (fromIntegral bytes) + return (fromIntegral res) + +-- ----------------------------------------------------------------------------- +-- FD operations + +-- Low level routines for reading/writing to (raw)buffers: + +#ifndef mingw32_HOST_OS + +{- +NOTE [nonblock]: + +Unix has broken semantics when it comes to non-blocking I/O: you can +set the O_NONBLOCK flag on an FD, but it applies to the all other FDs +attached to the same underlying file, pipe or TTY; there's no way to +have private non-blocking behaviour for an FD. See bug #724. + +We fix this by only setting O_NONBLOCK on FDs that we create; FDs that +come from external sources or are exposed externally are left in +blocking mode. This solution has some problems though. We can't +completely simulate a non-blocking read without O_NONBLOCK: several +cases are wrong here. The cases that are wrong: + + * reading/writing to a blocking FD in non-threaded mode. + In threaded mode, we just make a safe call to read(). + In non-threaded mode we call select() before attempting to read, + but that leaves a small race window where the data can be read + from the file descriptor before we issue our blocking read(). + * readRawBufferNoBlock for a blocking FD + +NOTE [2363]: + +In the threaded RTS we could just make safe calls to read()/write() +for file descriptors in blocking mode without worrying about blocking +other threads, but the problem with this is that the thread will be +uninterruptible while it is blocked in the foreign call. See #2363. +So now we always call fdReady() before reading, and if fdReady +indicates that there's no data, we call threadWaitRead. + +-} + +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtr loc !fd buf off len + | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block + | otherwise = do r <- throwErrnoIfMinus1 loc + (unsafe_fdReady (fdFD fd) 0 0 0) + if r /= 0 + then read + else do threadWaitRead (fromIntegral (fdFD fd)); read + where + do_read call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitRead (fromIntegral (fdFD fd))) + read = if threaded then safe_read else unsafe_read + unsafe_read = do_read (read_off (fdFD fd) buf off len) + safe_read = do_read (safe_read_off (fdFD fd) buf off len) + +-- return: -1 indicates EOF, >=0 is bytes read +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtrNoBlock loc !fd buf off len + | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 0 0 0 + if r /= 0 then safe_read + else return 0 + -- XXX see note [nonblock] + where + do_read call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1)) + case r of + (-1) -> return 0 + 0 -> return (-1) + n -> return n + unsafe_read = do_read (read_off (fdFD fd) buf off len) + safe_read = do_read (safe_read_off (fdFD fd) buf off len) + +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtr loc !fd buf off len + | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 + if r /= 0 + then write + else do threadWaitWrite (fromIntegral (fdFD fd)); write + where + do_write call = throwErrnoIfMinus1RetryMayBlock loc call + (threadWaitWrite (fromIntegral (fdFD fd))) + write = if threaded then safe_write else unsafe_write + unsafe_write = do_write (write_off (fdFD fd) buf off len) + safe_write = do_write (safe_write_off (fdFD fd) buf off len) + +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtrNoBlock loc !fd buf off len + | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block + | otherwise = do r <- unsafe_fdReady (fdFD fd) 1 0 0 + if r /= 0 then write + else return 0 + where + do_write call = do r <- throwErrnoIfMinus1RetryOnBlock loc call (return (-1)) + case r of + (-1) -> return 0 + n -> return n + write = if threaded then safe_write else unsafe_write + unsafe_write = do_write (write_off (fdFD fd) buf off len) + safe_write = do_write (safe_write_off (fdFD fd) buf off len) + +isNonBlocking :: FD -> Bool +isNonBlocking fd = fdIsNonBlocking fd /= 0 + +foreign import ccall unsafe "__hscore_PrelHandle_read" + read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_PrelHandle_write" + write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +foreign import ccall unsafe "fdReady" + unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt + +#else /* mingw32_HOST_OS.... */ + +readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtr loc !fd buf off len + | threaded = blockingReadRawBufferPtr loc fd buf off len + | otherwise = asyncReadRawBufferPtr loc fd buf off len + +writeRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtr loc !fd buf off len + | threaded = blockingWriteRawBufferPtr loc fd buf off len + | otherwise = asyncWriteRawBufferPtr loc fd buf off len + +readRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +readRawBufferPtrNoBlock = readRawBufferPtr + +writeRawBufferPtrNoBlock :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +writeRawBufferPtrNoBlock = writeRawBufferPtr + +-- Async versions of the read/write primitives, for the non-threaded RTS + +asyncReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +asyncReadRawBufferPtr loc !fd buf off len = do + (l, rc) <- asyncRead (fromIntegral (fdFD fd)) (fdIsSocket_ fd) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +asyncWriteRawBufferPtr loc !fd buf off len = do + (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd) + (fromIntegral len) (buf `plusPtr` off) + if l == (-1) + then + ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else return (fromIntegral l) + +-- Blocking versions of the read/write primitives, for the threaded RTS + +blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CInt -> IO CInt +blockingReadRawBufferPtr loc fd buf off len + = throwErrnoIfMinus1Retry loc $ + if fdIsSocket fd + then safe_recv_off (fdFD fd) buf off len + else safe_read_off (fdFD fd) buf off len + +blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CInt -> IO CInt +blockingWriteRawBufferPtr loc fd buf off len + = throwErrnoIfMinus1Retry loc $ + if fdIsSocket fd + then safe_send_off (fdFD fd) buf off len + else safe_write_off (fdFD fd) buf off len + +-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. +-- These calls may block, but that's ok. + +foreign import ccall safe "__hscore_PrelHandle_recv" + safe_recv_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_send" + safe_send_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +#endif + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool + +foreign import ccall safe "__hscore_PrelHandle_read" + safe_read_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + safe_write_off :: CInt -> Ptr Word8 -> Int -> CInt -> IO CInt + +-- ----------------------------------------------------------------------------- +-- utils + +#ifndef mingw32_HOST_OS +throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt +throwErrnoIfMinus1RetryOnBlock loc f on_block = + do + res <- f + if (res :: CInt) == -1 + then do + err <- getErrno + if err == eINTR + then throwErrnoIfMinus1RetryOnBlock loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block + else throwErrno loc + else return res +#endif + +-- ----------------------------------------------------------------------------- +-- Locking/unlocking + +#ifndef mingw32_HOST_OS +foreign import ccall unsafe "lockFile" + lockFile :: CInt -> CDev -> CIno -> CInt -> IO CInt + +foreign import ccall unsafe "unlockFile" + unlockFile :: CInt -> IO CInt +#endif + +#if defined(DEBUG_DUMP) +puts :: String -> IO () +puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len) + return () +#endif diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs new file mode 100644 index 0000000000..b4b90e8347 --- /dev/null +++ b/libraries/base/GHC/IO/Handle.hs @@ -0,0 +1,686 @@ +{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XRecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable +-- +-- External API for GHC's Handle implementation +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle ( + Handle, + BufferMode(..), + + mkFileHandle, mkDuplexHandle, + + hFileSize, hSetFileSize, hIsEOF, hLookAhead, + hSetBuffering, hSetBinaryMode, hSetEncoding, + hFlush, hDuplicate, hDuplicateTo, + + hClose, hClose_help, + + HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, + SeekMode(..), hSeek, hTell, + + hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, + hSetEcho, hGetEcho, hIsTerminalDevice, + + hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline, + noNewlineTranslation, universalNewlineMode, nativeNewlineMode, + + hShow, + + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + + hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking + ) where + +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Encoding +import GHC.IO.Buffer +import GHC.IO.BufferedIO ( BufferedIO ) +import GHC.IO.Device as IODevice +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.IO.Handle.Text +import System.IO.Error + +import GHC.Base +import GHC.Exception +import GHC.MVar +import GHC.IORef +import GHC.Show +import GHC.Num +import GHC.Real +import Data.Maybe +import Data.Typeable +import Control.Monad + +-- --------------------------------------------------------------------------- +-- Closing a handle + +-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the +-- computation finishes, if @hdl@ is writable its buffer is flushed as +-- for 'hFlush'. +-- Performing 'hClose' on a handle that has already been closed has no effect; +-- doing so is not an error. All other operations on a closed handle will fail. +-- If 'hClose' fails for any reason, any further operations (apart from +-- 'hClose') on the handle will still fail as if @hdl@ had been successfully +-- closed. + +hClose :: Handle -> IO () +hClose h@(FileHandle _ m) = do + mb_exc <- hClose' h m + case mb_exc of + Nothing -> return () + Just e -> hClose_rethrow e h +hClose h@(DuplexHandle _ r w) = do + mb_exc1 <- hClose' h w + mb_exc2 <- hClose' h r + case (do mb_exc1; mb_exc2) of + Nothing -> return () + Just e -> hClose_rethrow e h + +hClose_rethrow :: SomeException -> Handle -> IO () +hClose_rethrow e h = + case fromException e of + Just ioe -> ioError (augmentIOError ioe "hClose" h) + Nothing -> throwIO e + +hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException) +hClose' h m = withHandle' "hClose" h m $ hClose_help + +----------------------------------------------------------------------------- +-- Detecting and changing the size of a file + +-- | For a handle @hdl@ which attached to a physical file, +-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes. + +hFileSize :: Handle -> IO Integer +hFileSize handle = + withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + _ -> do flushWriteBuffer handle_ + r <- IODevice.getSize dev + if r /= -1 + then return r + else ioException (IOError Nothing InappropriateType "hFileSize" + "not a regular file" Nothing Nothing) + + +-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. + +hSetFileSize :: Handle -> Integer -> IO () +hSetFileSize handle size = + withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + _ -> do flushWriteBuffer handle_ + IODevice.setSize dev size + return () + +-- --------------------------------------------------------------------------- +-- Detecting the End of Input + +-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns +-- 'True' if no further input can be taken from @hdl@ or for a +-- physical file, if the current I\/O position is equal to the length of +-- the file. Otherwise, it returns 'False'. +-- +-- NOTE: 'hIsEOF' may block, because it is the same as calling +-- 'hLookAhead' and checking for an EOF exception. + +hIsEOF :: Handle -> IO Bool +hIsEOF handle = + catch + (do hLookAhead handle; return False) + (\e -> if isEOFError e then return True else ioError e) + +-- --------------------------------------------------------------------------- +-- Looking ahead + +-- | Computation 'hLookAhead' returns the next character from the handle +-- without removing it from the input buffer, blocking until a character +-- is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hLookAhead :: Handle -> IO Char +hLookAhead handle = + wantReadableHandle_ "hLookAhead" handle hLookAhead_ + +-- --------------------------------------------------------------------------- +-- Buffering Operations + +-- Three kinds of buffering are supported: line-buffering, +-- block-buffering or no-buffering. See GHC.IO.Handle for definition and +-- further explanation of what the type represent. + +-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for +-- handle @hdl@ on subsequent reads and writes. +-- +-- If the buffer mode is changed from 'BlockBuffering' or +-- 'LineBuffering' to 'NoBuffering', then +-- +-- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; +-- +-- * if @hdl@ is not writable, the contents of the buffer is discarded. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if the handle has already been used for reading +-- or writing and the implementation does not allow the buffering mode +-- to be changed. + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering handle mode = + withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> do + if mode == haBufferMode then return handle_ else do + + {- Note: + - we flush the old buffer regardless of whether + the new buffer could fit the contents of the old buffer + or not. + - allow a handle's buffering to change even if IO has + occurred (ANSI C spec. does not allow this, nor did + the previous implementation of IO.hSetBuffering). + - a non-standard extension is to allow the buffering + of semi-closed handles to change [sof 6/98] + -} + flushCharBuffer handle_ + + let state = initBufferState haType + reading = not (isWritableHandleType haType) + + new_buf <- + case mode of + -- See [note Buffer Sizing], GHC.IO.Handle.Types + NoBuffering | reading -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + | otherwise -> newCharBuffer 1 state + LineBuffering -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n + | otherwise -> newCharBuffer n state + + writeIORef haCharBuffer new_buf + + -- for input terminals we need to put the terminal into + -- cooked or raw mode depending on the type of buffering. + is_tty <- IODevice.isTerminal haDevice + when (is_tty && isReadableHandleType haType) $ + case mode of +#ifndef mingw32_HOST_OS + -- 'raw' mode under win32 is a bit too specialised (and troublesome + -- for most common uses), so simply disable its use here. + NoBuffering -> IODevice.setRaw haDevice True +#else + NoBuffering -> return () +#endif + _ -> IODevice.setRaw haDevice False + + -- throw away spare buffers, they might be the wrong size + writeIORef haBuffers BufferListNil + + return Handle__{ haBufferMode = mode,.. } + +-- ----------------------------------------------------------------------------- +-- hSetEncoding + +-- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding +-- for the handle @hdl@ to @encoding@. Encodings are available from the +-- module "GHC.IO.Encoding". The default encoding when a 'Handle' is +-- created is 'localeEncoding', namely the default encoding for the current +-- locale. +-- +-- To create a 'Handle' with no encoding at all, use 'openBinaryFile'. To +-- stop further encoding or decoding on an existing 'Handle', use +-- 'hSetBinaryMode'. +-- +hSetEncoding :: Handle -> TextEncoding -> IO () +hSetEncoding hdl encoding = do + withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do + flushCharBuffer h_ + (mb_encoder,mb_decoder) <- getEncoding (Just encoding) haType + return (Handle__{ haDecoder = mb_decoder, haEncoder = mb_encoder, .. }, + ()) + +-- ----------------------------------------------------------------------------- +-- hFlush + +-- | The action 'hFlush' @hdl@ causes any items buffered for output +-- in handle @hdl@ to be sent immediately to the operating system. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. +-- It is unspecified whether the characters in the buffer are discarded +-- or retained under these circumstances. + +hFlush :: Handle -> IO () +hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer + +-- ----------------------------------------------------------------------------- +-- Repositioning Handles + +data HandlePosn = HandlePosn Handle HandlePosition + +instance Eq HandlePosn where + (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 + +instance Show HandlePosn where + showsPrec p (HandlePosn h pos) = + showsPrec p h . showString " at position " . shows pos + + -- HandlePosition is the Haskell equivalent of POSIX' off_t. + -- We represent it as an Integer on the Haskell side, but + -- cheat slightly in that hGetPosn calls upon a C helper + -- that reports the position back via (merely) an Int. +type HandlePosition = Integer + +-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of +-- @hdl@ as a value of the abstract type 'HandlePosn'. + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn handle = do + posn <- hTell handle + return (HandlePosn handle posn) + +-- | If a call to 'hGetPosn' @hdl@ returns a position @p@, +-- then computation 'hSetPosn' @p@ sets the position of @hdl@ +-- to the position it held at the time of the call to 'hGetPosn'. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. + +hSetPosn :: HandlePosn -> IO () +hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i + +-- --------------------------------------------------------------------------- +-- hSeek + +{- Note: + - when seeking using `SeekFromEnd', positive offsets (>=0) means + seeking at or past EOF. + + - we possibly deviate from the report on the issue of seeking within + the buffer and whether to flush it or not. The report isn't exactly + clear here. +-} + +-- | Computation 'hSeek' @hdl mode i@ sets the position of handle +-- @hdl@ depending on @mode@. +-- The offset @i@ is given in terms of 8-bit bytes. +-- +-- If @hdl@ is block- or line-buffered, then seeking to a position which is not +-- in the current buffer will first cause any items in the output buffer to be +-- written to the device, and then cause the input buffer to be discarded. +-- Some handles may not be seekable (see 'hIsSeekable'), or only support a +-- subset of the possible positioning operations (for instance, it may only +-- be possible to seek to the end of a tape, or to a positive offset from +-- the beginning or current position). +-- It is not possible to set a negative I\/O position, or for +-- a physical file, an I\/O position beyond the current end-of-file. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. + +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek handle mode offset = + wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do + debugIO ("hSeek " ++ show (mode,offset)) + buf <- readIORef haCharBuffer + + if isWriteBuffer buf + then do flushWriteBuffer handle_ + IODevice.seek haDevice mode offset + else do + + let r = bufL buf; w = bufR buf + if mode == RelativeSeek && isNothing haDecoder && + offset >= 0 && offset < fromIntegral (w - r) + then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset } + else do + + flushCharReadBuffer handle_ + flushByteReadBuffer handle_ + IODevice.seek haDevice mode offset + + +hTell :: Handle -> IO Integer +hTell handle = + wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do + + posn <- IODevice.tell haDevice + + cbuf <- readIORef haCharBuffer + bbuf <- readIORef haByteBuffer + + let real_posn + | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf) + | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf) + - fromIntegral (bufR bbuf - bufL bbuf) + + debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn)) + debugIO (" cbuf: " ++ summaryBuffer cbuf ++ + " bbuf: " ++ summaryBuffer bbuf) + + return real_posn + +-- ----------------------------------------------------------------------------- +-- Handle Properties + +-- A number of operations return information about the properties of a +-- handle. Each of these operations returns `True' if the handle has +-- the specified property, and `False' otherwise. + +hIsOpen :: Handle -> IO Bool +hIsOpen handle = + withHandle_ "hIsOpen" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return False + SemiClosedHandle -> return False + _ -> return True + +hIsClosed :: Handle -> IO Bool +hIsClosed handle = + withHandle_ "hIsClosed" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return True + _ -> return False + +{- not defined, nor exported, but mentioned + here for documentation purposes: + + hSemiClosed :: Handle -> IO Bool + hSemiClosed h = do + ho <- hIsOpen h + hc <- hIsClosed h + return (not (ho || hc)) +-} + +hIsReadable :: Handle -> IO Bool +hIsReadable (DuplexHandle _ _ _) = return True +hIsReadable handle = + withHandle_ "hIsReadable" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + htype -> return (isReadableHandleType htype) + +hIsWritable :: Handle -> IO Bool +hIsWritable (DuplexHandle _ _ _) = return True +hIsWritable handle = + withHandle_ "hIsWritable" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + htype -> return (isWritableHandleType htype) + +-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode +-- for @hdl@. + +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering handle = + withHandle_ "hGetBuffering" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + _ -> + -- We're being non-standard here, and allow the buffering + -- of a semi-closed handle to be queried. -- sof 6/98 + return (haBufferMode handle_) -- could be stricter.. + +hIsSeekable :: Handle -> IO Bool +hIsSeekable handle = + withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> return False + _ -> IODevice.isSeekable haDevice + +-- ----------------------------------------------------------------------------- +-- Changing echo status (Non-standard GHC extensions) + +-- | Set the echoing status of a handle connected to a terminal. + +hSetEcho :: Handle -> Bool -> IO () +hSetEcho handle on = do + isT <- hIsTerminalDevice handle + if not isT + then return () + else + withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.setEcho haDevice on + +-- | Get the echoing status of a handle connected to a terminal. + +hGetEcho :: Handle -> IO Bool +hGetEcho handle = do + isT <- hIsTerminalDevice handle + if not isT + then return False + else + withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.getEcho haDevice + +-- | Is the handle connected to a terminal? + +hIsTerminalDevice :: Handle -> IO Bool +hIsTerminalDevice handle = do + withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do + case haType of + ClosedHandle -> ioe_closedHandle + _ -> IODevice.isTerminal haDevice + +-- ----------------------------------------------------------------------------- +-- hSetBinaryMode + +-- | Select binary mode ('True') or text mode ('False') on a open handle. +-- (See also 'openBinaryFile'.) +-- +-- This has the same effect as calling 'hSetEncoding' with 'latin1', together +-- with 'hSetNewlineMode' with 'noNewlineTranslation'. +-- +hSetBinaryMode :: Handle -> Bool -> IO () +hSetBinaryMode handle bin = + withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} -> + do + flushBuffer h_ + let mb_te | bin = Nothing + | otherwise = Just localeEncoding + + -- should match the default newline mode, whatever that is + let nl | bin = noNewlineTranslation + | otherwise = nativeNewlineMode + + (mb_encoder, mb_decoder) <- getEncoding mb_te haType + return Handle__{ haEncoder = mb_encoder, + haDecoder = mb_decoder, + haInputNL = inputNL nl, + haOutputNL = outputNL nl, .. } + +-- ----------------------------------------------------------------------------- +-- hSetNewlineMode + +-- | Set the 'NewlineMode' on the specified 'Handle'. All buffered +-- data is flushed first. +hSetNewlineMode :: Handle -> NewlineMode -> IO () +hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } = + withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} -> + do + flushBuffer h_ + return h_{ haInputNL=i, haOutputNL=o } + +-- ----------------------------------------------------------------------------- +-- Duplicating a Handle + +-- | Returns a duplicate of the original handle, with its own buffer. +-- The two Handles will share a file pointer, however. The original +-- handle's buffer is flushed, including discarding any input data, +-- before the handle is duplicated. + +hDuplicate :: Handle -> IO Handle +hDuplicate h@(FileHandle path m) = do + withHandle_' "hDuplicate" h m $ \h_ -> + dupHandle path h Nothing h_ (Just handleFinalizer) +hDuplicate h@(DuplexHandle path r w) = do + write_side@(FileHandle _ write_m) <- + withHandle_' "hDuplicate" h w $ \h_ -> + dupHandle path h Nothing h_ (Just handleFinalizer) + read_side@(FileHandle _ read_m) <- + withHandle_' "hDuplicate" h r $ \h_ -> + dupHandle path h (Just write_m) h_ Nothing + return (DuplexHandle path read_m write_m) + +dupHandle :: FilePath + -> Handle + -> Maybe (MVar Handle__) + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle +dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do + -- flush the buffer first, so we don't have to copy its contents + flushBuffer h_ + case other_side of + Nothing -> do + new_dev <- IODevice.dup haDevice + dupHandle_ new_dev filepath other_side h_ mb_finalizer + Just r -> + withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do + dupHandle_ dev filepath other_side h_ mb_finalizer + +dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> Maybe (MVar Handle__) + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle +dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do + -- XXX wrong! + let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing + mkHandle new_dev filepath haType True{-buffered-} mb_codec + NewlineMode { inputNL = haInputNL, outputNL = haOutputNL } + mb_finalizer other_side + +-- ----------------------------------------------------------------------------- +-- Replacing a Handle + +{- | +Makes the second handle a duplicate of the first handle. The second +handle will be closed first, if it is not already. + +This can be used to retarget the standard Handles, for example: + +> do h <- openFile "mystdout" WriteMode +> hDuplicateTo h stdout +-} + +hDuplicateTo :: Handle -> Handle -> IO () +hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2) = do + withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do + _ <- hClose_help h2_ + withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do + dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer) +hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2) = do + withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do + _ <- hClose_help w2_ + withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do + dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer) + withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do + _ <- hClose_help r2_ + withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do + dupHandleTo path h1 (Just w1) r2_ r1_ Nothing +hDuplicateTo h1 _ = + ioe_dupHandlesNotCompatible h1 + + +ioe_dupHandlesNotCompatible :: Handle -> IO a +ioe_dupHandlesNotCompatible h = + ioException (IOError (Just h) IllegalOperation "hDuplicateTo" + "handles are incompatible" Nothing Nothing) + +dupHandleTo :: FilePath + -> Handle + -> Maybe (MVar Handle__) + -> Handle__ + -> Handle__ + -> Maybe HandleFinalizer + -> IO Handle__ +dupHandleTo filepath h other_side + hto_@Handle__{haDevice=devTo,..} + h_@Handle__{haDevice=dev} mb_finalizer = do + flushBuffer h_ + case cast devTo of + Nothing -> ioe_dupHandlesNotCompatible h + Just dev' -> do + IODevice.dup2 dev dev' + FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer + takeMVar m + +-- --------------------------------------------------------------------------- +-- showing Handles. +-- +-- | 'hShow' is in the 'IO' monad, and gives more comprehensive output +-- than the (pure) instance of 'Show' for 'Handle'. + +hShow :: Handle -> IO String +hShow h@(FileHandle path _) = showHandle' path False h +hShow h@(DuplexHandle path _ _) = showHandle' path True h + +showHandle' :: String -> Bool -> Handle -> IO String +showHandle' filepath is_duplex h = + withHandle_ "showHandle" h $ \hdl_ -> + let + showType | is_duplex = showString "duplex (read-write)" + | otherwise = shows (haType hdl_) + in + return + (( showChar '{' . + showHdl (haType hdl_) + (showString "loc=" . showString filepath . showChar ',' . + showString "type=" . showType . showChar ',' . + showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) + ) "") + where + + showHdl :: HandleType -> ShowS -> ShowS + showHdl ht cont = + case ht of + ClosedHandle -> shows ht . showString "}" + _ -> cont + + showBufMode :: Buffer e -> BufferMode -> ShowS + showBufMode buf bmo = + case bmo of + NoBuffering -> showString "none" + LineBuffering -> showString "line" + BlockBuffering (Just n) -> showString "block " . showParen True (shows n) + BlockBuffering Nothing -> showString "block " . showParen True (shows def) + where + def :: Int + def = bufSize buf diff --git a/libraries/base/GHC/IO/Handle.hs-boot b/libraries/base/GHC/IO/Handle.hs-boot new file mode 100644 index 0000000000..68379e2249 --- /dev/null +++ b/libraries/base/GHC/IO/Handle.hs-boot @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} + +module GHC.IO.Handle where + +import GHC.IO +import GHC.IO.Handle.Types + +hFlush :: Handle -> IO () diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs new file mode 100644 index 0000000000..d74dd2da84 --- /dev/null +++ b/libraries/base/GHC/IO/Handle/FD.hs @@ -0,0 +1,250 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.FD +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Handle operations implemented by file descriptors (FDs) +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.FD ( + stdin, stdout, stderr, + openFile, openBinaryFile, + mkHandleFromFD, fdToHandle, fdToHandle', + isEOF + ) where + +import GHC.Base +import GHC.Num +import GHC.Real +import GHC.Show +import Data.Maybe +import Control.Monad +import Foreign.C.Types +import GHC.MVar +import GHC.IO +import GHC.IO.Encoding +import GHC.IO.Exception +import GHC.IO.Device as IODevice +import GHC.IO.Exception +import GHC.IO.IOMode +import GHC.IO.Handle +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import GHC.IO.FD (FD(..)) +import qualified GHC.IO.FD as FD +import qualified System.Posix.Internals as Posix + +-- --------------------------------------------------------------------------- +-- Standard Handles + +-- Three handles are allocated during program initialisation. The first +-- two manage input or output from the Haskell program's standard input +-- or output channel respectively. The third manages output to the +-- standard error channel. These handles are initially open. + +-- | A handle managing input from the Haskell program's standard input channel. +stdin :: Handle +stdin = unsafePerformIO $ do + -- ToDo: acquire lock + mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard output channel. +stdout :: Handle +stdout = unsafePerformIO $ do + -- ToDo: acquire lock + mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +-- | A handle managing output to the Haskell program's standard error channel. +stderr :: Handle +stderr = unsafePerformIO $ do + -- ToDo: acquire lock + mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} + (Just localeEncoding) + nativeNewlineMode{-translate newlines-} + (Just stdHandleFinalizer) Nothing + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do + h_ <- takeMVar m + flushWriteBuffer h_ + putMVar m (ioe_finalizedHandle fp) + +-- --------------------------------------------------------------------------- +-- isEOF + +-- | The computation 'isEOF' is identical to 'hIsEOF', +-- except that it works only on 'stdin'. + +isEOF :: IO Bool +isEOF = hIsEOF stdin + +-- --------------------------------------------------------------------------- +-- Opening and Closing Files + +addFilePathToIOError :: String -> FilePath -> IOException -> IOException +addFilePathToIOError fun fp ioe + = ioe{ ioe_location = fun, ioe_filename = Just fp } + +-- | Computation 'openFile' @file mode@ allocates and returns a new, open +-- handle to manage the file @file@. It manages input if @mode@ +-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', +-- and both input and output if mode is 'ReadWriteMode'. +-- +-- If the file does not exist and it is opened for output, it should be +-- created as a new file. If @mode@ is 'WriteMode' and the file +-- already exists, then it should be truncated to zero length. +-- Some operating systems delete empty files, so there is no guarantee +-- that the file will exist following an 'openFile' with @mode@ +-- 'WriteMode' unless it is subsequently written to successfully. +-- The handle is positioned at the end of the file if @mode@ is +-- 'AppendMode', and otherwise at the beginning (in which case its +-- internal position is 0). +-- The initial buffer mode is implementation-dependent. +-- +-- This operation may fail with: +-- +-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- +-- * 'isDoesNotExistError' if the file does not exist; or +-- +-- * 'isPermissionError' if the user does not have permission to open the file. +-- +-- Note: if you will be working with files containing binary data, you'll want to +-- be using 'openBinaryFile'. +openFile :: FilePath -> IOMode -> IO Handle +openFile fp im = + catchException + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) + +-- | Like 'openFile', but open the file in binary mode. +-- On Windows, reading a file in text mode (which is the default) +-- will translate CRLF to LF, and writing will translate LF to CRLF. +-- This is usually what you want with text files. With binary files +-- this is undesirable; also, as usual under Microsoft operating systems, +-- text mode treats control-Z as EOF. Binary mode turns off all special +-- treatment of end-of-line and end-of-file characters. +-- (See also 'hSetBinaryMode'.) + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile fp m = + catchException + (openFile' fp m True) + (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) + +openFile' :: String -> IOMode -> Bool -> IO Handle +openFile' filepath iomode binary = do + -- first open the file to get an FD + (fd, fd_type) <- FD.openFile filepath iomode + + let mb_codec = if binary then Nothing else Just localeEncoding + + -- then use it to make a Handle + mkHandleFromFD fd fd_type filepath iomode True{-non-blocking-} mb_codec + `onException` IODevice.close fd + -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise + -- this FD leaks. + -- ASSERT: if we just created the file, then fdToHandle' won't fail + -- (so we don't need to worry about removing the newly created file + -- in the event of an error). + + +-- --------------------------------------------------------------------------- +-- Converting file descriptors to Handles + +mkHandleFromFD + :: FD + -> IODeviceType + -> FilePath -- a string describing this file descriptor (e.g. the filename) + -> IOMode + -> Bool -- non_blocking (*sets* non-blocking mode on the FD) + -> Maybe TextEncoding + -> IO Handle + +mkHandleFromFD fd fd_type filepath iomode set_non_blocking mb_codec + = do +#ifndef mingw32_HOST_OS + when set_non_blocking $ FD.setNonBlockingMode fd + -- turn on non-blocking mode +#else + let _ = set_non_blocking -- warning suppression +#endif + + let nl | isJust mb_codec = nativeNewlineMode + | otherwise = noNewlineTranslation + + case fd_type of + Directory -> + ioException (IOError Nothing InappropriateType "openFile" + "is a directory" Nothing Nothing) + + Stream + -- only *Streams* can be DuplexHandles. Other read/write + -- Handles must share a buffer. + | ReadWriteMode <- iomode -> + mkDuplexHandle fd filepath mb_codec nl + + + _other -> + mkFileHandle fd filepath iomode mb_codec nl + +-- | Old API kept to avoid breaking clients +fdToHandle' :: CInt + -> Maybe IODeviceType + -> Bool -- is_socket on Win, non-blocking on Unix + -> FilePath + -> IOMode + -> Bool -- binary + -> IO Handle +fdToHandle' fdint mb_type is_socket filepath iomode binary = do + let mb_stat = case mb_type of + Nothing -> Nothing + -- mkFD will do the stat: + Just RegularFile -> Nothing + -- no stat required for streams etc.: + Just other -> Just (other,0,0) + (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode mb_stat + is_socket + is_socket + mkHandleFromFD fd fd_type filepath iomode is_socket + (if binary then Nothing else Just localeEncoding) + + +-- | Turn an existing file descriptor into a Handle. This is used by +-- various external libraries to make Handles. +-- +-- Makes a binary Handle. This is for historical reasons; it should +-- probably be a text Handle with the default encoding and newline +-- translation instead. +fdToHandle :: Posix.FD -> IO Handle +fdToHandle fdint = do + iomode <- Posix.fdGetMode (fromIntegral fdint) + (fd,fd_type) <- FD.mkFD (fromIntegral fdint) iomode Nothing + False{-is_socket-} + -- NB. the is_socket flag is False, meaning that: + -- on Windows we're guessing this is not a socket (XXX) + False{-is_nonblock-} + -- file descriptors that we get from external sources are + -- not put into non-blocking mode, becuase that would affect + -- other users of the file descriptor + let fd_str = "<file descriptor: " ++ show fd ++ ">" + mkHandleFromFD fd fd_type fd_str iomode False{-non-block-} + Nothing -- bin mode + +-- --------------------------------------------------------------------------- +-- Are files opened by default in text or binary mode, if the user doesn't +-- specify? + +dEFAULT_OPEN_IN_BINARY_MODE :: Bool +dEFAULT_OPEN_IN_BINARY_MODE = False diff --git a/libraries/base/GHC/IO/Handle/FD.hs-boot b/libraries/base/GHC/IO/Handle/FD.hs-boot new file mode 100644 index 0000000000..657af3882e --- /dev/null +++ b/libraries/base/GHC/IO/Handle/FD.hs-boot @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +module GHC.IO.Handle.FD where + +import GHC.IO.Handle.Types + +-- used in GHC.Conc, which is below GHC.IO.Handle.FD +stdout :: Handle diff --git a/libraries/base/GHC/IO/Handle/Internals.hs b/libraries/base/GHC/IO/Handle/Internals.hs new file mode 100644 index 0000000000..1826696ea8 --- /dev/null +++ b/libraries/base/GHC/IO/Handle/Internals.hs @@ -0,0 +1,793 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -XRecordWildCards #-} +{-# OPTIONS_HADDOCK hide #-} + +#undef DEBUG_DUMP + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.Internals +-- Copyright : (c) The University of Glasgow, 1994-2001 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- This module defines the basic operations on I\/O \"handles\". All +-- of the operations defined here are independent of the underlying +-- device. +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Handle.Internals ( + withHandle, withHandle', withHandle_, + withHandle__', withHandle_', withAllHandles__, + wantWritableHandle, wantReadableHandle, wantReadableHandle_, + wantSeekableHandle, + + mkHandle, mkFileHandle, mkDuplexHandle, + getEncoding, initBufferState, + dEFAULT_CHAR_BUFFER_SIZE, + + flushBuffer, flushWriteBuffer, flushWriteBuffer_, flushCharReadBuffer, + flushCharBuffer, flushByteReadBuffer, + + readTextDevice, writeTextDevice, readTextDeviceNonBlocking, + + augmentIOError, + ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, + ioe_finalizedHandle, ioe_bufsiz, + + hClose_help, hLookAhead_, + + HandleFinalizer, handleFinalizer, + + debugIO, + ) where + +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Encoding +import GHC.IO.Handle.Types +import GHC.IO.Buffer +import GHC.IO.BufferedIO (BufferedIO) +import GHC.IO.Exception +import GHC.IO.Device (IODevice, SeekMode(..)) +import qualified GHC.IO.Device as IODevice +import qualified GHC.IO.BufferedIO as Buffered + +import GHC.Real +import GHC.Base +import GHC.List +import GHC.Exception +import GHC.Num ( Num(..) ) +import GHC.Show +import GHC.IORef +import GHC.MVar +import Data.Typeable +import Control.Monad +import Data.Maybe +import Foreign +import System.IO.Error +import System.Posix.Internals hiding (FD) +import qualified System.Posix.Internals as Posix + +#ifdef DEBUG_DUMP +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Creating a new handle + +type HandleFinalizer = FilePath -> MVar Handle__ -> IO () + +newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle +newFileHandle filepath mb_finalizer hc = do + m <- newMVar hc + case mb_finalizer of + Just finalizer -> addMVarFinalizer m (finalizer filepath m) + Nothing -> return () + return (FileHandle filepath m) + +-- --------------------------------------------------------------------------- +-- Working with Handles + +{- +In the concurrent world, handles are locked during use. This is done +by wrapping an MVar around the handle which acts as a mutex over +operations on the handle. + +To avoid races, we use the following bracketing operations. The idea +is to obtain the lock, do some operation and replace the lock again, +whether the operation succeeded or failed. We also want to handle the +case where the thread receives an exception while processing the IO +operation: in these cases we also want to relinquish the lock. + +There are three versions of @withHandle@: corresponding to the three +possible combinations of: + + - the operation may side-effect the handle + - the operation may return a result + +If the operation generates an error or an exception is raised, the +original handle is always replaced. +-} + +{-# INLINE withHandle #-} +withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act +withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act + +withHandle' :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO (Handle__,a)) -> IO a +withHandle' fun h m act = + block $ do + h_ <- takeMVar m + checkHandleInvariants h_ + (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) + checkHandleInvariants h' + putMVar m h' + return v + +{-# INLINE withHandle_ #-} +withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a +withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act +withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act + +withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a +withHandle_' fun h m act = + block $ do + h_ <- takeMVar m + checkHandleInvariants h_ + v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) + checkHandleInvariants h_ + putMVar m h_ + return v + +withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () +withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act +withAllHandles__ fun h@(DuplexHandle _ r w) act = do + withHandle__' fun h r act + withHandle__' fun h w act + +withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) + -> IO () +withHandle__' fun h m act = + block $ do + h_ <- takeMVar m + checkHandleInvariants h_ + h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) + `catchException` \ex -> ioError (augmentIOError ex fun h) + checkHandleInvariants h' + putMVar m h' + return () + +augmentIOError :: IOException -> String -> Handle -> IOException +augmentIOError ioe@IOError{ ioe_filename = fp } fun h + = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath } + where filepath + | Just _ <- fp = fp + | otherwise = case h of + FileHandle path _ -> Just path + DuplexHandle path _ _ -> Just path + +-- --------------------------------------------------------------------------- +-- Wrapper for write operations. + +wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantWritableHandle fun h@(FileHandle _ m) act + = wantWritableHandle' fun h m act +wantWritableHandle fun h@(DuplexHandle _ _ m) act + = withHandle_' fun h m act + +wantWritableHandle' + :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO a) -> IO a +wantWritableHandle' fun h m act + = withHandle_' fun h m (checkWritableHandle act) + +checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkWritableHandle act h_@Handle__{..} + = case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + ReadHandle -> ioe_notWritable + ReadWriteHandle -> do + buf <- readIORef haCharBuffer + when (not (isWriteBuffer buf)) $ do + flushCharReadBuffer h_ + flushByteReadBuffer h_ + buf <- readIORef haCharBuffer + writeIORef haCharBuffer buf{ bufState = WriteBuffer } + buf <- readIORef haByteBuffer + writeIORef haByteBuffer buf{ bufState = WriteBuffer } + act h_ + _other -> act h_ + +-- --------------------------------------------------------------------------- +-- Wrapper for read operations. + +wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act) + +wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantReadableHandle_ fun h@(FileHandle _ m) act + = wantReadableHandle' fun h m act +wantReadableHandle_ fun h@(DuplexHandle _ m _) act + = withHandle_' fun h m act + +wantReadableHandle' + :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO a) -> IO a +wantReadableHandle' fun h m act + = withHandle_' fun h m (checkReadableHandle act) + +checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkReadableHandle act h_@Handle__{..} = + case haType of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notReadable + WriteHandle -> ioe_notReadable + ReadWriteHandle -> do + -- a read/write handle and we want to read from it. We must + -- flush all buffered write data first. + cbuf <- readIORef haCharBuffer + when (isWriteBuffer cbuf) $ do + cbuf' <- flushWriteBuffer_ h_ cbuf + writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer } + bbuf <- readIORef haByteBuffer + writeIORef haByteBuffer bbuf{ bufState = ReadBuffer } + act h_ + _other -> act h_ + +-- --------------------------------------------------------------------------- +-- Wrapper for seek operations. + +wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = + ioException (IOError (Just h) IllegalOperation fun + "handle is not seekable" Nothing Nothing) +wantSeekableHandle fun h@(FileHandle _ m) act = + withHandle_' fun h m (checkSeekableHandle act) + +checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a +checkSeekableHandle act handle_@Handle__{haDevice=dev} = + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + AppendHandle -> ioe_notSeekable + _ -> do b <- IODevice.isSeekable dev + if b then act handle_ + else ioe_notSeekable + +-- ----------------------------------------------------------------------------- +-- Handy IOErrors + +ioe_closedHandle, ioe_EOF, + ioe_notReadable, ioe_notWritable, ioe_cannotFlushTextRead, + ioe_notSeekable, ioe_notSeekable_notBin, ioe_invalidCharacter :: IO a + +ioe_closedHandle = ioException + (IOError Nothing IllegalOperation "" + "handle is closed" Nothing Nothing) +ioe_EOF = ioException + (IOError Nothing EOF "" "" Nothing Nothing) +ioe_notReadable = ioException + (IOError Nothing IllegalOperation "" + "handle is not open for reading" Nothing Nothing) +ioe_notWritable = ioException + (IOError Nothing IllegalOperation "" + "handle is not open for writing" Nothing Nothing) +ioe_notSeekable = ioException + (IOError Nothing IllegalOperation "" + "handle is not seekable" Nothing Nothing) +ioe_notSeekable_notBin = ioException + (IOError Nothing IllegalOperation "" + "seek operations on text-mode handles are not allowed on this platform" + Nothing Nothing) +ioe_cannotFlushTextRead = ioException + (IOError Nothing IllegalOperation "" + "cannot flush the read buffer of a text-mode handle" + Nothing Nothing) +ioe_invalidCharacter = ioException + (IOError Nothing InvalidArgument "" + ("invalid byte sequence for this encoding") Nothing Nothing) + +ioe_finalizedHandle :: FilePath -> Handle__ +ioe_finalizedHandle fp = throw + (IOError Nothing IllegalOperation "" + "handle is finalized" Nothing (Just fp)) + +ioe_bufsiz :: Int -> IO a +ioe_bufsiz n = ioException + (IOError Nothing InvalidArgument "hSetBuffering" + ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) + -- 9 => should be parens'ified. + +-- ----------------------------------------------------------------------------- +-- Handle Finalizers + +-- For a duplex handle, we arrange that the read side points to the write side +-- (and hence keeps it alive if the read side is alive). This is done by +-- having the haOtherSide field of the read side point to the read side. +-- The finalizer is then placed on the write side, and the handle only gets +-- finalized once, when both sides are no longer required. + +-- NOTE about finalized handles: It's possible that a handle can be +-- finalized and then we try to use it later, for example if the +-- handle is referenced from another finalizer, or from a thread that +-- has become unreferenced and then resurrected (arguably in the +-- latter case we shouldn't finalize the Handle...). Anyway, +-- we try to emit a helpful message which is better than nothing. + +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer fp m = do + handle_ <- takeMVar m + case haType handle_ of + ClosedHandle -> return () + _ -> do flushWriteBuffer handle_ `catchAny` \_ -> return () + -- ignore errors and async exceptions, and close the + -- descriptor anyway... + hClose_handle_ handle_ + return () + putMVar m (ioe_finalizedHandle fp) + +-- --------------------------------------------------------------------------- +-- Allocating buffers + +-- using an 8k char buffer instead of 32k improved performance for a +-- basic "cat" program by ~30% for me. --SDM +dEFAULT_CHAR_BUFFER_SIZE :: Int +dEFAULT_CHAR_BUFFER_SIZE = dEFAULT_BUFFER_SIZE `div` 4 + +getCharBuffer :: IODevice dev => dev -> BufferState + -> IO (IORef CharBuffer, BufferMode) +getCharBuffer dev state = do + buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + ioref <- newIORef buffer + is_tty <- IODevice.isTerminal dev + + let buffer_mode + | is_tty = LineBuffering + | otherwise = BlockBuffering Nothing + + return (ioref, buffer_mode) + +mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode) +mkUnBuffer state = do + buffer <- case state of -- See [note Buffer Sizing], GHC.IO.Handle.Types + ReadBuffer -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state + WriteBuffer -> newCharBuffer 1 state + ref <- newIORef buffer + return (ref, NoBuffering) + +-- ----------------------------------------------------------------------------- +-- Flushing buffers + +-- | syncs the file with the buffer, including moving the +-- file pointer backwards in the case of a read buffer. This can fail +-- on a non-seekable read Handle. +flushBuffer :: Handle__ -> IO () +flushBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + case bufState buf of + ReadBuffer -> do + flushCharReadBuffer h_ + flushByteReadBuffer h_ + WriteBuffer -> do + buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + +-- | flushes at least the Char buffer, and the byte buffer for a write +-- Handle. Works on all Handles. +flushCharBuffer :: Handle__ -> IO () +flushCharBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + case bufState buf of + ReadBuffer -> do + flushCharReadBuffer h_ + WriteBuffer -> do + buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + +-- ----------------------------------------------------------------------------- +-- Writing data (flushing write buffers) + +-- flushWriteBuffer flushes the buffer iff it contains pending write +-- data. Flushes both the Char and the byte buffer, leaving both +-- empty. +flushWriteBuffer :: Handle__ -> IO () +flushWriteBuffer h_@Handle__{..} = do + buf <- readIORef haCharBuffer + if isWriteBuffer buf + then do buf' <- flushWriteBuffer_ h_ buf + writeIORef haCharBuffer buf' + else return () + +flushWriteBuffer_ :: Handle__ -> CharBuffer -> IO CharBuffer +flushWriteBuffer_ h_@Handle__{..} cbuf = do + bbuf <- readIORef haByteBuffer + if not (isEmptyBuffer cbuf) || not (isEmptyBuffer bbuf) + then do writeTextDevice h_ cbuf + return cbuf{ bufL=0, bufR=0 } + else return cbuf + +-- ----------------------------------------------------------------------------- +-- Flushing read buffers + +-- It is always possible to flush the Char buffer back to the byte buffer. +flushCharReadBuffer :: Handle__ -> IO () +flushCharReadBuffer Handle__{..} = do + cbuf <- readIORef haCharBuffer + if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do + + -- haLastDecode is the byte buffer just before we did our last batch of + -- decoding. We're going to re-decode the bytes up to the current char, + -- to find out where we should revert the byte buffer to. + bbuf0 <- readIORef haLastDecode + + cbuf0 <- readIORef haCharBuffer + writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 } + + -- if we haven't used any characters from the char buffer, then just + -- re-install the old byte buffer. + if bufL cbuf0 == 0 + then do writeIORef haByteBuffer bbuf0 + return () + else do + + case haDecoder of + Nothing -> do + writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 } + -- no decoder: the number of bytes to decode is the same as the + -- number of chars we have used up. + + Just decoder -> do + debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++ + " cbuf=" ++ summaryBuffer cbuf0) + + (bbuf1,cbuf1) <- (encode decoder) bbuf0 + cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 } + + -- tricky case: if the decoded string starts with e BOM, then it was + -- probably ignored last time we decoded these bytes, and we should + -- therefore decode another char. + (c,_) <- readCharBuf (bufRaw cbuf1) (bufL cbuf1) + (bbuf2,_) <- if (c == '\xfeff') + then do debugIO "found BOM, decoding another char" + (encode decoder) bbuf1 + cbuf0{ bufL=0, bufR=0, bufSize = 1 } + else return (bbuf1,cbuf1) + + debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++ + " cbuf=" ++ summaryBuffer cbuf1) + + writeIORef haByteBuffer bbuf2 + + +-- When flushing the byte read buffer, we seek backwards by the number +-- of characters in the buffer. The file descriptor must therefore be +-- seekable: attempting to flush the read buffer on an unseekable +-- handle is not allowed. + +flushByteReadBuffer :: Handle__ -> IO () +flushByteReadBuffer h_@Handle__{..} = do + bbuf <- readIORef haByteBuffer + + if isEmptyBuffer bbuf then return () else do + + seekable <- IODevice.isSeekable haDevice + when (not seekable) $ ioe_cannotFlushTextRead + + let seek = negate (bufR bbuf - bufL bbuf) + + debugIO ("flushByteReadBuffer: new file offset = " ++ show seek) + IODevice.seek haDevice RelativeSeek (fromIntegral seek) + + writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 } + +-- ---------------------------------------------------------------------------- +-- Making Handles + +mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath + -> HandleType + -> Bool -- buffered? + -> Maybe TextEncoding + -> NewlineMode + -> (Maybe HandleFinalizer) + -> Maybe (MVar Handle__) + -> IO Handle + +mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do + let buf_state = initBufferState ha_type + bbuf <- Buffered.newBuffer dev buf_state + bbufref <- newIORef bbuf + last_decode <- newIORef bbuf + + (mb_encoder, mb_decoder) <- getEncoding mb_codec ha_type + + (cbufref,bmode) <- + if buffered then getCharBuffer dev buf_state + else mkUnBuffer buf_state + + spares <- newIORef BufferListNil + newFileHandle filepath finalizer + (Handle__ { haDevice = dev, + haType = ha_type, + haBufferMode = bmode, + haByteBuffer = bbufref, + haLastDecode = last_decode, + haCharBuffer = cbufref, + haBuffers = spares, + haEncoder = mb_encoder, + haDecoder = mb_decoder, + haInputNL = inputNL nl, + haOutputNL = outputNL nl, + haOtherSide = other_side + }) + +-- | makes a new 'Handle' +mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev) + => dev -- ^ the underlying IO device, which must support + -- 'IODevice', 'BufferedIO' and 'Typeable' + -> FilePath + -- ^ a string describing the 'Handle', e.g. the file + -- path for a file. Used in error messages. + -> IOMode + -- The mode in which the 'Handle' is to be used + -> Maybe TextEncoding + -- Create the 'Handle' with no text encoding? + -> NewlineMode + -- Translate newlines? + -> IO Handle +mkFileHandle dev filepath iomode mb_codec tr_newlines = do + mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec + tr_newlines + (Just handleFinalizer) Nothing{-other_side-} + +-- | like 'mkFileHandle', except that a 'Handle' is created with two +-- independent buffers, one for reading and one for writing. Used for +-- full-dupliex streams, such as network sockets. +mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev + -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle +mkDuplexHandle dev filepath mb_codec tr_newlines = do + + write_side@(FileHandle _ write_m) <- + mkHandle dev filepath WriteHandle True mb_codec + tr_newlines + (Just handleFinalizer) + Nothing -- no othersie + + read_side@(FileHandle _ read_m) <- + mkHandle dev filepath ReadHandle True mb_codec + tr_newlines + Nothing -- no finalizer + (Just write_m) + + return (DuplexHandle filepath read_m write_m) + +ioModeToHandleType :: IOMode -> HandleType +ioModeToHandleType ReadMode = ReadHandle +ioModeToHandleType WriteMode = WriteHandle +ioModeToHandleType ReadWriteMode = ReadWriteHandle +ioModeToHandleType AppendMode = AppendHandle + +initBufferState :: HandleType -> BufferState +initBufferState ReadHandle = ReadBuffer +initBufferState _ = WriteBuffer + +getEncoding :: Maybe TextEncoding -> HandleType + -> IO (Maybe TextEncoder, + Maybe TextDecoder) + +getEncoding Nothing ha_type = return (Nothing, Nothing) +getEncoding (Just te) ha_type = do + mb_decoder <- if isReadableHandleType ha_type then do + decoder <- mkTextDecoder te + return (Just decoder) + else + return Nothing + mb_encoder <- if isWritableHandleType ha_type then do + encoder <- mkTextEncoder te + return (Just encoder) + else + return Nothing + return (mb_encoder, mb_decoder) + +-- --------------------------------------------------------------------------- +-- closing Handles + +-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read +-- or an IO error occurs on a lazy stream. The semi-closed Handle is +-- then closed immediately. We have to be careful with DuplexHandles +-- though: we have to leave the closing to the finalizer in that case, +-- because the write side may still be in use. +hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException) +hClose_help handle_ = + case haType handle_ of + ClosedHandle -> return (handle_,Nothing) + _ -> do flushWriteBuffer handle_ -- interruptible + hClose_handle_ handle_ + +hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException) +hClose_handle_ Handle__{..} = do + + -- close the file descriptor, but not when this is the read + -- side of a duplex handle. + -- If an exception is raised by the close(), we want to continue + -- to close the handle and release the lock if it has one, then + -- we return the exception to the caller of hClose_help which can + -- raise it if necessary. + maybe_exception <- + case haOtherSide of + Nothing -> (do IODevice.close haDevice; return Nothing) + `catchException` \e -> return (Just e) + + Just _ -> return Nothing + + -- free the spare buffers + writeIORef haBuffers BufferListNil + writeIORef haCharBuffer noCharBuffer + writeIORef haByteBuffer noByteBuffer + + -- release our encoder/decoder + case haDecoder of Nothing -> return (); Just d -> close d + case haEncoder of Nothing -> return (); Just d -> close d + + -- we must set the fd to -1, because the finalizer is going + -- to run eventually and try to close/unlock it. + -- ToDo: necessary? the handle will be marked ClosedHandle + -- XXX GHC won't let us use record update here, hence wildcards + return (Handle__{ haType = ClosedHandle, .. }, maybe_exception) + +{-# NOINLINE noCharBuffer #-} +noCharBuffer :: CharBuffer +noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer + +{-# NOINLINE noByteBuffer #-} +noByteBuffer :: Buffer Word8 +noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer + +-- --------------------------------------------------------------------------- +-- Looking ahead + +hLookAhead_ :: Handle__ -> IO Char +hLookAhead_ handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + + -- fill up the read buffer if necessary + new_buf <- if isEmptyBuffer buf + then readTextDevice handle_ buf + else return buf + writeIORef haCharBuffer new_buf + + peekCharBuf (bufRaw buf) (bufL buf) + +-- --------------------------------------------------------------------------- +-- debugging + +debugIO :: String -> IO () +#if defined(DEBUG_DUMP) +debugIO s = do + withCStringLen (s++"\n") $ \(p,len) -> c_write 1 p (fromIntegral len) + return () +#else +debugIO s = return () +#endif + +-- ---------------------------------------------------------------------------- +-- Text input/output + +-- Write the contents of the supplied Char buffer to the device, return +-- only when all the data has been written. +writeTextDevice :: Handle__ -> CharBuffer -> IO () +writeTextDevice h_@Handle__{..} cbuf = do + -- + bbuf <- readIORef haByteBuffer + + debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++ + " bbuf=" ++ summaryBuffer bbuf) + + (cbuf',bbuf') <- case haEncoder of + Nothing -> latin1_encode cbuf bbuf + Just encoder -> (encode encoder) cbuf bbuf + + debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf') + + Buffered.flushWriteBuffer haDevice bbuf' + writeIORef haByteBuffer bbuf{bufL=0,bufR=0} + if not (isEmptyBuffer cbuf') + then writeTextDevice h_ cbuf' + else return () + +-- Read characters into the provided buffer. Return when any +-- characters are available; raise an exception if the end of +-- file is reached. +readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer +readTextDevice h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + + debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++ + " bbuf=" ++ summaryBuffer bbuf0) + + bbuf1 <- if not (isEmptyBuffer bbuf0) + then return bbuf0 + else do + (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0 + if r == 0 then ioe_EOF else do -- raise EOF + return bbuf1 + + debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1) + + writeIORef haLastDecode bbuf1 + (bbuf2,cbuf') <- case haDecoder of + Nothing -> latin1_decode bbuf1 cbuf + Just decoder -> (encode decoder) bbuf1 cbuf + + debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf2) + + writeIORef haByteBuffer bbuf2 + if bufR cbuf' == bufR cbuf -- no new characters + then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char + else return cbuf' + +-- we have an incomplete byte sequence at the end of the buffer: try to +-- read more bytes. +readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer +readTextDevice' h_@Handle__{..} bbuf0 cbuf = do + -- + -- copy the partial sequence to the beginning of the buffer, so we have + -- room to read more bytes. + bbuf1 <- slideContents bbuf0 + + bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1 + if r == 0 + then ioe_invalidCharacter + else return bbuf2 + + debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2) + + writeIORef haLastDecode bbuf2 + (bbuf3,cbuf') <- case haDecoder of + Nothing -> latin1_decode bbuf2 cbuf + Just decoder -> (encode decoder) bbuf2 cbuf + + debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + " bbuf=" ++ summaryBuffer bbuf3) + + writeIORef haByteBuffer bbuf3 + if bufR cbuf == bufR cbuf' + then readTextDevice' h_ bbuf3 cbuf' + else return cbuf' + +-- Read characters into the provided buffer. Do not block; +-- return zero characters instead. Raises an exception on end-of-file. +readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer +readTextDeviceNonBlocking h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer + bbuf1 <- if not (isEmptyBuffer bbuf0) + then return bbuf0 + else do + (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0 + if r == 0 then ioe_EOF else do -- raise EOF + return bbuf1 + + (bbuf2,cbuf') <- case haDecoder of + Nothing -> latin1_decode bbuf1 cbuf + Just decoder -> (encode decoder) bbuf1 cbuf + + writeIORef haByteBuffer bbuf2 + return cbuf' diff --git a/libraries/base/GHC/IO/Handle/Text.hs b/libraries/base/GHC/IO/Handle/Text.hs new file mode 100644 index 0000000000..2dd86df0da --- /dev/null +++ b/libraries/base/GHC/IO/Handle/Text.hs @@ -0,0 +1,961 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-unused-matches #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Text +-- Copyright : (c) The University of Glasgow, 1992-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- String I\/O functions +-- +----------------------------------------------------------------------------- + +-- #hide +module GHC.IO.Handle.Text ( + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + commitBuffer', -- hack, see below + hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + memcpy, + ) where + +import GHC.IO +import GHC.IO.FD +import GHC.IO.Buffer +import qualified GHC.IO.BufferedIO as Buffered +import GHC.IO.Exception +import GHC.IO.Handle.Types +import GHC.IO.Handle.Internals +import qualified GHC.IO.Device as IODevice +import qualified GHC.IO.Device as RawIO + +import Foreign +import Foreign.C + +import Data.Typeable +import System.IO.Error +import Data.Maybe +import Control.Monad + +import GHC.IORef +import GHC.Base +import GHC.Real +import GHC.Num +import GHC.Show +import GHC.List + +-- --------------------------------------------------------------------------- +-- Simple input operations + +-- If hWaitForInput finds anything in the Handle's buffer, it +-- immediately returns. If not, it tries to read from the underlying +-- OS handle. Notice that for buffered Handles connected to terminals +-- this means waiting until a complete line is available. + +-- | Computation 'hWaitForInput' @hdl t@ +-- waits until input is available on handle @hdl@. +-- It returns 'True' as soon as input is available on @hdl@, +-- or 'False' if no input is available within @t@ milliseconds. +-- +-- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. +-- +-- NOTE for GHC users: unless you use the @-threaded@ flag, +-- @hWaitForInput t@ where @t >= 0@ will block all other Haskell +-- threads for the duration of the call. It behaves like a +-- @safe@ foreign call in this respect. + +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput h msecs = do + wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do + buf <- readIORef haCharBuffer + + if not (isEmptyBuffer buf) + then return True + else do + + if msecs < 0 + then do buf' <- readTextDevice handle_ buf + writeIORef haCharBuffer buf' + return True + else do r <- IODevice.ready haDevice False{-read-} msecs + if r then do -- Call hLookAhead' to throw an EOF + -- exception if appropriate + hLookAhead_ handle_ + return True + else return False + +-- --------------------------------------------------------------------------- +-- hGetChar + +-- | Computation 'hGetChar' @hdl@ reads a character from the file or +-- channel managed by @hdl@, blocking until a character is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hGetChar :: Handle -> IO Char +hGetChar handle = + wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do + + -- buffering mode makes no difference: we just read whatever is available + -- from the device (blocking only if there is nothing available), and then + -- return the first character. + -- See [note Buffered Reading] in GHC.IO.Handle.Types + buf0 <- readIORef haCharBuffer + + buf1 <- if isEmptyBuffer buf0 + then readTextDevice handle_ buf0 + else return buf0 + + (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1) + let buf2 = bufferAdjustL i buf1 + + if haInputNL == CRLF && c1 == '\r' + then do + mbuf3 <- if isEmptyBuffer buf2 + then maybeFillReadBuffer handle_ buf2 + else return (Just buf2) + + case mbuf3 of + -- EOF, so just return the '\r' we have + Nothing -> do + writeIORef haCharBuffer buf2 + return '\r' + Just buf3 -> do + (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2) + if c2 == '\n' + then do + writeIORef haCharBuffer (bufferAdjustL i2 buf3) + return '\n' + else do + -- not a \r\n sequence, so just return the \r + writeIORef haCharBuffer buf3 + return '\r' + else do + writeIORef haCharBuffer buf2 + return c1 + +-- --------------------------------------------------------------------------- +-- hGetLine + +-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for +-- the duration. + +-- | Computation 'hGetLine' @hdl@ reads a line from the file or +-- channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file is encountered when reading +-- the /first/ character of the line. +-- +-- If 'hGetLine' encounters end-of-file at any other point while reading +-- in a line, it is treated as a line terminator and the (partial) +-- line is returned. + +hGetLine :: Handle -> IO String +hGetLine h = + wantReadableHandle_ "hGetLine" h $ \ handle_ -> do + hGetLineBuffered handle_ + +hGetLineBuffered :: Handle__ -> IO String +hGetLineBuffered handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + hGetLineBufferedLoop handle_ buf [] + +hGetLineBufferedLoop :: Handle__ + -> CharBuffer -> [String] + -> IO String +hGetLineBufferedLoop handle_@Handle__{..} + buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss = + let + -- find the end-of-line character, if there is one + loop raw r + | r == w = return (False, w) + | otherwise = do + (c,r') <- readCharBuf raw r + if c == '\n' + then return (True, r) -- NB. not r': don't include the '\n' + else loop raw r' + in do + (eol, off) <- loop raw0 r0 + + debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off) + + (xs,r') <- if haInputNL == CRLF + then unpack_nl raw0 r0 off "" + else do xs <- unpack raw0 r0 off "" + return (xs,off) + + -- if eol == True, then off is the offset of the '\n' + -- otherwise off == w and the buffer is now empty. + if eol -- r' == off + then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf) + return (concat (reverse (xs:xss))) + else do + let buf1 = bufferAdjustL r' buf + maybe_buf <- maybeFillReadBuffer handle_ buf1 + case maybe_buf of + -- Nothing indicates we caught an EOF, and we may have a + -- partial line to return. + Nothing -> do + -- we reached EOF. There might be a lone \r left + -- in the buffer, so check for that and + -- append it to the line if necessary. + -- + let pre = if not (isEmptyBuffer buf1) then "\r" else "" + writeIORef haCharBuffer buf1{ bufL=0, bufR=0 } + let str = concat (reverse (pre:xs:xss)) + if not (null str) + then return str + else ioe_EOF + Just new_buf -> + hGetLineBufferedLoop handle_ new_buf (xs:xss) + +maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) +maybeFillReadBuffer handle_ buf + = catch + (do buf' <- getSomeCharacters handle_ buf + return (Just buf') + ) + (\e -> do if isEOFError e + then return Nothing + else ioError e) + +-- See GHC.IO.Buffer +#define CHARBUF_UTF32 +-- #define CHARBUF_UTF16 + +-- NB. performance-critical code: eyeball the Core. +unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char] +unpack !buf !r !w acc0 + | r == w = return acc0 + | otherwise = + withRawBuffer buf $ \pbuf -> + let + unpackRB acc !i + | i < r = return acc + | otherwise = do +#ifdef CHARBUF_UTF16 + -- reverse-order decoding of UTF-16 + c2 <- peekElemOff pbuf i + if (c2 < 0xdc00 || c2 > 0xdffff) + then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1) + else do c1 <- peekElemOff pbuf (i-1) + let c = (fromIntegral c1 - 0xd800) * 0x400 + + (fromIntegral c2 - 0xdc00) + 0x10000 + unpackRB (unsafeChr c : acc) (i-2) +#else + c <- peekElemOff pbuf i + unpackRB (c:acc) (i-1) +#endif + in + unpackRB acc0 (w-1) + +-- NB. performance-critical code: eyeball the Core. +unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int) +unpack_nl !buf !r !w acc0 + | r == w = return (acc0, 0) + | otherwise = + withRawBuffer buf $ \pbuf -> + let + unpackRB acc !i + | i < r = return acc + | otherwise = do + c <- peekElemOff pbuf i + if (c == '\n' && i > r) + then do + c1 <- peekElemOff pbuf (i-1) + if (c1 == '\r') + then unpackRB ('\n':acc) (i-2) + else unpackRB ('\n':acc) (i-1) + else do + unpackRB (c:acc) (i-1) + in do + c <- peekElemOff pbuf (w-1) + if (c == '\r') + then do + -- If the last char is a '\r', we need to know whether or + -- not it is followed by a '\n', so leave it in the buffer + -- for now and just unpack the rest. + str <- unpackRB acc0 (w-2) + return (str, w-1) + else do + str <- unpackRB acc0 (w-1) + return (str, w) + + +-- ----------------------------------------------------------------------------- +-- hGetContents + +-- hGetContents on a DuplexHandle only affects the read side: you can +-- carry on writing to it afterwards. + +-- | Computation 'hGetContents' @hdl@ returns the list of characters +-- corresponding to the unread portion of the channel or file managed +-- by @hdl@, which is put into an intermediate state, /semi-closed/. +-- In this state, @hdl@ is effectively closed, +-- but items are read from @hdl@ on demand and accumulated in a special +-- list returned by 'hGetContents' @hdl@. +-- +-- Any operation that fails because a handle is closed, +-- also fails if a handle is semi-closed. The only exception is 'hClose'. +-- A semi-closed handle becomes closed: +-- +-- * if 'hClose' is applied to it; +-- +-- * if an I\/O error occurs when reading an item from the handle; +-- +-- * or once the entire contents of the handle has been read. +-- +-- Once a semi-closed handle becomes closed, the contents of the +-- associated list becomes fixed. The contents of this final list is +-- only partially specified: it will contain at least all the items of +-- the stream that were evaluated prior to the handle becoming closed. +-- +-- Any I\/O errors encountered while a handle is semi-closed are simply +-- discarded. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. + +hGetContents :: Handle -> IO String +hGetContents handle = + wantReadableHandle "hGetContents" handle $ \handle_ -> do + xs <- lazyRead handle + return (handle_{ haType=SemiClosedHandle}, xs ) + +-- Note that someone may close the semi-closed handle (or change its +-- buffering), so each time these lazy read functions are pulled on, +-- they have to check whether the handle has indeed been closed. + +lazyRead :: Handle -> IO String +lazyRead handle = + unsafeInterleaveIO $ + withHandle "lazyRead" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> return (handle_, "") + SemiClosedHandle -> lazyReadBuffered handle handle_ + _ -> ioException + (IOError (Just handle) IllegalOperation "lazyRead" + "illegal handle type" Nothing Nothing) + +lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) +lazyReadBuffered h handle_@Handle__{..} = do + buf <- readIORef haCharBuffer + catch + (do + buf'@Buffer{..} <- getSomeCharacters handle_ buf + lazy_rest <- lazyRead h + (s,r) <- if haInputNL == CRLF + then unpack_nl bufRaw bufL bufR lazy_rest + else do s <- unpack bufRaw bufL bufR lazy_rest + return (s,bufR) + writeIORef haCharBuffer (bufferAdjustL r buf') + return (handle_, s) + ) + -- all I/O errors are discarded. Additionally, we close the handle. + (\e -> do (handle_', _) <- hClose_help handle_ + debugIO ("hGetContents caught: " ++ show e) + -- We might have a \r cached in CRLF mode. So we + -- need to check for that and return it: + if not (isEmptyBuffer buf) + then return (handle_', "\r") + else return (handle_', "") + ) + +-- ensure we have some characters in the buffer +getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer +getSomeCharacters handle_@Handle__{..} buf@Buffer{..} = + case bufferElems buf of + + -- buffer empty: read some more + 0 -> readTextDevice handle_ buf + + -- if the buffer has a single '\r' in it and we're doing newline + -- translation: read some more + 1 | haInputNL == CRLF -> do + (c,_) <- readCharBuf bufRaw bufL + if c == '\r' + then do -- shuffle the '\r' to the beginning. This is only safe + -- if we're about to call readTextDevice, otherwise it + -- would mess up flushCharBuffer. + -- See [note Buffer Flushing], GHC.IO.Handle.Types + writeCharBuf bufRaw 0 '\r' + let buf' = buf{ bufL=0, bufR=1 } + readTextDevice handle_ buf' + else do + return buf + + -- buffer has some chars in it already: just return it + _otherwise -> + return buf + +-- --------------------------------------------------------------------------- +-- hPutChar + +-- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the +-- file or channel managed by @hdl@. Characters may be buffered if +-- buffering is enabled for @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. + +hPutChar :: Handle -> Char -> IO () +hPutChar handle c = do + c `seq` return () + wantWritableHandle "hPutChar" handle $ \ handle_ -> do + case haBufferMode handle_ of + LineBuffering -> hPutcBuffered handle_ True c + _other -> hPutcBuffered handle_ False c + +hPutcBuffered :: Handle__ -> Bool -> Char -> IO () +hPutcBuffered handle_@Handle__{..} is_line c = do + buf <- readIORef haCharBuffer + if c == '\n' + then do buf1 <- if haOutputNL == CRLF + then do + buf1 <- putc buf '\r' + putc buf1 '\n' + else do + putc buf '\n' + if is_line + then do + flushed_buf <- flushWriteBuffer_ handle_ buf1 + writeIORef haCharBuffer flushed_buf + else + writeIORef haCharBuffer buf1 + else do + buf1 <- putc buf c + writeIORef haCharBuffer buf1 + where + putc buf@Buffer{ bufRaw=raw, bufR=w } c = do + debugIO ("putc: " ++ summaryBuffer buf) + w' <- writeCharBuf raw w c + let buf' = buf{ bufR = w' } + if isFullCharBuffer buf' + then flushWriteBuffer_ handle_ buf' + else return buf' + +-- --------------------------------------------------------------------------- +-- hPutStr + +-- We go to some trouble to avoid keeping the handle locked while we're +-- evaluating the string argument to hPutStr, in case doing so triggers another +-- I/O operation on the same handle which would lead to deadlock. The classic +-- case is +-- +-- putStr (trace "hello" "world") +-- +-- so the basic scheme is this: +-- +-- * copy the string into a fresh buffer, +-- * "commit" the buffer to the handle. +-- +-- Committing may involve simply copying the contents of the new +-- buffer into the handle's buffer, flushing one or both buffers, or +-- maybe just swapping the buffers over (if the handle's buffer was +-- empty). See commitBuffer below. + +-- | Computation 'hPutStr' @hdl s@ writes the string +-- @s@ to the file or channel managed by @hdl@. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; or +-- +-- * 'isPermissionError' if another system resource limit would be exceeded. + +hPutStr :: Handle -> String -> IO () +hPutStr handle str = do + (buffer_mode, nl) <- + wantWritableHandle "hPutStr" handle $ \h_ -> do + bmode <- getSpareBuffer h_ + return (bmode, haOutputNL h_) + + case buffer_mode of + (NoBuffering, _) -> do + hPutChars handle str -- v. slow, but we don't care + (LineBuffering, buf) -> do + writeBlocks handle True nl buf str + (BlockBuffering _, buf) -> do + writeBlocks handle False nl buf str + +hPutChars :: Handle -> [Char] -> IO () +hPutChars _ [] = return () +hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs + +getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer) +getSpareBuffer Handle__{haCharBuffer=ref, + haBuffers=spare_ref, + haBufferMode=mode} + = do + case mode of + NoBuffering -> return (mode, error "no buffer!") + _ -> do + bufs <- readIORef spare_ref + buf <- readIORef ref + case bufs of + BufferListCons b rest -> do + writeIORef spare_ref rest + return ( mode, emptyBuffer b (bufSize buf) WriteBuffer) + BufferListNil -> do + new_buf <- newCharBuffer (bufSize buf) WriteBuffer + return (mode, new_buf) + + +-- NB. performance-critical code: eyeball the Core. +writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO () +writeBlocks hdl line_buffered nl + buf@Buffer{ bufRaw=raw, bufSize=len } s = + let + shoveString :: Int -> [Char] -> IO () + shoveString !n [] = do + commitBuffer hdl raw len n False{-no flush-} True{-release-} + return () + shoveString !n (c:cs) + -- n+1 so we have enough room to write '\r\n' if necessary + | n + 1 >= len = do + new_buf <- commitBuffer hdl raw len n True{-needs flush-} False + writeBlocks hdl line_buffered nl new_buf (c:cs) + | c == '\n' = do + n' <- if nl == CRLF + then do + n1 <- writeCharBuf raw n '\r' + writeCharBuf raw n1 '\n' + else do + writeCharBuf raw n c + if line_buffered + then do + new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False + writeBlocks hdl line_buffered nl new_buf cs + else do + shoveString n' cs + | otherwise = do + n' <- writeCharBuf raw n c + shoveString n' cs + in + shoveString 0 s + +-- ----------------------------------------------------------------------------- +-- commitBuffer handle buf sz count flush release +-- +-- Write the contents of the buffer 'buf' ('sz' bytes long, containing +-- 'count' bytes of data) to handle (handle must be block or line buffered). +-- +-- Implementation: +-- +-- for block/line buffering, +-- 1. If there isn't room in the handle buffer, flush the handle +-- buffer. +-- +-- 2. If the handle buffer is empty, +-- if flush, +-- then write buf directly to the device. +-- else swap the handle buffer with buf. +-- +-- 3. If the handle buffer is non-empty, copy buf into the +-- handle buffer. Then, if flush != 0, flush +-- the buffer. + +commitBuffer + :: Handle -- handle to commit to + -> RawCharBuffer -> Int -- address and size (in bytes) of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- True <=> flush the handle afterward + -> Bool -- release the buffer? + -> IO CharBuffer + +commitBuffer hdl !raw !sz !count flush release = + wantWritableHandle "commitAndReleaseBuffer" hdl $ + commitBuffer' raw sz count flush release +{-# NOINLINE commitBuffer #-} + +-- Explicitly lambda-lift this function to subvert GHC's full laziness +-- optimisations, which otherwise tends to float out subexpressions +-- past the \handle, which is really a pessimisation in this case because +-- that lambda is a one-shot lambda. +-- +-- Don't forget to export the function, to stop it being inlined too +-- (this appears to be better than NOINLINE, because the strictness +-- analyser still gets to worker-wrapper it). +-- +-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 +-- +commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__ + -> IO CharBuffer +commitBuffer' raw sz@(I# _) count@(I# _) flush release + handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do + + debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count + ++ ", flush=" ++ show flush ++ ", release=" ++ show release) + + old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } + <- readIORef ref + + buf_ret <- + -- enough room in handle buffer? + if (not flush && (size - w > count)) + -- The > is to be sure that we never exactly fill + -- up the buffer, which would require a flush. So + -- if copying the new data into the buffer would + -- make the buffer full, we just flush the existing + -- buffer and the new data immediately, rather than + -- copying before flushing. + + -- not flushing, and there's enough room in the buffer: + -- just copy the data in and update bufR. + then do withRawBuffer raw $ \praw -> + copyToRawBuffer old_raw (w*charSize) + praw (fromIntegral (count*charSize)) + writeIORef ref old_buf{ bufR = w + count } + return (emptyBuffer raw sz WriteBuffer) + + -- else, we have to flush + else do flushed_buf <- flushWriteBuffer_ handle_ old_buf + + let this_buf = + Buffer{ bufRaw=raw, bufState=WriteBuffer, + bufL=0, bufR=count, bufSize=sz } + + -- if: (a) we don't have to flush, and + -- (b) size(new buffer) == size(old buffer), and + -- (c) new buffer is not full, + -- we can just just swap them over... + if (not flush && sz == size && count /= sz) + then do + writeIORef ref this_buf + return flushed_buf + + -- otherwise, we have to flush the new data too, + -- and start with a fresh buffer + else do + flushWriteBuffer_ handle_ this_buf + writeIORef ref flushed_buf + -- if the sizes were different, then allocate + -- a new buffer of the correct size. + if sz == size + then return (emptyBuffer raw sz WriteBuffer) + else newCharBuffer size WriteBuffer + + -- release the buffer if necessary + case buf_ret of + Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do + if release && buf_ret_sz == size + then do + spare_bufs <- readIORef spare_buf_ref + writeIORef spare_buf_ref + (BufferListCons buf_ret_raw spare_bufs) + return buf_ret + else + return buf_ret + +-- --------------------------------------------------------------------------- +-- Reading/writing sequences of bytes. + +-- --------------------------------------------------------------------------- +-- hPutBuf + +-- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the +-- buffer @buf@ to the handle @hdl@. It returns (). +-- +-- 'hPutBuf' ignores any text encoding that applies to the 'Handle', +-- writing the bytes directly to the underlying file or device. +-- +-- This operation may fail with: +-- +-- * 'ResourceVanished' if the handle is a pipe or socket, and the +-- reading end is closed. (If this is a POSIX system, and the program +-- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered +-- instead, whose default action is to terminate the program). + +hPutBuf :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO () +hPutBuf h ptr count = do hPutBuf' h ptr count True; return () + +hPutBufNonBlocking + :: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> IO Int -- returns: number of bytes written +hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False + +hPutBuf':: Handle -- handle to write to + -> Ptr a -- address of buffer + -> Int -- number of bytes of data in buffer + -> Bool -- allow blocking? + -> IO Int +hPutBuf' handle ptr count can_block + | count == 0 = return 0 + | count < 0 = illegalBufferSize handle "hPutBuf" count + | otherwise = + wantWritableHandle "hPutBuf" handle $ + \ h_@Handle__{..} -> do + debugIO ("hPutBuf count=" ++ show count) + -- first flush the Char buffer if it is non-empty, then we + -- can work directly with the byte buffer + cbuf <- readIORef haCharBuffer + when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_ + + r <- bufWrite h_ (castPtr ptr) count can_block + + -- we must flush if this Handle is set to NoBuffering. If + -- it is set to LineBuffering, be conservative and flush + -- anyway (we didn't check for newlines in the data). + case haBufferMode of + BlockBuffering _ -> do return () + _line_or_no_buffering -> do flushWriteBuffer h_ + return r + +bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int +bufWrite h_@Handle__{..} ptr count can_block = + seq count $ do -- strictness hack + old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } + <- readIORef haByteBuffer + + -- enough room in handle buffer? + if (size - w > count) + -- There's enough room in the buffer: + -- just copy the data in and update bufR. + then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w) + copyToRawBuffer old_raw w ptr (fromIntegral count) + writeIORef haByteBuffer old_buf{ bufR = w + count } + return count + + -- else, we have to flush + else do debugIO "hPutBuf: flushing first" + Buffered.flushWriteBuffer haDevice old_buf + -- TODO: we should do a non-blocking flush here + writeIORef haByteBuffer old_buf{bufL=0,bufR=0} + -- if we can fit in the buffer, then just loop + if count < size + then bufWrite h_ ptr count can_block + else if can_block + then do writeChunk h_ (castPtr ptr) count + return count + else writeChunkNonBlocking h_ (castPtr ptr) count + +writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO () +writeChunk h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes + | otherwise = error "Todo: hPutBuf" + +writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int +writeChunkNonBlocking h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes + | otherwise = error "Todo: hPutBuf" + +-- --------------------------------------------------------------------------- +-- hGetBuf + +-- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached or +-- @count@ 8-bit bytes have been read. +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently +-- using, and reads bytes directly from the underlying IO device. +-- +-- 'hGetBuf' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBuf' will behave as if EOF was reached. +-- + +hGetBuf :: Handle -> Ptr a -> Int -> IO Int +hGetBuf h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBuf" count + | otherwise = + wantReadableHandle_ "hGetBuf" h $ \ h_ -> do + flushCharReadBuffer h_ + bufRead h_ (castPtr ptr) 0 count + +-- small reads go through the buffer, large reads are satisfied by +-- taking data first from the buffer and then direct from the file +-- descriptor. +bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int +bufRead h_@Handle__{..} ptr so_far count = + seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- small read? + then do rest <- readChunk h_ ptr count + return (so_far + rest) + else do (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return so_far + else do writeIORef haByteBuffer buf' + bufRead h_ ptr so_far count + else do + let avail = w - r + if (count == avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + return (so_far + count) + else do + if (count < avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufL = r + count } + return (so_far + count) + else do + + copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + if remaining < sz + then bufRead h_ ptr' so_far' remaining + else do + + rest <- readChunk h_ ptr' remaining + return (so_far' + rest) + +readChunk :: Handle__ -> Ptr a -> Int -> IO Int +readChunk h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = loop fd 0 bytes + | otherwise = error "ToDo: hGetBuf" + where + loop :: FD -> Int -> Int -> IO Int + loop fd off bytes | bytes <= 0 = return off + loop fd off bytes = do + r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes) + if r == 0 + then return off + else loop fd (off + r) (bytes - r) + +-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@ until either EOF is reached, or +-- @count@ 8-bit bytes have been read, or there is no more data available +-- to read immediately. +-- +-- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will +-- never block waiting for data to become available, instead it returns +-- only whatever data is available. To wait for data to arrive before +-- calling 'hGetBufNonBlocking', use 'hWaitForInput'. +-- +-- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle' +-- is currently using, and reads bytes directly from the underlying IO +-- device. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. +-- +hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int +hGetBufNonBlocking h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count + | otherwise = + wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do + flushCharReadBuffer h_ + bufReadNonBlocking h_ (castPtr ptr) 0 count + +bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNonBlocking h_@Handle__{..} ptr so_far count = + seq so_far $ seq count $ do -- strictness hack + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- large read? + then do rest <- readChunkNonBlocking h_ ptr count + return (so_far + rest) + else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf + case r of + Nothing -> return so_far + Just 0 -> return so_far + Just r -> do + writeIORef haByteBuffer buf' + bufReadNonBlocking h_ ptr so_far (min count r) + -- NOTE: new count is min count w' + -- so we will just copy the contents of the + -- buffer in the recursive call, and not + -- loop again. + else do + let avail = w - r + if (count == avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + return (so_far + count) + else do + if (count < avail) + then do + copyFromRawBuffer ptr raw r count + writeIORef haByteBuffer buf{ bufL = r + count } + return (so_far + count) + else do + + copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) + writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + let remaining = count - avail + so_far' = so_far + avail + ptr' = ptr `plusPtr` avail + + -- we haven't attempted to read anything yet if we get to here. + if remaining < sz + then bufReadNonBlocking h_ ptr' so_far' remaining + else do + + rest <- readChunkNonBlocking h_ ptr' remaining + return (so_far' + rest) + + +readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int +readChunkNonBlocking h_@Handle__{..} ptr bytes + | Just fd <- cast haDevice = do + m <- RawIO.readNonBlocking (fd::FD) ptr bytes + case m of + Nothing -> return 0 + Just n -> return n + | otherwise = error "ToDo: hGetBuf" + +-- --------------------------------------------------------------------------- +-- memcpy wrappers + +copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO () +copyToRawBuffer raw off ptr bytes = do + withRawBuffer raw $ \praw -> + memcpy (praw `plusPtr` off) ptr (fromIntegral bytes) + return () + +copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO () +copyFromRawBuffer ptr raw off bytes = do + withRawBuffer raw $ \praw -> + memcpy ptr (praw `plusPtr` off) (fromIntegral bytes) + return () + +foreign import ccall unsafe "memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ()) + +----------------------------------------------------------------------------- +-- Internal Utils + +illegalBufferSize :: Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioException (IOError (Just handle) + InvalidArgument fn + ("illegal buffer size " ++ showsPrec 9 sz []) + Nothing Nothing) diff --git a/libraries/base/GHC/IO/Handle/Types.hs b/libraries/base/GHC/IO/Handle/Types.hs new file mode 100644 index 0000000000..f3cf717065 --- /dev/null +++ b/libraries/base/GHC/IO/Handle/Types.hs @@ -0,0 +1,400 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Handle.Types +-- Copyright : (c) The University of Glasgow, 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Basic types for the implementation of IO Handles. +-- +----------------------------------------------------------------------------- + +module GHC.IO.Handle.Types ( + Handle(..), Handle__(..), showHandle, + checkHandleInvariants, + BufferList(..), + HandleType(..), + isReadableHandleType, isWritableHandleType, isReadWriteHandleType, + BufferMode(..), + BufferCodec(..), + NewlineMode(..), Newline(..), nativeNewline, + universalNewlineMode, noNewlineTranslation, nativeNewlineMode + ) where + +#undef DEBUG + +import GHC.Base +import GHC.MVar +import GHC.IO +import GHC.IO.Buffer +import GHC.IO.BufferedIO +import GHC.IO.Encoding.Types +import GHC.IORef +import Data.Maybe +import GHC.Show +import GHC.Read +import GHC.Word +import GHC.IO.Device +import Data.Typeable + +-- --------------------------------------------------------------------------- +-- Handle type + +-- A Handle is represented by (a reference to) a record +-- containing the state of the I/O port/device. We record +-- the following pieces of info: + +-- * type (read,write,closed etc.) +-- * the underlying file descriptor +-- * buffering mode +-- * buffer, and spare buffers +-- * user-friendly name (usually the +-- FilePath used when IO.openFile was called) + +-- Note: when a Handle is garbage collected, we want to flush its buffer +-- and close the OS file handle, so as to free up a (precious) resource. + +-- | Haskell defines operations to read and write characters from and to files, +-- represented by values of type @Handle@. Each value of this type is a +-- /handle/: a record used by the Haskell run-time system to /manage/ I\/O +-- with file system objects. A handle has at least the following properties: +-- +-- * whether it manages input or output or both; +-- +-- * whether it is /open/, /closed/ or /semi-closed/; +-- +-- * whether the object is seekable; +-- +-- * whether buffering is disabled, or enabled on a line or block basis; +-- +-- * a buffer (whose length may be zero). +-- +-- Most handles will also have a current I\/O position indicating where the next +-- input or output operation will occur. A handle is /readable/ if it +-- manages only input or both input and output; likewise, it is /writable/ if +-- it manages only output or both input and output. A handle is /open/ when +-- first allocated. +-- Once it is closed it can no longer be used for either input or output, +-- though an implementation cannot re-use its storage while references +-- remain to it. Handles are in the 'Show' and 'Eq' classes. The string +-- produced by showing a handle is system dependent; it should include +-- enough information to identify the handle for debugging. A handle is +-- equal according to '==' only to itself; no attempt +-- is made to compare the internal state of different handles for equality. +-- +-- GHC note: a 'Handle' will be automatically closed when the garbage +-- collector detects that it has become unreferenced by the program. +-- However, relying on this behaviour is not generally recommended: +-- the garbage collector is unpredictable. If possible, use explicit +-- an explicit 'hClose' to close 'Handle's when they are no longer +-- required. GHC does not currently attempt to free up file +-- descriptors when they have run out, it is your responsibility to +-- ensure that this doesn't happen. + +data Handle + = FileHandle -- A normal handle to a file + FilePath -- the file (used for error messages + -- only) + !(MVar Handle__) + + | DuplexHandle -- A handle to a read/write stream + FilePath -- file for a FIFO, otherwise some + -- descriptive string (used for error + -- messages only) + !(MVar Handle__) -- The read side + !(MVar Handle__) -- The write side + + deriving Typeable + +-- NOTES: +-- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be +-- seekable. + +instance Eq Handle where + (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2 + (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2 + _ == _ = False + +data Handle__ + = forall dev . (IODevice dev, BufferedIO dev, Typeable dev) => + Handle__ { + haDevice :: !dev, + haType :: HandleType, -- type (read/write/append etc.) + haByteBuffer :: !(IORef (Buffer Word8)), + haBufferMode :: BufferMode, + haLastDecode :: !(IORef (Buffer Word8)), + haCharBuffer :: !(IORef (Buffer CharBufElem)), -- the current buffer + haBuffers :: !(IORef (BufferList CharBufElem)), -- spare buffers + haEncoder :: Maybe TextEncoder, + haDecoder :: Maybe TextDecoder, + haInputNL :: Newline, + haOutputNL :: Newline, + haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a + -- duplex handle. + } + deriving Typeable + +-- we keep a few spare buffers around in a handle to avoid allocating +-- a new one for each hPutStr. These buffers are *guaranteed* to be the +-- same size as the main buffer. +data BufferList e + = BufferListNil + | BufferListCons (RawBuffer e) (BufferList e) + +-- Internally, we classify handles as being one +-- of the following: + +data HandleType + = ClosedHandle + | SemiClosedHandle + | ReadHandle + | WriteHandle + | AppendHandle + | ReadWriteHandle + +isReadableHandleType :: HandleType -> Bool +isReadableHandleType ReadHandle = True +isReadableHandleType ReadWriteHandle = True +isReadableHandleType _ = False + +isWritableHandleType :: HandleType -> Bool +isWritableHandleType AppendHandle = True +isWritableHandleType WriteHandle = True +isWritableHandleType ReadWriteHandle = True +isWritableHandleType _ = False + +isReadWriteHandleType :: HandleType -> Bool +isReadWriteHandleType ReadWriteHandle{} = True +isReadWriteHandleType _ = False + +-- INVARIANTS on Handles: +-- +-- * A handle *always* has a buffer, even if it is only 1 character long +-- (an unbuffered handle needs a 1 character buffer in order to support +-- hLookAhead and hIsEOF). +-- * In a read Handle, the byte buffer is always empty (we decode when reading) +-- * In a wriite Handle, the Char buffer is always empty (we encode when writing) +-- +checkHandleInvariants :: Handle__ -> IO () +#ifdef DEBUG +checkHandleInvariants h_ = do + bbuf <- readIORef (haByteBuffer h_) + checkBuffer bbuf + cbuf <- readIORef (haCharBuffer h_) + checkBuffer cbuf +#else +checkHandleInvariants _ = return () +#endif + +-- --------------------------------------------------------------------------- +-- Buffering modes + +-- | Three kinds of buffering are supported: line-buffering, +-- block-buffering or no-buffering. These modes have the following +-- effects. For output, items are written out, or /flushed/, +-- from the internal buffer according to the buffer mode: +-- +-- * /line-buffering/: the entire output buffer is flushed +-- whenever a newline is output, the buffer overflows, +-- a 'System.IO.hFlush' is issued, or the handle is closed. +-- +-- * /block-buffering/: the entire buffer is written out whenever it +-- overflows, a 'System.IO.hFlush' is issued, or the handle is closed. +-- +-- * /no-buffering/: output is written immediately, and never stored +-- in the buffer. +-- +-- An implementation is free to flush the buffer more frequently, +-- but not less frequently, than specified above. +-- The output buffer is emptied as soon as it has been written out. +-- +-- Similarly, input occurs according to the buffer mode for the handle: +-- +-- * /line-buffering/: when the buffer for the handle is not empty, +-- the next item is obtained from the buffer; otherwise, when the +-- buffer is empty, characters up to and including the next newline +-- character are read into the buffer. No characters are available +-- until the newline character is available or the buffer is full. +-- +-- * /block-buffering/: when the buffer for the handle becomes empty, +-- the next block of data is read into the buffer. +-- +-- * /no-buffering/: the next input item is read and returned. +-- The 'System.IO.hLookAhead' operation implies that even a no-buffered +-- handle may require a one-character buffer. +-- +-- The default buffering mode when a handle is opened is +-- implementation-dependent and may depend on the file system object +-- which is attached to that handle. +-- For most implementations, physical files will normally be block-buffered +-- and terminals will normally be line-buffered. + +data BufferMode + = NoBuffering -- ^ buffering is disabled if possible. + | LineBuffering + -- ^ line-buffering should be enabled if possible. + | BlockBuffering (Maybe Int) + -- ^ block-buffering should be enabled if possible. + -- The size of the buffer is @n@ items if the argument + -- is 'Just' @n@ and is otherwise implementation-dependent. + deriving (Eq, Ord, Read, Show) + +{- +[note Buffering Implementation] + +Each Handle has two buffers: a byte buffer (haByteBuffer) and a Char +buffer (haCharBuffer). + +[note Buffered Reading] + +For read Handles, bytes are read into the byte buffer, and immediately +decoded into the Char buffer (see +GHC.IO.Handle.Internals.readTextDevice). The only way there might be +some data left in the byte buffer is if there is a partial multi-byte +character sequence that cannot be decoded into a full character. + +Note that the buffering mode (haBufferMode) makes no difference when +reading data into a Handle. When reading, we can always just read all +the data there is available without blocking, decode it into the Char +buffer, and then provide it immediately to the caller. + +[note Buffered Writing] + +Characters are written into the Char buffer by e.g. hPutStr. When the +buffer is full, we call writeTextDevice, which encodes the Char buffer +into the byte buffer, and then immediately writes it all out to the +underlying device. The Char buffer will always be empty afterward. +This might require multiple decoding/writing cycles. + +[note Buffer Sizing] + +Since the buffer mode makes no difference when reading, we can just +use the default buffer size for both the byte and the Char buffer. +Ineed, we must have room for at least one Char in the Char buffer, +because we have to implement hLookAhead, which requires caching a Char +in the Handle. Furthermore, when doing newline translation, we need +room for at least two Chars in the read buffer, so we can spot the +\r\n sequence. + +For writing, however, when the buffer mode is NoBuffering, we use a +1-element Char buffer to force flushing of the buffer after each Char +is read. + +[note Buffer Flushing] + +** Flushing the Char buffer + +We must be able to flush the Char buffer, in order to implement +hSetEncoding, and things like hGetBuf which want to read raw bytes. + +Flushing the Char buffer on a write Handle is easy: just call +writeTextDevice to encode and write the date. + +Flushing the Char buffer on a read Handle involves rewinding the byte +buffer to the point representing the next Char in the Char buffer. +This is done by + + - remembering the state of the byte buffer *before* the last decode + + - re-decoding the bytes that represent the chars already read from the + Char buffer. This gives us the point in the byte buffer that + represents the *next* Char to be read. + +In order for this to work, after readTextHandle we must NOT MODIFY THE +CONTENTS OF THE BYTE OR CHAR BUFFERS, except to remove characters from +the Char buffer. + +** Flushing the byte buffer + +The byte buffer can be flushed if the Char buffer has already been +flushed (see above). For a read Handle, flushing the byte buffer +means seeking the device back by the number of bytes in the buffer, +and hence it is only possible on a seekable Handle. + +-} + +-- --------------------------------------------------------------------------- +-- Newline translation + +-- | The representation of a newline in the external file or stream. +data Newline = LF -- ^ "\n" + | CRLF -- ^ "\r\n" + deriving Eq + +-- | Specifies the translation, if any, of newline characters between +-- internal Strings and the external file or stream. Haskell Strings +-- are assumed to represent newlines with the '\n' character; the +-- newline mode specifies how to translate '\n' on output, and what to +-- translate into '\n' on input. +data NewlineMode + = NewlineMode { inputNL :: Newline, + -- ^ the representation of newlines on input + outputNL :: Newline + -- ^ the representation of newlines on output + } + deriving Eq + +-- | The native newline representation for the current platform +nativeNewline :: Newline +#ifdef mingw32_HOST_OS +nativeNewline = CRLF +#else +nativeNewline = LF +#endif + +-- | Map "\r\n" into "\n" on input, and "\n" to the native newline +-- represetnation on output. This mode can be used on any platform, and +-- works with text files using any newline convention. The downside is +-- that @readFile >>= writeFile@ might yield a different file. +-- +-- > universalNewlineMode = NewlineMode { inputNL = CRLF, +-- > outputNL = nativeNewline } +-- +universalNewlineMode :: NewlineMode +universalNewlineMode = NewlineMode { inputNL = CRLF, + outputNL = nativeNewline } + +-- | Use the native newline representation on both input and output +-- +-- > nativeNewlineMode = NewlineMode { inputNL = nativeNewline +-- > outputNL = nativeNewline } +-- +nativeNewlineMode :: NewlineMode +nativeNewlineMode = NewlineMode { inputNL = nativeNewline, + outputNL = nativeNewline } + +-- | Do no newline translation at all. +-- +-- > noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF } +-- +noNewlineTranslation :: NewlineMode +noNewlineTranslation = NewlineMode { inputNL = LF, outputNL = LF } + +-- --------------------------------------------------------------------------- +-- Show instance for Handles + +-- handle types are 'show'n when printing error msgs, so +-- we provide a more user-friendly Show instance for it +-- than the derived one. + +instance Show HandleType where + showsPrec _ t = + case t of + ClosedHandle -> showString "closed" + SemiClosedHandle -> showString "semi-closed" + ReadHandle -> showString "readable" + WriteHandle -> showString "writable" + AppendHandle -> showString "writable (append)" + ReadWriteHandle -> showString "read-writable" + +instance Show Handle where + showsPrec _ (FileHandle file _) = showHandle file + showsPrec _ (DuplexHandle file _ _) = showHandle file + +showHandle :: FilePath -> String -> String +showHandle file = showString "{handle: " . showString file . showString "}" diff --git a/libraries/base/GHC/IO/IOMode.hs b/libraries/base/GHC/IO/IOMode.hs new file mode 100644 index 0000000000..dbae0882c3 --- /dev/null +++ b/libraries/base/GHC/IO/IOMode.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.IOMode +-- Copyright : (c) The University of Glasgow, 1994-2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- The IOMode type +-- +----------------------------------------------------------------------------- + +module GHC.IO.IOMode (IOMode(..)) where + +import GHC.Base +import GHC.Show +import GHC.Read +import GHC.Arr +import GHC.Enum + +data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode + deriving (Eq, Ord, Ix, Enum, Read, Show) diff --git a/libraries/base/GHC/IOArray.hs b/libraries/base/GHC/IOArray.hs new file mode 100644 index 0000000000..5d41c40c28 --- /dev/null +++ b/libraries/base/GHC/IOArray.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IOArray +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IOArray type +-- +----------------------------------------------------------------------------- + +module GHC.IOArray ( + IOArray(..), + newIOArray, unsafeReadIOArray, unsafeWriteIOArray, + readIOArray, writeIOArray, + boundsIOArray + ) where + +import GHC.Base +import GHC.IO +import GHC.Arr + +-- --------------------------------------------------------------------------- +-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. +-- The type arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. +-- +-- + +newtype IOArray i e = IOArray (STArray RealWorld i e) + +-- explicit instance because Haddock can't figure out a derived one +instance Eq (IOArray i e) where + IOArray x == IOArray y = x == y + +-- |Build a new 'IOArray' +newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) +{-# INLINE newIOArray #-} +newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} + +-- | Read a value from an 'IOArray' +unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e +{-# INLINE unsafeReadIOArray #-} +unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) + +-- | Write a new value into an 'IOArray' +unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () +{-# INLINE unsafeWriteIOArray #-} +unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) + +-- | Read a value from an 'IOArray' +readIOArray :: Ix i => IOArray i e -> i -> IO e +readIOArray (IOArray marr) i = stToIO (readSTArray marr i) + +-- | Write a new value into an 'IOArray' +writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () +writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) + +{-# INLINE boundsIOArray #-} +boundsIOArray :: IOArray i e -> (i,i) +boundsIOArray (IOArray marr) = boundsSTArray marr diff --git a/libraries/base/GHC/IOBase.hs b/libraries/base/GHC/IOBase.hs new file mode 100644 index 0000000000..cbadc870fa --- /dev/null +++ b/libraries/base/GHC/IOBase.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IOBase +-- Copyright : (c) The University of Glasgow 1994-2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Backwards-compatibility interface +-- +----------------------------------------------------------------------------- + + +module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} ( + IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- 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, ioException, + IOError, IOException(..), IOErrorType(..), ioError, userError, + ExitCode(..), + throwIO, block, unblock, blocked, catchAny, catchException, + evaluate, + ErrorCall(..), AssertionFailed(..), assertError, untangle, + BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), + blockedOnDeadMVar, blockedIndefinitely + ) where + +import GHC.Exception +import GHC.IO +import GHC.IO.Handle.Types +import GHC.IO.IOMode +import GHC.IO.Exception +import GHC.IOArray +import GHC.IORef +import GHC.MVar +import Foreign.C.Types + +type FD = CInt diff --git a/libraries/base/GHC/IOBase.lhs b/libraries/base/GHC/IOBase.lhs deleted file mode 100644 index 0a19d80d1a..0000000000 --- a/libraries/base/GHC/IOBase.lhs +++ /dev/null @@ -1,1041 +0,0 @@ -\begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ --- | --- Module : GHC.IOBase --- Copyright : (c) The University of Glasgow 1994-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Definitions for the 'IO' monad and its friends. --- ------------------------------------------------------------------------------ - --- #hide -module GHC.IOBase( - IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, - unsafePerformIO, unsafeInterleaveIO, - unsafeDupablePerformIO, unsafeDupableInterleaveIO, - noDuplicate, - - -- To and from from ST - stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - - -- References - IORef(..), newIORef, readIORef, writeIORef, - IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, - unsafeWriteIOArray, boundsIOArray, - 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, ioException, - IOError, IOException(..), IOErrorType(..), ioError, userError, - ExitCode(..), - throwIO, block, unblock, blocked, catchAny, catchException, - evaluate, - ErrorCall(..), AssertionFailed(..), assertError, untangle, - BlockedOnDeadMVar(..), BlockedIndefinitely(..), Deadlock(..), - blockedOnDeadMVar, blockedIndefinitely - ) 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 -XNoImplicitPrelude -import Data.Maybe ( Maybe(..) ) -import GHC.Show -import GHC.List -import GHC.Read -import Foreign.C.Types (CInt) -import GHC.Exception - -#ifndef __HADDOCK__ -import {-# SOURCE #-} Data.Typeable ( Typeable ) -#endif - --- --------------------------------------------------------------------------- --- The IO Monad - -{- -The IO Monad is just an instance of the ST monad, where the state is -the real world. We use the exception mechanism (in GHC.Exception) to -implement IO exceptions. - -NOTE: The IO representation is deeply wired in to various parts of the -system. The following list may or may not be exhaustive: - -Compiler - types of various primitives in PrimOp.lhs - -RTS - forceIO (StgMiscClosures.hc) - - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast - (Exceptions.hc) - - raiseAsync (Schedule.c) - -Prelude - GHC.IOBase.lhs, and several other places including - GHC.Exception.lhs. - -Libraries - parts of hslibs/lang. - ---SDM --} - -{-| -A value of type @'IO' a@ is a computation which, when performed, -does some I\/O before returning a value of type @a@. - -There is really only one way to \"perform\" an I\/O action: bind it to -@Main.main@ in your program. When your program is run, the I\/O will -be performed. It isn't possible to perform I\/O from an arbitrary -function, unless that function is itself in the 'IO' monad and called -at some point, directly or indirectly, from @Main.main@. - -'IO' is a monad, so 'IO' actions can be combined using either the do-notation -or the '>>' and '>>=' operations from the 'Monad' class. --} -newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) - -unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) -unIO (IO a) = a - -instance Functor IO where - fmap f x = x >>= (return . f) - -instance Monad IO where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return x = returnIO x - - m >>= k = bindIO m k - fail s = failIO s - -failIO :: String -> IO a -failIO s = ioError (userError s) - -liftIO :: IO a -> State# RealWorld -> STret RealWorld a -liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r - -bindIO :: IO a -> (a -> IO b) -> IO b -bindIO (IO m) k = IO ( \ s -> - case m s of - (# new_s, a #) -> unIO (k a) new_s - ) - -thenIO :: IO a -> IO b -> IO b -thenIO (IO m) k = IO ( \ s -> - case m s of - (# new_s, _ #) -> unIO k new_s - ) - -returnIO :: a -> IO a -returnIO x = IO (\ s -> (# s, x #)) - --- --------------------------------------------------------------------------- --- Coercions between IO and ST - --- | A monad transformer embedding strict state transformers in the 'IO' --- monad. The 'RealWorld' parameter indicates that the internal state --- used by the 'ST' computation is a special one supplied by the 'IO' --- monad, and thus distinct from those used by invocations of 'runST'. -stToIO :: ST RealWorld a -> IO a -stToIO (ST m) = IO m - -ioToST :: IO a -> ST RealWorld a -ioToST (IO m) = (ST m) - --- This relies on IO and ST having the same representation modulo the --- constraint on the type of the state --- -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 - -{-| -This is the \"back door\" into the 'IO' monad, allowing -'IO' computation to be performed at any time. For -this to be safe, the 'IO' computation should be -free of side effects and independent of its environment. - -If the I\/O computation wrapped in 'unsafePerformIO' -performs side effects, then the relative order in which those side -effects take place (relative to the main I\/O trunk, or other calls to -'unsafePerformIO') is indeterminate. You have to be careful when -writing and compiling modules that use 'unsafePerformIO': - - * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ - that calls 'unsafePerformIO'. If the call is inlined, - the I\/O may be performed more than once. - - * Use the compiler flag @-fno-cse@ to prevent common sub-expression - elimination being performed on the module, which might combine - two side effects that were meant to be separate. A good example - is using multiple global variables (like @test@ in the example below). - - * Make sure that the either you switch off let-floating, or that the - call to 'unsafePerformIO' cannot float outside a lambda. For example, - if you say: - @ - f x = unsafePerformIO (newIORef []) - @ - you may get only one reference cell shared between all calls to @f@. - Better would be - @ - f x = unsafePerformIO (newIORef [x]) - @ - because now it can't float outside the lambda. - -It is less well known that -'unsafePerformIO' is not type safe. For example: - -> test :: IORef [a] -> test = unsafePerformIO $ newIORef [] -> -> main = do -> writeIORef test [42] -> bang <- readIORef test -> print (bang :: [Char]) - -This program will core dump. This problem with polymorphic references -is well known in the ML community, and does not arise with normal -monadic use of references. There is no easy way to make it impossible -once you use 'unsafePerformIO'. Indeed, it is -possible to write @coerce :: a -> b@ with the -help of 'unsafePerformIO'. So be careful! --} -unsafePerformIO :: IO a -> a -unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) - -{-| -This version of 'unsafePerformIO' is slightly more efficient, -because it omits the check that the IO is only being performed by a -single thread. Hence, when you write 'unsafeDupablePerformIO', -there is a possibility that the IO action may be performed multiple -times (on a multiprocessor), and you should therefore ensure that -it gives the same results each time. --} -{-# NOINLINE unsafeDupablePerformIO #-} -unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) - --- Why do we NOINLINE unsafeDupablePerformIO? See the comment with --- GHC.ST.runST. Essentially the issue is that the IO computation --- inside unsafePerformIO must be atomic: it must either all run, or --- 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 unsafeDupablePerformIO? --- If we don't have it, the demand analyser discovers the following strictness --- for unsafeDupablePerformIO: C(U(AV)) --- But then consider --- unsafeDupablePerformIO (\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 unsafeDupablePerformIO, --- 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 -when the value of the @a@ is demanded. This is used to implement lazy -file reading, see 'System.IO.hGetContents'. --} -{-# INLINE unsafeInterleaveIO #-} -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) - --- We believe that INLINE on unsafeInterleaveIO is safe, because the --- state from this IO thread is passed explicitly to the interleaved --- IO, so it cannot be floated out and shared. - -{-# INLINE unsafeDupableInterleaveIO #-} -unsafeDupableInterleaveIO :: IO a -> IO a -unsafeDupableInterleaveIO (IO m) - = IO ( \ s -> let - r = case m s of (# _, res #) -> res - in - (# s, r #)) - -{-| -Ensures that the suspensions under evaluation by the current thread -are unique; that is, the current thread is not evaluating anything -that is also under evaluation by another thread that has also executed -'noDuplicate'. - -This operation is used in the definition of 'unsafePerformIO' to -prevent the IO action from being executed multiple times, which is usually -undesirable. --} -noDuplicate :: IO () -noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) - --- --------------------------------------------------------------------------- --- Handle type - -data MVar a = MVar (MVar# RealWorld a) -{- ^ -An 'MVar' (pronounced \"em-var\") is a synchronising variable, used -for communication between concurrent threads. It can be thought of -as a a box, which may be empty or full. --} - --- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module -instance Eq (MVar a) where - (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# - --- A Handle is represented by (a reference to) a record --- containing the state of the I/O port/device. We record --- the following pieces of info: - --- * type (read,write,closed etc.) --- * the underlying file descriptor --- * buffering mode --- * buffer, and spare buffers --- * user-friendly name (usually the --- FilePath used when IO.openFile was called) - --- Note: when a Handle is garbage collected, we want to flush its buffer --- and close the OS file handle, so as to free up a (precious) resource. - --- | Haskell defines operations to read and write characters from and to files, --- represented by values of type @Handle@. Each value of this type is a --- /handle/: a record used by the Haskell run-time system to /manage/ I\/O --- with file system objects. A handle has at least the following properties: --- --- * whether it manages input or output or both; --- --- * whether it is /open/, /closed/ or /semi-closed/; --- --- * whether the object is seekable; --- --- * whether buffering is disabled, or enabled on a line or block basis; --- --- * a buffer (whose length may be zero). --- --- Most handles will also have a current I\/O position indicating where the next --- input or output operation will occur. A handle is /readable/ if it --- manages only input or both input and output; likewise, it is /writable/ if --- it manages only output or both input and output. A handle is /open/ when --- first allocated. --- Once it is closed it can no longer be used for either input or output, --- though an implementation cannot re-use its storage while references --- remain to it. Handles are in the 'Show' and 'Eq' classes. The string --- produced by showing a handle is system dependent; it should include --- enough information to identify the handle for debugging. A handle is --- equal according to '==' only to itself; no attempt --- is made to compare the internal state of different handles for equality. --- --- GHC note: a 'Handle' will be automatically closed when the garbage --- collector detects that it has become unreferenced by the program. --- However, relying on this behaviour is not generally recommended: --- the garbage collector is unpredictable. If possible, use explicit --- an explicit 'hClose' to close 'Handle's when they are no longer --- required. GHC does not currently attempt to free up file --- descriptors when they have run out, it is your responsibility to --- ensure that this doesn't happen. - -data Handle - = FileHandle -- A normal handle to a file - FilePath -- the file (invariant) - !(MVar Handle__) - - | DuplexHandle -- A handle to a read/write stream - FilePath -- file for a FIFO, otherwise some - -- descriptive string. - !(MVar Handle__) -- The read side - !(MVar Handle__) -- The write side - --- NOTES: --- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be --- seekable. - -instance Eq Handle where - (FileHandle _ h1) == (FileHandle _ h2) = h1 == h2 - (DuplexHandle _ h1 _) == (DuplexHandle _ h2 _) = h1 == h2 - _ == _ = False - -type FD = CInt - -data Handle__ - = Handle__ { - haFD :: !FD, -- file descriptor - haType :: HandleType, -- type (read/write/append etc.) - haIsBin :: Bool, -- binary mode? - haIsStream :: Bool, -- Windows : is this a socket? - -- Unix : is O_NONBLOCK set? - haBufferMode :: BufferMode, -- buffer contains read/write data? - haBuffer :: !(IORef Buffer), -- the current buffer - haBuffers :: !(IORef BufferList), -- spare buffers - haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a - -- duplex handle. - } - --- --------------------------------------------------------------------------- --- Buffers - --- The buffer is represented by a mutable variable containing a --- record, where the record contains the raw buffer and the start/end --- points of the filled portion. We use a mutable variable so that --- the common operation of writing (or reading) some data from (to) --- the buffer doesn't need to modify, and hence copy, the handle --- itself, it just updates the buffer. - --- There will be some allocation involved in a simple hPutChar in --- order to create the new Buffer structure (below), but this is --- relatively small, and this only has to be done once per write --- operation. - --- The buffer contains its size - we could also get the size by --- calling sizeOfMutableByteArray# on the raw buffer, but that tends --- to be rounded up to the nearest Word. - -type RawBuffer = MutableByteArray# RealWorld - --- INVARIANTS on a Buffer: --- --- * A handle *always* has a buffer, even if it is only 1 character long --- (an unbuffered handle needs a 1 character buffer in order to support --- hLookAhead and hIsEOF). --- * r <= w --- * if r == w, then r == 0 && w == 0 --- * if state == WriteBuffer, then r == 0 --- * a write buffer is never full. If an operation --- fills up the buffer, it will always flush it before --- returning. --- * a read buffer may be full as a result of hLookAhead. In normal --- operation, a read buffer always has at least one character of space. - -data Buffer - = Buffer { - bufBuf :: RawBuffer, - bufRPtr :: !Int, - bufWPtr :: !Int, - bufSize :: !Int, - bufState :: BufferState - } - -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) - --- we keep a few spare buffers around in a handle to avoid allocating --- a new one for each hPutStr. These buffers are *guaranteed* to be the --- same size as the main buffer. -data BufferList - = BufferListNil - | BufferListCons RawBuffer BufferList - - -bufferIsWritable :: Buffer -> Bool -bufferIsWritable Buffer{ bufState=WriteBuffer } = True -bufferIsWritable _other = False - -bufferEmpty :: Buffer -> Bool -bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w - --- only makes sense for a write buffer -bufferFull :: Buffer -> Bool -bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b - --- Internally, we classify handles as being one --- of the following: - -data HandleType - = ClosedHandle - | SemiClosedHandle - | ReadHandle - | WriteHandle - | AppendHandle - | ReadWriteHandle - -isReadableHandleType :: HandleType -> Bool -isReadableHandleType ReadHandle = True -isReadableHandleType ReadWriteHandle = True -isReadableHandleType _ = False - -isWritableHandleType :: HandleType -> Bool -isWritableHandleType AppendHandle = True -isWritableHandleType WriteHandle = True -isWritableHandleType ReadWriteHandle = True -isWritableHandleType _ = False - -isReadWriteHandleType :: HandleType -> Bool -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. - -type FilePath = String - --- --------------------------------------------------------------------------- --- Buffering modes - --- | Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. These modes have the following --- effects. For output, items are written out, or /flushed/, --- from the internal buffer according to the buffer mode: --- --- * /line-buffering/: the entire output buffer is flushed --- whenever a newline is output, the buffer overflows, --- a 'System.IO.hFlush' is issued, or the handle is closed. --- --- * /block-buffering/: the entire buffer is written out whenever it --- overflows, a 'System.IO.hFlush' is issued, or the handle is closed. --- --- * /no-buffering/: output is written immediately, and never stored --- in the buffer. --- --- An implementation is free to flush the buffer more frequently, --- but not less frequently, than specified above. --- The output buffer is emptied as soon as it has been written out. --- --- Similarly, input occurs according to the buffer mode for the handle: --- --- * /line-buffering/: when the buffer for the handle is not empty, --- the next item is obtained from the buffer; otherwise, when the --- buffer is empty, characters up to and including the next newline --- character are read into the buffer. No characters are available --- until the newline character is available or the buffer is full. --- --- * /block-buffering/: when the buffer for the handle becomes empty, --- the next block of data is read into the buffer. --- --- * /no-buffering/: the next input item is read and returned. --- The 'System.IO.hLookAhead' operation implies that even a no-buffered --- handle may require a one-character buffer. --- --- The default buffering mode when a handle is opened is --- implementation-dependent and may depend on the file system object --- which is attached to that handle. --- For most implementations, physical files will normally be block-buffered --- and terminals will normally be line-buffered. - -data BufferMode - = NoBuffering -- ^ buffering is disabled if possible. - | LineBuffering - -- ^ line-buffering should be enabled if possible. - | BlockBuffering (Maybe Int) - -- ^ block-buffering should be enabled if possible. - -- The size of the buffer is @n@ items if the argument - -- is 'Just' @n@ and is otherwise implementation-dependent. - deriving (Eq, Ord, Read, Show) - --- --------------------------------------------------------------------------- --- IORefs - --- |A mutable variable in the 'IO' monad -newtype IORef a = IORef (STRef RealWorld a) - --- explicit instance because Haddock can't figure out a derived one -instance Eq (IORef a) where - IORef x == IORef y = x == y - --- |Build a new 'IORef' -newIORef :: a -> IO (IORef a) -newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) - --- |Read the value of an 'IORef' -readIORef :: IORef a -> IO a -readIORef (IORef var) = stToIO (readSTRef var) - --- |Write a new value into an 'IORef' -writeIORef :: IORef a -> a -> IO () -writeIORef (IORef var) v = stToIO (writeSTRef var v) - --- --------------------------------------------------------------------------- --- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. --- The type arguments are as follows: --- --- * @i@: the index type of the array (should be an instance of 'Ix') --- --- * @e@: the element type of the array. --- --- - -newtype IOArray i e = IOArray (STArray RealWorld i e) - --- explicit instance because Haddock can't figure out a derived one -instance Eq (IOArray i e) where - IOArray x == IOArray y = x == y - --- |Build a new 'IOArray' -newIOArray :: Ix i => (i,i) -> e -> IO (IOArray i e) -{-# INLINE newIOArray #-} -newIOArray lu initial = stToIO $ do {marr <- newSTArray lu initial; return (IOArray marr)} - --- | Read a value from an 'IOArray' -unsafeReadIOArray :: Ix i => IOArray i e -> Int -> IO e -{-# INLINE unsafeReadIOArray #-} -unsafeReadIOArray (IOArray marr) i = stToIO (unsafeReadSTArray marr i) - --- | Write a new value into an 'IOArray' -unsafeWriteIOArray :: Ix i => IOArray i e -> Int -> e -> IO () -{-# INLINE unsafeWriteIOArray #-} -unsafeWriteIOArray (IOArray marr) i e = stToIO (unsafeWriteSTArray marr i e) - --- | Read a value from an 'IOArray' -readIOArray :: Ix i => IOArray i e -> i -> IO e -readIOArray (IOArray marr) i = stToIO (readSTArray marr i) - --- | Write a new value into an 'IOArray' -writeIOArray :: Ix i => IOArray i e -> i -> e -> IO () -writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) - -{-# INLINE boundsIOArray #-} -boundsIOArray :: IOArray i e -> (i,i) -boundsIOArray (IOArray marr) = boundsSTArray marr - --- --------------------------------------------------------------------------- --- Show instance for Handles - --- handle types are 'show'n when printing error msgs, so --- we provide a more user-friendly Show instance for it --- than the derived one. - -instance Show HandleType where - showsPrec _ t = - case t of - ClosedHandle -> showString "closed" - SemiClosedHandle -> showString "semi-closed" - ReadHandle -> showString "readable" - WriteHandle -> showString "writable" - AppendHandle -> showString "writable (append)" - ReadWriteHandle -> showString "read-writable" - -instance Show Handle where - showsPrec _ (FileHandle file _) = showHandle file - showsPrec _ (DuplexHandle file _ _) = showHandle file - -showHandle :: FilePath -> String -> String -showHandle file = showString "{handle: " . showString file . showString "}" - --- ------------------------------------------------------------------------ --- Exception datatypes and operations - --- |The thread is blocked on an @MVar@, but there are no other references --- to the @MVar@ so it can't ever continue. -data BlockedOnDeadMVar = BlockedOnDeadMVar - deriving Typeable - -instance Exception BlockedOnDeadMVar - -instance Show BlockedOnDeadMVar where - showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely" - -blockedOnDeadMVar :: SomeException -- for the RTS -blockedOnDeadMVar = toException BlockedOnDeadMVar - ------ - --- |The thread is awiting to retry an STM transaction, but there are no --- other references to any @TVar@s involved, so it can't ever continue. -data BlockedIndefinitely = BlockedIndefinitely - deriving Typeable - -instance Exception BlockedIndefinitely - -instance Show BlockedIndefinitely where - showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely" - -blockedIndefinitely :: SomeException -- for the RTS -blockedIndefinitely = toException BlockedIndefinitely - ------ - --- |There are no runnable threads, so the program is deadlocked. --- The @Deadlock@ exception is raised in the main thread only. -data Deadlock = Deadlock - deriving Typeable - -instance Exception Deadlock - -instance Show Deadlock where - showsPrec _ Deadlock = showString "<<deadlock>>" - ------ - --- |Exceptions generated by 'assert'. The @String@ gives information --- about the source location of the assertion. -data AssertionFailed = AssertionFailed String - deriving Typeable - -instance Exception AssertionFailed - -instance Show AssertionFailed where - showsPrec _ (AssertionFailed err) = showString err - ------ - --- |Asynchronous exceptions. -data AsyncException - = StackOverflow - -- ^The current thread\'s stack exceeded its limit. - -- Since an exception has been raised, the thread\'s stack - -- will certainly be below its limit again, but the - -- programmer should take remedial action - -- immediately. - | HeapOverflow - -- ^The program\'s heap is reaching its limit, and - -- the program should take action to reduce the amount of - -- live data it has. Notes: - -- - -- * It is undefined which thread receives this exception. - -- - -- * GHC currently does not throw 'HeapOverflow' exceptions. - | ThreadKilled - -- ^This exception is raised by another thread - -- calling 'Control.Concurrent.killThread', or by the system - -- if it needs to terminate the thread for some - -- reason. - | UserInterrupt - -- ^This exception is raised by default in the main thread of - -- the program when the user requests to terminate the program - -- via the usual mechanism(s) (e.g. Control-C in the console). - deriving (Eq, Ord, Typeable) - -instance Exception AsyncException - --- | Exceptions generated by array operations -data ArrayException - = IndexOutOfBounds String - -- ^An attempt was made to index an array outside - -- its declared bounds. - | UndefinedElement String - -- ^An attempt was made to evaluate an element of an - -- array that had not been initialized. - deriving (Eq, Ord, Typeable) - -instance Exception ArrayException - -stackOverflow, heapOverflow :: SomeException -- for the RTS -stackOverflow = toException StackOverflow -heapOverflow = toException HeapOverflow - -instance Show AsyncException where - showsPrec _ StackOverflow = showString "stack overflow" - showsPrec _ HeapOverflow = showString "heap overflow" - showsPrec _ ThreadKilled = showString "thread killed" - showsPrec _ UserInterrupt = showString "user interrupt" - -instance Show ArrayException where - showsPrec _ (IndexOutOfBounds s) - = showString "array index out of range" - . (if not (null s) then showString ": " . showString s - else id) - showsPrec _ (UndefinedElement s) - = showString "undefined array element" - . (if not (null s) then showString ": " . showString s - else id) - --- ----------------------------------------------------------------------------- --- The ExitCode type - --- We need it here because it is used in ExitException in the --- Exception datatype (above). - -data ExitCode - = ExitSuccess -- ^ indicates successful termination; - | ExitFailure Int - -- ^ indicates program failure with an exit code. - -- The exact interpretation of the code is - -- operating-system dependent. In particular, some values - -- may be prohibited (e.g. 0 on a POSIX-compliant system). - deriving (Eq, Ord, Read, Show, Typeable) - -instance Exception ExitCode - -ioException :: IOException -> IO a -ioException err = throwIO err - --- | Raise an 'IOError' in the 'IO' monad. -ioError :: IOError -> IO a -ioError = ioException - --- --------------------------------------------------------------------------- --- IOError type - --- | The Haskell 98 type for exceptions in the 'IO' monad. --- Any I\/O operation may raise an 'IOError' instead of returning a result. --- For a more general type of exception, including also those that arise --- in pure code, see 'Control.Exception.Exception'. --- --- In Haskell 98, this is an opaque type. -type IOError = IOException - --- |Exceptions that occur in the @IO@ monad. --- An @IOException@ records a more specific error type, a descriptive --- string and maybe the handle that was used when the error was --- flagged. -data IOException - = IOError { - ioe_handle :: Maybe Handle, -- the handle used by the action flagging - -- the error. - ioe_type :: IOErrorType, -- what it was. - ioe_location :: String, -- location. - ioe_description :: String, -- error type specific information. - ioe_errno :: Maybe CInt, -- errno leading to this error, if any. - ioe_filename :: Maybe FilePath -- filename the error is related to. - } - deriving Typeable - -instance Exception IOException - -instance Eq IOException where - (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) = - e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2 - --- | An abstract type that contains a value for each variant of 'IOError'. -data IOErrorType - -- Haskell 98: - = AlreadyExists - | NoSuchThing - | ResourceBusy - | ResourceExhausted - | EOF - | IllegalOperation - | PermissionDenied - | UserError - -- GHC only: - | UnsatisfiedConstraints - | SystemError - | ProtocolError - | OtherError - | InvalidArgument - | InappropriateType - | HardwareFault - | UnsupportedOperation - | TimeExpired - | ResourceVanished - | Interrupted - -instance Eq IOErrorType where - x == y = getTag x ==# getTag y - -instance Show IOErrorType where - showsPrec _ e = - showString $ - case e of - AlreadyExists -> "already exists" - NoSuchThing -> "does not exist" - ResourceBusy -> "resource busy" - ResourceExhausted -> "resource exhausted" - EOF -> "end of file" - IllegalOperation -> "illegal operation" - PermissionDenied -> "permission denied" - UserError -> "user error" - HardwareFault -> "hardware fault" - InappropriateType -> "inappropriate type" - Interrupted -> "interrupted" - InvalidArgument -> "invalid argument" - OtherError -> "failed" - ProtocolError -> "protocol error" - ResourceVanished -> "resource vanished" - SystemError -> "system error" - TimeExpired -> "timeout" - UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! - UnsupportedOperation -> "unsupported operation" - --- | Construct an 'IOError' value with a string describing the error. --- The 'fail' method of the 'IO' instance of the 'Monad' class raises a --- 'userError', thus: --- --- > instance Monad IO where --- > ... --- > fail s = ioError (userError s) --- -userError :: String -> IOError -userError str = IOError Nothing UserError "" str Nothing Nothing - --- --------------------------------------------------------------------------- --- Showing IOErrors - -instance Show IOException where - showsPrec p (IOError hdl iot loc s _ fn) = - (case fn of - Nothing -> case hdl of - Nothing -> id - Just h -> showsPrec p h . showString ": " - Just name -> showString name . showString ": ") . - (case loc of - "" -> id - _ -> showString loc . showString ": ") . - showsPrec p iot . - (case s of - "" -> id - _ -> showString " (" . showString s . showString ")") - --- ----------------------------------------------------------------------------- --- IOMode type - -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) -\end{code} - -%********************************************************* -%* * -\subsection{Primitive catch and throwIO} -%* * -%********************************************************* - -catchException used to handle the passing around of the state to the -action and the handler. This turned out to be a bad idea - it meant -that we had to wrap both arguments in thunks so they could be entered -as normal (remember IO returns an unboxed pair...). - -Now catch# has type - - catch# :: IO a -> (b -> IO a) -> IO a - -(well almost; the compiler doesn't know about the IO newtype so we -have to work around that in the definition of catchException below). - -\begin{code} -catchException :: Exception e => IO a -> (e -> IO a) -> IO a -catchException (IO io) handler = IO $ catch# io handler' - where handler' e = case fromException e of - Just e' -> unIO (handler e') - Nothing -> raise# e - -catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a -catchAny (IO io) handler = IO $ catch# io handler' - where handler' (SomeException e) = unIO (handler e) - --- | A variant of 'throw' that can only be used within the 'IO' monad. --- --- Although 'throwIO' has a type that is an instance of the type of 'throw', the --- two functions are subtly different: --- --- > 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 --- an exception to be raised when it is used within the 'IO' monad. --- The 'throwIO' variant should be used in preference to 'throw' to --- raise an exception within the 'IO' monad because it guarantees --- ordering with respect to other 'IO' operations, whereas 'throw' --- does not. -throwIO :: Exception e => e -> IO a -throwIO e = IO (raiseIO# (toException e)) -\end{code} - - -%********************************************************* -%* * -\subsection{Controlling asynchronous exception delivery} -%* * -%********************************************************* - -\begin{code} --- | Applying 'block' to a computation will --- execute that computation with asynchronous exceptions --- /blocked/. That is, any thread which --- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be --- blocked until asynchronous exceptions are enabled again. There\'s --- no need to worry about re-enabling asynchronous exceptions; that is --- done automatically on exiting the scope of --- 'block'. --- --- Threads created by 'Control.Concurrent.forkIO' inherit the blocked --- state from the parent; that is, to start a thread in blocked mode, --- use @block $ forkIO ...@. This is particularly useful if you need to --- establish an exception handler in the forked thread before any --- asynchronous exceptions are received. -block :: IO a -> IO a - --- | To re-enable asynchronous exceptions inside the scope of --- 'block', 'unblock' can be --- used. It scopes in exactly the same way, so on exit from --- 'unblock' asynchronous exception delivery will --- be disabled again. -unblock :: IO a -> IO a - -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io - --- | returns True if asynchronous exceptions are blocked in the --- current thread. -blocked :: IO Bool -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) -\end{code} - -\begin{code} --- | Forces its argument to be evaluated to weak head normal form when --- the resultant 'IO' action is executed. It can be used to order --- evaluation with respect to other 'IO' operations; its semantics are --- given by --- --- > evaluate x `seq` y ==> y --- > evaluate x `catch` f ==> (return $! x) `catch` f --- > evaluate x >>= f ==> (return $! x) >>= f --- --- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the --- same as @(return $! x)@. A correct definition is --- --- > evaluate x = (return $! x) >>= return --- -evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument -\end{code} - -\begin{code} -assertError :: Addr# -> Bool -> a -> a -assertError str predicate v - | predicate = v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) - -{- -(untangle coded message) expects "coded" to be of the form - "location|details" -It prints - location message details --} -untangle :: Addr# -> String -> String -untangle coded message - = location - ++ ": " - ++ message - ++ details - ++ "\n" - where - coded_str = unpackCStringUtf8# coded - - (location, details) - = case (span not_bar coded_str) of { (loc, rest) -> - case rest of - ('|':det) -> (loc, ' ' : det) - _ -> (loc, "") - } - not_bar c = c /= '|' -\end{code} - diff --git a/libraries/base/GHC/IORef.hs b/libraries/base/GHC/IORef.hs new file mode 100644 index 0000000000..4ac336ed70 --- /dev/null +++ b/libraries/base/GHC/IORef.hs @@ -0,0 +1,49 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IORef +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The IORef type +-- +----------------------------------------------------------------------------- +module GHC.IORef ( + IORef(..), + newIORef, readIORef, writeIORef, atomicModifyIORef + ) where + +import GHC.Base +import GHC.STRef +import GHC.IO + +-- --------------------------------------------------------------------------- +-- IORefs + +-- |A mutable variable in the 'IO' monad +newtype IORef a = IORef (STRef RealWorld a) + +-- explicit instance because Haddock can't figure out a derived one +instance Eq (IORef a) where + IORef x == IORef y = x == y + +-- |Build a new 'IORef' +newIORef :: a -> IO (IORef a) +newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) + +-- |Read the value of an 'IORef' +readIORef :: IORef a -> IO a +readIORef (IORef var) = stToIO (readSTRef var) + +-- |Write a new value into an 'IORef' +writeIORef :: IORef a -> a -> IO () +writeIORef (IORef var) v = stToIO (writeSTRef var v) + +atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef (IORef (STRef r#)) f = IO $ \s -> atomicModifyMutVar# r# f s + diff --git a/libraries/base/GHC/MVar.hs b/libraries/base/GHC/MVar.hs new file mode 100644 index 0000000000..98ecd45370 --- /dev/null +++ b/libraries/base/GHC/MVar.hs @@ -0,0 +1,143 @@ +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.MVar +-- Copyright : (c) The University of Glasgow 2008 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- The MVar type +-- +----------------------------------------------------------------------------- + +module GHC.MVar ( + -- * MVars + MVar(..) + , newMVar -- :: a -> IO (MVar a) + , newEmptyMVar -- :: IO (MVar a) + , takeMVar -- :: MVar a -> IO a + , putMVar -- :: MVar a -> a -> IO () + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool + , isEmptyMVar -- :: MVar a -> IO Bool + , addMVarFinalizer -- :: MVar a -> IO () -> IO () + + ) where + +import GHC.Base +import GHC.IO +import Data.Maybe + +data MVar a = MVar (MVar# RealWorld a) +{- ^ +An 'MVar' (pronounced \"em-var\") is a synchronising variable, used +for communication between concurrent threads. It can be thought of +as a a box, which may be empty or full. +-} + +-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module +instance Eq (MVar a) where + (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# + +{- +M-Vars are rendezvous points for concurrent threads. They begin +empty, and any attempt to read an empty M-Var blocks. When an M-Var +is written, a single blocked thread may be freed. Reading an M-Var +toggles its state from full back to empty. Therefore, any value +written to an M-Var may only be read once. Multiple reads and writes +are allowed, but there must be at least one read between any two +writes. +-} + +--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) + +-- |Create an 'MVar' which is initially empty. +newEmptyMVar :: IO (MVar a) +newEmptyMVar = IO $ \ s# -> + case newMVar# s# of + (# s2#, svar# #) -> (# s2#, MVar svar# #) + +-- |Create an 'MVar' which contains the supplied value. +newMVar :: a -> IO (MVar a) +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +-- |Return the contents of the 'MVar'. If the 'MVar' is currently +-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', +-- the 'MVar' is left empty. +-- +-- There are two further important properties of 'takeMVar': +-- +-- * 'takeMVar' is single-wakeup. That is, if there are multiple +-- threads blocked in 'takeMVar', and the 'MVar' becomes full, +-- only one thread will be woken up. The runtime guarantees that +-- the woken thread completes its 'takeMVar' operation. +-- +-- * When multiple threads are blocked on an 'MVar', they are +-- woken up in FIFO order. This is useful for providing +-- fairness properties of abstractions built using 'MVar's. +-- +takeMVar :: MVar a -> IO a +takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# + +-- |Put a value into an 'MVar'. If the 'MVar' is currently full, +-- 'putMVar' will wait until it becomes empty. +-- +-- There are two further important properties of 'putMVar': +-- +-- * 'putMVar' is single-wakeup. That is, if there are multiple +-- threads blocked in 'putMVar', and the 'MVar' becomes empty, +-- only one thread will be woken up. The runtime guarantees that +-- the woken thread completes its 'putMVar' operation. +-- +-- * When multiple threads are blocked on an 'MVar', they are +-- woken up in FIFO order. This is useful for providing +-- fairness properties of abstractions built using 'MVar's. +-- +putMVar :: MVar a -> a -> IO () +putMVar (MVar mvar#) x = IO $ \ s# -> + case putMVar# mvar# x s# of + s2# -> (# s2#, () #) + +-- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function +-- returns immediately, with 'Nothing' if the 'MVar' was empty, or +-- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', +-- the 'MVar' is left empty. +tryTakeMVar :: MVar a -> IO (Maybe a) +tryTakeMVar (MVar m) = IO $ \ s -> + case tryTakeMVar# m s of + (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty + (# s', _, a #) -> (# s', Just a #) -- MVar is full + +-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function +-- attempts to put the value @a@ into the 'MVar', returning 'True' if +-- it was successful, or 'False' otherwise. +tryPutMVar :: MVar a -> a -> IO Bool +tryPutMVar (MVar mvar#) x = IO $ \ s# -> + case tryPutMVar# mvar# x s# of + (# s, 0# #) -> (# s, False #) + (# s, _ #) -> (# s, True #) + +-- |Check whether a given 'MVar' is empty. +-- +-- Notice that the boolean value returned is just a snapshot of +-- the state of the MVar. By the time you get to react on its result, +-- the MVar may have been filled (or emptied) - so be extremely +-- careful when using this operation. Use 'tryTakeMVar' instead if possible. +isEmptyMVar :: MVar a -> IO Bool +isEmptyMVar (MVar mv#) = IO $ \ s# -> + case isEmptyMVar# mv# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) + +-- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and +-- "System.Mem.Weak" for more about finalizers. +addMVarFinalizer :: MVar a -> IO () -> IO () +addMVarFinalizer (MVar m) finalizer = + IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } + diff --git a/libraries/base/GHC/Stable.lhs b/libraries/base/GHC/Stable.lhs index 2086a3b3c0..29db0bb002 100644 --- a/libraries/base/GHC/Stable.lhs +++ b/libraries/base/GHC/Stable.lhs @@ -27,7 +27,7 @@ module GHC.Stable import GHC.Ptr import GHC.Base -import GHC.IOBase +import GHC.IO ----------------------------------------------------------------------------- -- Stable Pointers diff --git a/libraries/base/GHC/Storable.lhs b/libraries/base/GHC/Storable.lhs index 4b5c90da24..5aecb5e024 100644 --- a/libraries/base/GHC/Storable.lhs +++ b/libraries/base/GHC/Storable.lhs @@ -55,7 +55,7 @@ import GHC.Stable ( StablePtr(..) ) import GHC.Int import GHC.Word import GHC.Ptr -import GHC.IOBase +import GHC.IO import GHC.Base \end{code} diff --git a/libraries/base/GHC/TopHandler.lhs b/libraries/base/GHC/TopHandler.lhs index c61de0daef..ffc62f996e 100644 --- a/libraries/base/GHC/TopHandler.lhs +++ b/libraries/base/GHC/TopHandler.lhs @@ -36,8 +36,11 @@ import GHC.Base import GHC.Conc hiding (throwTo) import GHC.Num import GHC.Real -import GHC.Handle -import GHC.IOBase +import GHC.MVar +import GHC.IO +import GHC.IO.Handle.FD +import GHC.IO.Handle +import GHC.IO.Exception import GHC.Weak import Data.Typeable #if defined(mingw32_HOST_OS) diff --git a/libraries/base/GHC/Weak.lhs b/libraries/base/GHC/Weak.lhs index 2d9163e37f..860872774d 100644 --- a/libraries/base/GHC/Weak.lhs +++ b/libraries/base/GHC/Weak.lhs @@ -20,7 +20,7 @@ module GHC.Weak where import GHC.Base import Data.Maybe -import GHC.IOBase ( IO(..), unIO ) +import GHC.IO ( IO(..), unIO ) import Data.Typeable {-| diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index 61bd27eb8b..bb83068e30 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -155,7 +155,8 @@ import Data.Tuple #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception import Text.Read import GHC.Enum import GHC.Num diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs index c734158e0f..4f0ab96779 100644 --- a/libraries/base/System/Environment.hs +++ b/libraries/base/System/Environment.hs @@ -34,7 +34,8 @@ import Foreign import Foreign.C import Control.Exception.Base ( bracket ) import Control.Monad -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception #endif #ifdef __HUGS__ diff --git a/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs index 1e74c1acb3..a344f7a0e6 100644 --- a/libraries/base/System/Exit.hs +++ b/libraries/base/System/Exit.hs @@ -23,7 +23,8 @@ module System.Exit import Prelude #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception #endif #ifdef __HUGS__ diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index 0142d10868..f6d1b75b1f 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -175,9 +175,12 @@ import System.Posix.Internals #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase -- Together these four Prelude modules define -import GHC.Handle -- all the stuff exported by IO for the GHC version -import GHC.IO +import GHC.IO hiding ( onException ) +import GHC.IO.IOMode +import GHC.IO.Handle.FD +import GHC.IO.Handle +import GHC.IORef +import GHC.IO.Exception ( userError ) import GHC.Exception import GHC.Num import Text.Read diff --git a/libraries/base/System/IO/Error.hs b/libraries/base/System/IO/Error.hs index 2b9eb7ce87..6dcf24dfc2 100644 --- a/libraries/base/System/IO/Error.hs +++ b/libraries/base/System/IO/Error.hs @@ -93,7 +93,9 @@ import Data.Maybe #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IOBase +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Handle.Types import Text.Show #endif diff --git a/libraries/base/System/IO/Unsafe.hs b/libraries/base/System/IO/Unsafe.hs index 431df46a79..3a3e7f60bc 100644 --- a/libraries/base/System/IO/Unsafe.hs +++ b/libraries/base/System/IO/Unsafe.hs @@ -20,7 +20,7 @@ module System.IO.Unsafe ( ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase (unsafePerformIO, unsafeInterleaveIO) +import GHC.IO (unsafePerformIO, unsafeInterleaveIO) #endif #ifdef __HUGS__ diff --git a/libraries/base/System/Mem/StableName.hs b/libraries/base/System/Mem/StableName.hs index a2f939797b..beeb51490c 100644 --- a/libraries/base/System/Mem/StableName.hs +++ b/libraries/base/System/Mem/StableName.hs @@ -38,7 +38,7 @@ import Hugs.Stable #endif #ifdef __GLASGOW_HASKELL__ -import GHC.IOBase ( IO(..) ) +import GHC.IO ( IO(..) ) import GHC.Base ( Int(..), StableName#, makeStableName# , eqStableName#, stableNameToInt# ) diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs index fbac648e78..c4bb446841 100644 --- a/libraries/base/System/Posix/Internals.hs +++ b/libraries/base/System/Posix/Internals.hs @@ -48,7 +48,10 @@ import System.IO.Error import GHC.Base import GHC.Num import GHC.Real -import GHC.IOBase +import GHC.IO +import GHC.IO.IOMode +import GHC.IO.Exception +import GHC.IO.Device #elif __HUGS__ import Hugs.Prelude (IOException(..), IOErrorType(..)) import Hugs.IO (IOMode(..)) @@ -80,9 +83,7 @@ type CTms = () type CUtimbuf = () type CUtsname = () -#ifndef __GLASGOW_HASKELL__ type FD = CInt -#endif -- --------------------------------------------------------------------------- -- stat()-related stuff @@ -99,10 +100,7 @@ fdFileSize fd = c_size <- st_size p_stat return (fromIntegral c_size) -data FDType = Directory | Stream | RegularFile | RawDevice - deriving (Eq) - -fileType :: FilePath -> IO FDType +fileType :: FilePath -> IO IODeviceType fileType file = allocaBytes sizeof_stat $ \ p_stat -> do withCString file $ \p_file -> do @@ -112,7 +110,7 @@ fileType file = -- NOTE: On Win32 platforms, this will only work with file descriptors -- referring to file handles. i.e., it'll fail for socket FDs. -fdStat :: FD -> IO (FDType, CDev, CIno) +fdStat :: FD -> IO (IODeviceType, CDev, CIno) fdStat fd = allocaBytes sizeof_stat $ \ p_stat -> do throwErrnoIfMinus1Retry "fdType" $ @@ -122,10 +120,10 @@ fdStat fd = ino <- st_ino p_stat return (ty,dev,ino) -fdType :: FD -> IO FDType +fdType :: FD -> IO IODeviceType fdType fd = do (ty,_,_) <- fdStat fd; return ty -statGetType :: Ptr CStat -> IO FDType +statGetType :: Ptr CStat -> IO IODeviceType statGetType p_stat = do c_mode <- st_mode p_stat :: IO CMode case () of @@ -149,16 +147,6 @@ ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType" ioe_unknownfiletype = UserError "fdType" "unknown file type" #endif -#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__)) -closeFd :: Bool -> CInt -> IO CInt -closeFd isStream fd - | isStream = c_closesocket fd - | otherwise = c_close fd - -foreign import stdcall unsafe "HsBase.h closesocket" - c_closesocket :: CInt -> IO CInt -#endif - fdGetMode :: FD -> IO IOMode #if defined(mingw32_HOST_OS) || defined(__MINGW32__) fdGetMode _ = do @@ -186,9 +174,6 @@ fdGetMode fd = do -- --------------------------------------------------------------------------- -- Terminal-related stuff -fdIsTTY :: FD -> IO Bool -fdIsTTY fd = c_isatty fd >>= return.toBool - #if defined(HTYPE_TCFLAG_T) setEcho :: FD -> Bool -> IO () @@ -551,3 +536,8 @@ foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> #else s_issock _ = False #endif + +foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int +foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt +foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt +foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 4545976ea6..1ee6f30209 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -41,9 +41,30 @@ Library { GHC.Exts, GHC.Float, GHC.ForeignPtr, - GHC.Handle, + GHC.MVar, GHC.IO, + GHC.IO.IOMode, + GHC.IO.Buffer, + GHC.IO.Device, + GHC.IO.BufferedIO, + GHC.IO.FD, + GHC.IO.Exception, + GHC.IO.Encoding, + GHC.IO.Encoding.Latin1, + GHC.IO.Encoding.UTF8, + GHC.IO.Encoding.UTF16, + GHC.IO.Encoding.UTF32, + GHC.IO.Encoding.Types, + GHC.IO.Encoding.Iconv, + GHC.IO.Handle, + GHC.IO.Handle.Types, + GHC.IO.Handle.Internals, + GHC.IO.Handle.FD, + GHC.IO.Handle.Text, GHC.IOBase, + GHC.Handle, + GHC.IORef, + GHC.IOArray, GHC.Int, GHC.List, GHC.Num, diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h index c8de4546b8..d2c26daf7d 100644 --- a/libraries/base/include/HsBase.h +++ b/libraries/base/include/HsBase.h @@ -268,16 +268,6 @@ INLINE void * __hscore_memcpy_src_off( char *dst, char *src, int src_off, size_t sz ) { return memcpy(dst, src+src_off, sz); } -INLINE HsBool -__hscore_supportsTextMode() -{ -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) - return HS_BOOL_FALSE; -#else - return HS_BOOL_TRUE; -#endif -} - INLINE HsInt __hscore_bufsiz() { |