-- #not-home
module GHC.Conc
- ( ThreadId(..)
+ ( ThreadId(..)
- -- * Forking and suchlike
- , forkIO -- :: IO a -> IO ThreadId
- , forkOnIO -- :: Int -> IO a -> IO ThreadId
+ -- * Forking and suchlike
+ , forkIO -- :: IO a -> IO ThreadId
+ , forkOnIO -- :: Int -> IO a -> IO ThreadId
, numCapabilities -- :: Int
- , childHandler -- :: Exception -> IO ()
- , myThreadId -- :: IO ThreadId
- , killThread -- :: ThreadId -> IO ()
- , throwTo -- :: ThreadId -> Exception -> IO ()
- , par -- :: a -> b -> b
- , pseq -- :: a -> b -> b
- , yield -- :: IO ()
- , labelThread -- :: ThreadId -> String -> IO ()
-
- -- * Waiting
- , threadDelay -- :: Int -> IO ()
- , registerDelay -- :: Int -> IO (TVar Bool)
- , 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
- , retry -- :: STM a
- , orElse -- :: STM a -> STM a -> STM a
+ , childHandler -- :: Exception -> IO ()
+ , myThreadId -- :: IO ThreadId
+ , killThread -- :: ThreadId -> IO ()
+ , throwTo -- :: ThreadId -> Exception -> IO ()
+ , par -- :: a -> b -> b
+ , pseq -- :: a -> b -> b
+ , yield -- :: IO ()
+ , labelThread -- :: ThreadId -> String -> IO ()
+
+ -- * Waiting
+ , threadDelay -- :: Int -> IO ()
+ , registerDelay -- :: Int -> IO (TVar Bool)
+ , 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
+ , retry -- :: STM a
+ , orElse -- :: STM a -> STM a -> STM a
, catchSTM -- :: STM a -> (Exception -> STM a) -> STM a
- , alwaysSucceeds -- :: STM a -> STM ()
- , always -- :: STM Bool -> STM ()
- , TVar(..)
- , newTVar -- :: a -> STM (TVar a)
- , newTVarIO -- :: a -> STM (TVar a)
- , readTVar -- :: TVar a -> STM a
- , writeTVar -- :: a -> TVar a -> STM ()
- , unsafeIOToSTM -- :: IO a -> STM a
-
- -- * Miscellaneous
+ , alwaysSucceeds -- :: STM a -> STM ()
+ , always -- :: STM Bool -> STM ()
+ , TVar(..)
+ , newTVar -- :: a -> STM (TVar a)
+ , newTVarIO -- :: a -> STM (TVar a)
+ , readTVar -- :: TVar a -> STM a
+ , writeTVar -- :: a -> TVar a -> STM ()
+ , unsafeIOToSTM -- :: IO a -> STM a
+
+ -- * Miscellaneous
#ifdef mingw32_HOST_OS
- , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
- , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
- , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
+ , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
+ , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
+ , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
- , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
- , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
+ , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
+ , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
#endif
#ifndef mingw32_HOST_OS
, signalHandlerLock
#endif
- , ensureIOManagerIsRunning
+ , ensureIOManagerIsRunning
#ifdef mingw32_HOST_OS
, ConsoleEvent(..)
import GHC.Base
import GHC.IOBase
-import GHC.Num ( Num(..) )
-import GHC.Real ( fromIntegral, div )
+import GHC.Num ( Num(..) )
+import GHC.Real ( fromIntegral, div )
#ifndef mingw32_HOST_OS
-import GHC.Base ( Int(..) )
+import GHC.Base ( Int(..) )
#endif
#ifdef mingw32_HOST_OS
import GHC.Read ( Read )
import GHC.Enum ( Enum )
#endif
import GHC.Exception
-import GHC.Pack ( packCString# )
+import GHC.Pack ( packCString# )
import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
import GHC.STRef
-import GHC.Show ( Show(..), showString )
+import GHC.Show ( Show(..), showString )
import Data.Typeable
infixr 0 `par`, `pseq`
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{@ThreadId@, @par@, and @fork@}
-%* *
+%* *
%************************************************************************
\begin{code}
instance Show ThreadId where
showsPrec d t =
- showString "ThreadId " .
+ showString "ThreadId " .
showsPrec d (getThreadId (id2TSO t))
foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt
real_handler :: Exception -> IO ()
real_handler ex =
case ex of
- -- ignore thread GC and killThread exceptions:
- BlockedOnDeadMVar -> return ()
- BlockedIndefinitely -> return ()
- AsyncException ThreadKilled -> return ()
+ -- ignore thread GC and killThread exceptions:
+ BlockedOnDeadMVar -> return ()
+ BlockedIndefinitely -> return ()
+ AsyncException ThreadKilled -> return ()
- -- report all others:
- AsyncException StackOverflow -> reportStackOverflow
- other -> reportError other
+ -- report all others:
+ AsyncException StackOverflow -> reportStackOverflow
+ other -> reportError other
{- | 'killThread' terminates the given thread (GHC only).
Any work already done by the thread isn\'t
adr = byteArrayContents# ps in
case (labelThread# t adr s) of s1 -> (# s1, () #)
--- Nota Bene: 'pseq' used to be 'seq'
--- but 'seq' is now defined in PrelGHC
+-- Nota Bene: 'pseq' used to be 'seq'
+-- but 'seq' is now defined in PrelGHC
--
-- "pseq" is defined a bit weirdly (see below)
--
%************************************************************************
-%* *
+%* *
\subsection[stm]{Transactional heap operations}
-%* *
+%* *
%************************************************************************
TVars are shared memory locations which support atomic memory
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = thenSTM m k
- return x = returnSTM x
+ return x = returnSTM x
m >>= k = bindSTM m k
bindSTM :: STM a -> (a -> STM b) -> STM b
INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar")
instance Eq (TVar a) where
- (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
+ (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
-- |Create a new TVar holding a value supplied
newTVar :: a -> STM (TVar a)
newTVar val = STM $ \s1# ->
case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
+ (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-- |@IO@ version of 'newTVar'. This is useful for creating top-level
-- 'TVar's using 'System.IO.Unsafe.unsafePerformIO', because using
newTVarIO :: a -> IO (TVar a)
newTVarIO val = IO $ \s1# ->
case newTVar# val s1# of
- (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
+ (# s2#, tvar# #) -> (# s2#, TVar tvar# #)
-- |Return the current value stored in a TVar
readTVar :: TVar a -> STM a
writeTVar :: TVar a -> a -> STM ()
writeTVar (TVar tvar#) val = STM $ \s1# ->
case writeTVar# tvar# val s1# of
- s2# -> (# s2#, () #)
+ s2# -> (# s2#, () #)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[mvars]{M-Structures}
-%* *
+%* *
%************************************************************************
M-Vars are rendezvous points for concurrent threads. They begin
-- |Create an 'MVar' which contains the supplied value.
newMVar :: a -> IO (MVar a)
newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
return mvar
-- |Return the contents of the 'MVar'. If the 'MVar' is currently
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
+ (# 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
block $ do
a <- takeMVar m
b <- catchException (unblock (io a))
- (\e -> do putMVar m a; throw e)
+ (\e -> do putMVar m a; throw e)
putMVar m a
return b
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Thread waiting}
-%* *
+%* *
%************************************************************************
\begin{code}
asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncRead# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
+ (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) =
IO $ \s -> case asyncWrite# fd isSock len buf s of
- (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
+ (# s, len#, err# #) -> (# s, (I# len#, I# err#) #)
asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int
asyncDoProc (FunPtr proc) (Ptr param) =
-- the 'length' value is ignored; simplifies implementation of
-- the async*# primops to have them all return the same result.
IO $ \s -> case asyncDoProc# proc param s of
- (# s, len#, err# #) -> (# s, I# err# #)
+ (# s, len#, err# #) -> (# s, I# err# #)
-- to aid the use of these primops by the IO Handle implementation,
-- provide the following convenience funs:
| threaded = waitForReadEvent fd
#endif
| otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitRead# fd# s of { s -> (# s, () #)
- }}
+ case fromIntegral fd of { I# fd# ->
+ case waitRead# fd# s of { s -> (# s, () #)
+ }}
-- | Block the current thread until data can be written to the
-- given file descriptor (GHC only).
| threaded = waitForWriteEvent fd
#endif
| otherwise = IO $ \s ->
- case fromIntegral fd of { I# fd# ->
- case waitWrite# fd# s of { s -> (# s, () #)
- }}
+ case fromIntegral fd of { I# fd# ->
+ case waitWrite# fd# s of { s -> (# s, () #)
+ }}
-- | Suspends the current thread for a given number of microseconds
-- (GHC only).
threadDelay time
| threaded = waitForDelayEvent time
| otherwise = IO $ \s ->
- case fromIntegral time of { I# time# ->
- case delay# time# s of { s -> (# s, () #)
- }}
+ case fromIntegral time of { I# time# ->
+ case delay# time# s of { s -> (# s, () #)
+ }}
-- | Set the value of returned TVar to True after a given number of
-- Issues, possible problems:
--
--- - we might want bound threads to just do the blocking
--- operation rather than communicating with the IO manager
--- thread. This would prevent simgle-threaded programs which do
--- IO from requiring multiple OS threads. However, it would also
--- prevent bound threads waiting on IO from being killed or sent
--- exceptions.
+-- - we might want bound threads to just do the blocking
+-- operation rather than communicating with the IO manager
+-- thread. This would prevent simgle-threaded programs which do
+-- IO from requiring multiple OS threads. However, it would also
+-- prevent bound threads waiting on IO from being killed or sent
+-- exceptions.
--
--- - Apprently exec() doesn't work on Linux in a multithreaded program.
--- I couldn't repeat this.
+-- - Apprently exec() doesn't work on Linux in a multithreaded program.
+-- I couldn't repeat this.
--
--- - How do we handle signal delivery in the multithreaded RTS?
+-- - How do we handle signal delivery in the multithreaded RTS?
--
--- - forkProcess will kill the IO manager thread. Let's just
--- hope we don't need to do any blocking IO between fork & exec.
+-- - forkProcess will kill the IO manager thread. Let's just
+-- hope we don't need to do any blocking IO between fork & exec.
#ifndef mingw32_HOST_OS
data IOReq
pendingEvents :: IORef [IOReq]
#endif
pendingDelays :: IORef [DelayReq]
- -- could use a strict list or array here
+ -- could use a strict list or array here
{-# NOINLINE pendingEvents #-}
{-# NOINLINE pendingDelays #-}
(pendingEvents,pendingDelays) = unsafePerformIO $ do
reqs <- newIORef []
dels <- newIORef []
return (reqs, dels)
- -- the first time we schedule an IO request, the service thread
- -- will be created (cool, huh?)
+ -- the first time we schedule an IO request, the service thread
+ -- will be created (cool, huh?)
ensureIOManagerIsRunning :: IO ()
ensureIOManagerIsRunning
0 -> do
r <- c_readIOManagerEvent
exit <-
- case r of
- _ | r == io_MANAGER_WAKEUP -> return False
- _ | r == io_MANAGER_DIE -> return True
+ case r of
+ _ | r == io_MANAGER_WAKEUP -> return False
+ _ | r == io_MANAGER_DIE -> return True
0 -> return False -- spurious wakeup
- r -> do start_console_handler (r `shiftR` 1); return False
+ r -> do start_console_handler (r `shiftR` 1); return False
if exit
then return ()
else service_cont wakeup delays'
getDelay now all@(d : rest)
= case d of
Delay time m | now >= time -> do
- putMVar m ()
- getDelay now rest
+ putMVar m ()
+ getDelay now rest
DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now rest
+ atomically $ writeTVar t True
+ getDelay now rest
_otherwise ->
-- delay is in millisecs for WaitForSingleObject
let micro_seconds = delayTime d - now
startIOManagerThread :: IO ()
startIOManagerThread = do
allocaArray 2 $ \fds -> do
- throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
- rd_end <- peekElemOff fds 0
- wr_end <- peekElemOff fds 1
- writeIORef stick (fromIntegral wr_end)
- c_setIOManagerPipe wr_end
- forkIO $ do
- allocaBytes sizeofFdSet $ \readfds -> do
- allocaBytes sizeofFdSet $ \writefds -> do
- allocaBytes sizeofTimeVal $ \timeval -> do
- service_loop (fromIntegral rd_end) readfds writefds timeval [] []
- return ()
+ throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
+ rd_end <- peekElemOff fds 0
+ wr_end <- peekElemOff fds 1
+ writeIORef stick (fromIntegral wr_end)
+ c_setIOManagerPipe wr_end
+ forkIO $ do
+ allocaBytes sizeofFdSet $ \readfds -> do
+ allocaBytes sizeofFdSet $ \writefds -> do
+ allocaBytes sizeofTimeVal $ \timeval -> do
+ service_loop (fromIntegral rd_end) readfds writefds timeval [] []
+ return ()
service_loop
- :: Fd -- listen to this for wakeup calls
+ :: Fd -- listen to this for wakeup calls
-> Ptr CFdSet
-> Ptr CFdSet
-> Ptr CTimeVal
-- perform the select()
let do_select delays = do
- -- check the current time and wake up any thread in
- -- threadDelay whose timeout has expired. Also find the
- -- timeout value for the select() call.
- now <- getUSecOfDay
- (delays', timeout) <- getDelay now ptimeval delays
-
- res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
- nullPtr timeout
- if (res == -1)
- then do
- err <- getErrno
- case err of
- _ | err == eINTR -> do_select delays'
- -- EINTR: just redo the select()
- _ | err == eBADF -> return (True, delays)
- -- EBADF: one of the file descriptors is closed or bad,
- -- we don't know which one, so wake everyone up.
- _ | otherwise -> throwErrno "select"
- -- otherwise (ENOMEM or EINVAL) something has gone
- -- wrong; report the error.
- else
- return (False,delays')
+ -- check the current time and wake up any thread in
+ -- threadDelay whose timeout has expired. Also find the
+ -- timeout value for the select() call.
+ now <- getUSecOfDay
+ (delays', timeout) <- getDelay now ptimeval delays
+
+ res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds
+ nullPtr timeout
+ if (res == -1)
+ then do
+ err <- getErrno
+ case err of
+ _ | err == eINTR -> do_select delays'
+ -- EINTR: just redo the select()
+ _ | err == eBADF -> return (True, delays)
+ -- EBADF: one of the file descriptors is closed or bad,
+ -- we don't know which one, so wake everyone up.
+ _ | otherwise -> throwErrno "select"
+ -- otherwise (ENOMEM or EINVAL) something has gone
+ -- wrong; report the error.
+ else
+ return (False,delays')
(wakeup_all,delays') <- do_select delays
if b == 0
then return False
else alloca $ \p -> do
- c_read (fromIntegral wakeup) p 1; return ()
- s <- peek p
- case s of
- _ | s == io_MANAGER_WAKEUP -> return False
- _ | s == io_MANAGER_DIE -> return True
- _ -> withMVar signalHandlerLock $ \_ -> do
+ c_read (fromIntegral wakeup) p 1; return ()
+ s <- peek p
+ case s of
+ _ | s == io_MANAGER_WAKEUP -> return False
+ _ | s == io_MANAGER_DIE -> return True
+ _ -> withMVar signalHandlerLock $ \_ -> do
handler_tbl <- peek handlers
- sp <- peekElemOff handler_tbl (fromIntegral s)
+ sp <- peekElemOff handler_tbl (fromIntegral s)
io <- deRefStablePtr sp
- forkIO io
- return False
+ forkIO io
+ return False
if exit then return () else do
atomicModifyIORef prodding (\_ -> (False,False))
reqs' <- if wakeup_all then do wakeupAll reqs; return []
- else completeRequests reqs readfds writefds []
+ else completeRequests reqs readfds writefds []
service_loop wakeup readfds writefds ptimeval reqs' delays'
buildFdSets maxfd readfds writefds (Read fd m : reqs)
| fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
| otherwise = do
- fdSet fd readfds
+ fdSet fd readfds
buildFdSets (max maxfd fd) readfds writefds reqs
buildFdSets maxfd readfds writefds (Write fd m : reqs)
| fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
| otherwise = do
- fdSet fd writefds
- buildFdSets (max maxfd fd) readfds writefds reqs
+ fdSet fd writefds
+ buildFdSets (max maxfd fd) readfds writefds reqs
completeRequests [] _ _ reqs' = return reqs'
completeRequests (Read fd m : reqs) readfds writefds reqs' = do
getDelay now ptimeval all@(d : rest)
= case d of
Delay time m | now >= time -> do
- putMVar m ()
- getDelay now ptimeval rest
+ putMVar m ()
+ getDelay now ptimeval rest
DelaySTM time t | now >= time -> do
- atomically $ writeTVar t True
- getDelay now ptimeval rest
+ atomically $ writeTVar t True
+ getDelay now ptimeval rest
_otherwise -> do
- setTimevalTicks ptimeval (delayTime d - now)
- return (all,ptimeval)
+ setTimevalTicks ptimeval (delayTime d - now)
+ return (all,ptimeval)
newtype CTimeVal = CTimeVal ()
module GHC.ConsoleHandler
#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
- where
+ where
import Prelude -- necessary to get dependencies right
#else /* whole file */
- ( Handler(..)
- , installHandler
- , ConsoleEvent(..)
- , flushConsole
- ) where
+ ( Handler(..)
+ , installHandler
+ , ConsoleEvent(..)
+ , flushConsole
+ ) where
{-
#include "Signals.h"
-- it in one of these environments.
--
installHandler :: Handler -> IO Handler
-installHandler handler
+installHandler handler
| threaded =
modifyMVar win32ConsoleHandler $ \old_h -> do
- (new_h,rc) <-
+ (new_h,rc) <-
case handler of
Default -> do
r <- rts_installHandler STG_SIG_DFL nullPtr
Catch h -> do
r <- rts_installHandler STG_SIG_HAN nullPtr
return (h, r)
- prev_handler <-
+ prev_handler <-
case rc of
STG_SIG_DFL -> return Default
STG_SIG_IGN -> return Ignore
| otherwise =
alloca $ \ p_sp -> do
- rc <-
+ rc <-
case handler of
Default -> rts_installHandler STG_SIG_DFL p_sp
Ignore -> rts_installHandler STG_SIG_IGN p_sp
Catch h -> do
v <- newStablePtr (toHandler h)
- poke p_sp v
- rts_installHandler STG_SIG_HAN p_sp
+ poke p_sp v
+ rts_installHandler STG_SIG_HAN p_sp
case rc of
STG_SIG_DFL -> return Default
STG_SIG_IGN -> return Ignore
STG_SIG_HAN -> do
osptr <- peek p_sp
oldh <- deRefStablePtr osptr
- -- stable pointer is no longer in use, free it.
- freeStablePtr osptr
- return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
+ -- stable pointer is no longer in use, free it.
+ freeStablePtr osptr
+ return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
where
- fromConsoleEvent ev =
+ fromConsoleEvent ev =
case ev of
ControlC -> 0 {- CTRL_C_EVENT-}
Break -> 1 {- CTRL_BREAK_EVENT-}
toHandler hdlr ev = do
case toWin32ConsoleEvent ev of
- -- see rts/win32/ConsoleHandler.c for comments as to why
- -- rts_ConsoleHandlerDone is called here.
+ -- see rts/win32/ConsoleHandler.c for comments as to why
+ -- rts_ConsoleHandlerDone is called here.
Just x -> hdlr x >> rts_ConsoleHandlerDone ev
- Nothing -> return () -- silently ignore..
+ Nothing -> return () -- silently ignore..
no_handler = error "win32ConsoleHandler"
flushConsole :: Handle -> IO ()
-flushConsole h =
- wantReadableHandle "flushConsole" h $ \ h_ ->
+flushConsole h =
+ wantReadableHandle "flushConsole" h $ \ h_ ->
throwErrnoIfMinus1Retry_ "flushConsole"
(flush_console_fd (fromIntegral (haFD h_)))
foreign import ccall unsafe "consUtils.h flush_input_console__"
- flush_console_fd :: CInt -> IO CInt
+ flush_console_fd :: CInt -> IO CInt
#endif /* mingw32_HOST_OS */
--
-----------------------------------------------------------------------------
-module GHC.Dotnet
- ( Object
- , unmarshalObject
- , marshalObject
- , unmarshalString
- , marshalString
- , checkResult
- ) where
+module GHC.Dotnet
+ ( Object
+ , unmarshalObject
+ , marshalObject
+ , unmarshalString
+ , marshalString
+ , checkResult
+ ) where
import GHC.Prim
import GHC.Base
import Foreign.Storable
import Foreign.C.String
-data Object a
+data Object a
= Object Addr#
checkResult :: (State# RealWorld -> (# State# RealWorld, a, Addr# #))
- -> IO a
-checkResult fun = IO $ \ st ->
+ -> IO a
+checkResult fun = IO $ \ st ->
case fun st of
- (# st1, res, err #)
+ (# st1, res, err #)
| err `eqAddr#` nullAddr# -> (# st1, res #)
| otherwise -> throw (IOException (raiseError err)) st1
-
+
-- ToDo: attach finaliser.
unmarshalObject :: Addr# -> Object a
unmarshalObject x = Object x
-- dotnet interop support passing and returning
-- strings.
-marshalString :: String
- -> (Addr# -> IO a)
- -> IO a
+marshalString :: String
+ -> (Addr# -> IO a)
+ -> IO a
marshalString str cont = withCString str (\ (Ptr x) -> cont x)
-- char** received back from a .NET interop layer.
-- #hide
module GHC.Enum(
- Bounded(..), Enum(..),
- boundedEnumFrom, boundedEnumFromThen,
+ Bounded(..), Enum(..),
+ boundedEnumFrom, boundedEnumFromThen,
- -- Instances for Bounded and Enum: (), Char, Int
+ -- Instances for Bounded and Enum: (), Char, Int
) where
import GHC.Base
-import Data.Tuple () -- for dependencies
-default () -- Double isn't available yet
+import Data.Tuple () -- for dependencies
+default () -- Double isn't available yet
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Class declarations}
-%* *
+%* *
%*********************************************************
\begin{code}
-- * 'enumFrom' and 'enumFromThen' should be defined with an implicit bound,
-- thus:
--
--- > enumFrom x = enumFromTo x maxBound
--- > enumFromThen x y = enumFromThenTo x y bound
--- > where
--- > bound | fromEnum y >= fromEnum x = maxBound
--- > | otherwise = minBound
+-- > enumFrom x = enumFromTo x maxBound
+-- > enumFromThen x y = enumFromThenTo x y bound
+-- > where
+-- > bound | fromEnum y >= fromEnum x = maxBound
+-- > | otherwise = minBound
--
-class Enum a where
+class Enum a where
-- | the successor of a value. For numeric types, 'succ' adds 1.
- succ :: a -> a
+ succ :: a -> a
-- | the predecessor of a value. For numeric types, 'pred' subtracts 1.
- pred :: a -> a
+ pred :: a -> a
-- | Convert from an 'Int'.
toEnum :: Int -> a
-- | Convert to an 'Int'.
fromEnum :: a -> Int
-- | Used in Haskell's translation of @[n..]@.
- enumFrom :: a -> [a]
+ enumFrom :: a -> [a]
-- | Used in Haskell's translation of @[n,n'..]@.
- enumFromThen :: a -> a -> [a]
+ enumFromThen :: a -> a -> [a]
-- | Used in Haskell's translation of @[n..m]@.
- enumFromTo :: a -> a -> [a]
+ enumFromTo :: a -> a -> [a]
-- | Used in Haskell's translation of @[n,n'..m]@.
- enumFromThenTo :: a -> a -> a -> [a]
+ enumFromThenTo :: a -> a -> a -> [a]
- succ = toEnum . (`plusInt` oneInt) . fromEnum
- pred = toEnum . (`minusInt` oneInt) . fromEnum
- enumFrom x = map toEnum [fromEnum x ..]
- enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
+ succ = toEnum . (`plusInt` oneInt) . fromEnum
+ pred = toEnum . (`minusInt` oneInt) . fromEnum
+ enumFrom x = map toEnum [fromEnum x ..]
+ enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..]
enumFromTo x y = map toEnum [fromEnum x .. fromEnum y]
enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y]
%*********************************************************
-%* *
+%* *
\subsection{Tuples}
-%* *
+%* *
%*********************************************************
\begin{code}
| otherwise = error "Prelude.Enum.().toEnum: bad argument"
fromEnum () = zeroInt
- enumFrom () = [()]
- enumFromThen () () = let many = ():many in many
- enumFromTo () () = [()]
+ enumFrom () = [()]
+ enumFromThen () () = let many = ():many in many
+ enumFromTo () () = [()]
enumFromThenTo () () () = let many = ():many in many
\end{code}
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f)
- => Bounded (a,b,c,d,e,f) where
+ => Bounded (a,b,c,d,e,f) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g)
- => Bounded (a,b,c,d,e,f,g) where
+ => Bounded (a,b,c,d,e,f,g) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h)
- => Bounded (a,b,c,d,e,f,g,h) where
+ Bounded h)
+ => Bounded (a,b,c,d,e,f,g,h) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i)
- => Bounded (a,b,c,d,e,f,g,h,i) where
+ Bounded h, Bounded i)
+ => Bounded (a,b,c,d,e,f,g,h,i) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound)
+ minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound)
+ maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j)
- => Bounded (a,b,c,d,e,f,g,h,i,j) where
+ Bounded h, Bounded i, Bounded j)
+ => Bounded (a,b,c,d,e,f,g,h,i,j) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound)
+ minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound)
+ maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k) where
+ Bounded h, Bounded i, Bounded j, Bounded k)
+ => Bounded (a,b,c,d,e,f,g,h,i,j,k) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound)
+ minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound)
+ maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where
+ Bounded h, Bounded i, Bounded j, Bounded k, Bounded l)
+ => Bounded (a,b,c,d,e,f,g,h,i,j,k,l) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound)
+ minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound)
+ maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where
+ Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m)
+ => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound)
+ minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound)
+ maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
+ Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n)
+ => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound, minBound)
+ minBound, minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
+ maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
instance (Bounded a, Bounded b, Bounded c, Bounded d, Bounded e, Bounded f, Bounded g,
- Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o)
- => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
+ Bounded h, Bounded i, Bounded j, Bounded k, Bounded l, Bounded m, Bounded n, Bounded o)
+ => Bounded (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
minBound = (minBound, minBound, minBound, minBound, minBound, minBound, minBound, minBound,
- minBound, minBound, minBound, minBound, minBound, minBound, minBound)
+ minBound, minBound, minBound, minBound, minBound, minBound, minBound)
maxBound = (maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound,
- maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
+ maxBound, maxBound, maxBound, maxBound, maxBound, maxBound, maxBound)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Bool@}
-%* *
+%* *
%*********************************************************
\begin{code}
pred False = error "Prelude.Enum.Bool.pred: bad argument"
toEnum n | n == zeroInt = False
- | n == oneInt = True
- | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument"
+ | n == oneInt = True
+ | otherwise = error "Prelude.Enum.Bool.toEnum: bad argument"
fromEnum False = zeroInt
fromEnum True = oneInt
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Ordering@}
-%* *
+%* *
%*********************************************************
\begin{code}
pred LT = error "Prelude.Enum.Ordering.pred: bad argument"
toEnum n | n == zeroInt = LT
- | n == oneInt = EQ
- | n == twoInt = GT
+ | n == oneInt = EQ
+ | n == twoInt = GT
toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argument"
fromEnum LT = zeroInt
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Char@}
-%* *
+%* *
%*********************************************************
\begin{code}
instance Enum Char where
succ (C# c#)
| not (ord# c# ==# 0x10FFFF#) = C# (chr# (ord# c# +# 1#))
- | otherwise = error ("Prelude.Enum.Char.succ: bad argument")
+ | otherwise = error ("Prelude.Enum.Char.succ: bad argument")
pred (C# c#)
| not (ord# c# ==# 0#) = C# (chr# (ord# c# -# 1#))
- | otherwise = error ("Prelude.Enum.Char.pred: bad argument")
+ | otherwise = error ("Prelude.Enum.Char.pred: bad argument")
toEnum = chr
fromEnum = ord
{-# INLINE enumFrom #-}
enumFrom (C# x) = eftChar (ord# x) 0x10FFFF#
- -- Blarg: technically I guess enumFrom isn't strict!
+ -- Blarg: technically I guess enumFrom isn't strict!
{-# INLINE enumFromTo #-}
enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y)
enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y)
{-# RULES
-"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
-"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
-"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
-"eftCharList" [1] eftCharFB (:) [] = eftChar
-"efdCharList" [1] efdCharFB (:) [] = efdChar
-"efdtCharList" [1] efdtCharFB (:) [] = efdtChar
+"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
+"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
+"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
+"eftCharList" [1] eftCharFB (:) [] = eftChar
+"efdCharList" [1] efdCharFB (:) [] = efdChar
+"efdtCharList" [1] efdtCharFB (:) [] = efdtChar
#-}
-- have hassles about arithmetic overflow at maxBound
{-# INLINE [0] eftCharFB #-}
eftCharFB c n x y = go x
- where
- go x | x ># y = n
- | otherwise = C# (chr# x) `c` go (x +# 1#)
+ where
+ go x | x ># y = n
+ | otherwise = C# (chr# x) `c` go (x +# 1#)
eftChar x y | x ># y = []
- | otherwise = C# (chr# x) : eftChar (x +# 1#) y
+ | otherwise = C# (chr# x) : eftChar (x +# 1#) y
-- For enumFromThenTo we give up on inlining
= go_up x
where
go_up x | x ># lim = n
- | otherwise = C# (chr# x) `c` go_up (x +# delta)
+ | otherwise = C# (chr# x) `c` go_up (x +# delta)
go_dn_char_fb c n x delta lim
= go_dn x
where
go_dn x | x <# lim = n
- | otherwise = C# (chr# x) `c` go_dn (x +# delta)
+ | otherwise = C# (chr# x) `c` go_dn (x +# delta)
go_up_char_list x delta lim
= go_up x
where
go_up x | x ># lim = []
- | otherwise = C# (chr# x) : go_up (x +# delta)
+ | otherwise = C# (chr# x) : go_up (x +# delta)
go_dn_char_list x delta lim
= go_dn x
where
go_dn x | x <# lim = []
- | otherwise = C# (chr# x) : go_dn (x +# delta)
+ | otherwise = C# (chr# x) : go_dn (x +# delta)
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Type @Int@}
-%* *
+%* *
%*********************************************************
Be careful about these instances.
- (a) remember that you have to count down as well as up e.g. [13,12..0]
- (b) be careful of Int overflow
- (c) remember that Int is bounded, so [1..] terminates at maxInt
+ (a) remember that you have to count down as well as up e.g. [13,12..0]
+ (b) be careful of Int overflow
+ (c) remember that Int is bounded, so [1..] terminates at maxInt
Also NB that the Num class isn't available in this module.
-
+
\begin{code}
instance Bounded Int where
minBound = minInt
{-# INLINE enumFrom #-}
enumFrom (I# x) = eftInt x maxInt#
where I# maxInt# = maxInt
- -- Blarg: technically I guess enumFrom isn't strict!
+ -- Blarg: technically I guess enumFrom isn't strict!
{-# INLINE enumFromTo #-}
enumFromTo (I# x) (I# y) = eftInt x y
-- In particular, we have rules for deforestation
{-# RULES
-"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
-"eftIntList" [1] eftIntFB (:) [] = eftInt
+"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+"eftIntList" [1] eftIntFB (:) [] = eftInt
#-}
eftInt :: Int# -> Int# -> [Int]
-- [x1..x2]
eftInt x y | x ># y = []
- | otherwise = go x
- where
- go x = I# x : if x ==# y then [] else go (x +# 1#)
+ | otherwise = go x
+ where
+ go x = I# x : if x ==# y then [] else go (x +# 1#)
{-# INLINE [0] eftIntFB #-}
eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
-eftIntFB c n x y | x ># y = n
- | otherwise = go x
- where
- go x = I# x `c` if x ==# y then n else go (x +# 1#)
- -- Watch out for y=maxBound; hence ==, not >
- -- Be very careful not to have more than one "c"
- -- so that when eftInfFB is inlined we can inline
- -- whatever is bound to "c"
+eftIntFB c n x y | x ># y = n
+ | otherwise = go x
+ where
+ go x = I# x `c` if x ==# y then n else go (x +# 1#)
+ -- Watch out for y=maxBound; hence ==, not >
+ -- Be very careful not to have more than one "c"
+ -- so that when eftInfFB is inlined we can inline
+ -- whatever is bound to "c"
-----------------------------------------------------
-----------------------------------------------------------------------------
-- #hide
-module GHC.Err
+module GHC.Err
(
irrefutPatError
, noMethodBindingError
, patError
, recSelError
, recConError
- , runtimeError -- :: Addr# -> a -- Addr# points to UTF8 encoded C string
+ , runtimeError -- :: Addr# -> a -- Addr# points to UTF8 encoded C string
- , absentErr -- :: a
- , divZeroError -- :: a
- , overflowError -- :: a
+ , absentErr -- :: a
+ , divZeroError -- :: a
+ , overflowError -- :: a
- , error -- :: String -> a
- , assertError -- :: String -> Bool -> a -> a
-
- , undefined -- :: a
+ , error -- :: String -> a
+ , assertError -- :: String -> Bool -> a -> a
+
+ , undefined -- :: a
) where
#ifndef __HADDOCK__
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Error-ish functions}
-%* *
+%* *
%*********************************************************
\begin{code}
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Compiler generated errors + local utils}
-%* *
+%* *
%*********************************************************
Used for compiler-generated error message;
\begin{code}
recSelError, recConError, irrefutPatError, runtimeError,
- nonExhaustiveGuardsError, patError, noMethodBindingError
- :: Addr# -> a -- All take a UTF8-encoded C string
+ nonExhaustiveGuardsError, patError, noMethodBindingError
+ :: Addr# -> a -- All take a UTF8-encoded C string
-recSelError s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
-runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately
+recSelError s = throw (RecSelError (unpackCStringUtf8# s)) -- No location info unfortunately
+runtimeError s = error (unpackCStringUtf8# s) -- No location info unfortunately
nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
-irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
-recConError s = throw (RecConError (untangle s "Missing field in record construction"))
+irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+recConError s = throw (RecConError (untangle s "Missing field in record construction"))
noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
-patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
assertError :: Addr# -> Bool -> a -> a
assertError str pred v
(untangle coded message) expects "coded" to be of the form
- "location|details"
+ "location|details"
It prints
- location message details
+ location message details
\begin{code}
untangle :: Addr# -> String -> String
(location, details)
= case (span not_bar coded_str) of { (loc, rest) ->
- case rest of
- ('|':det) -> (loc, ' ' : det)
- _ -> (loc, "")
- }
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
not_bar c = c /= '|'
\end{code}
-----------------------------------------------------------------------------
-- #hide
-module GHC.Exception
- ( module GHC.Exception,
- Exception(..), AsyncException(..),
- IOException(..), ArithException(..), ArrayException(..),
- throw, throwIO, ioError )
+module GHC.Exception
+ ( module GHC.Exception,
+ Exception(..), AsyncException(..),
+ IOException(..), ArithException(..), ArrayException(..),
+ throw, throwIO, ioError )
where
import GHC.Base
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Primitive catch}
-%* *
+%* *
%*********************************************************
catchException used to handle the passing around of the state to the
-- Non-I\/O exceptions are not caught by this variant; to catch all
-- exceptions, use 'Control.Exception.catch' from "Control.Exception".
catch :: IO a -> (IOError -> IO a) -> IO a
-catch m k = catchException m handler
+catch m k = catchException m handler
where handler (IOException err) = k err
- handler other = throw other
+ handler other = throw other
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Controlling asynchronous exception delivery}
-%* *
+%* *
%*********************************************************
\begin{code}
(
-- * Representations of some basic types
Int(..),Word(..),Float(..),Double(..),Integer(..),Char(..),
- Ptr(..), FunPtr(..),
+ Ptr(..), FunPtr(..),
-- * Primitive operations
module GHC.Prim,
- shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
+ shiftL#, shiftRL#, iShiftL#, iShiftRA#, iShiftRL#,
uncheckedShiftL64#, uncheckedShiftRL64#,
uncheckedIShiftL64#, uncheckedIShiftRA64#,
- -- * Fusion
- build, augment,
+ -- * Fusion
+ build, augment,
- -- * Overloaded string literals
- IsString(..),
+ -- * Overloaded string literals
+ IsString(..),
- -- * Debugging
- breakpoint, breakpointCond,
+ -- * Debugging
+ breakpoint, breakpointCond,
- -- * Ids with special behaviour
- lazy, inline,
+ -- * Ids with special behaviour
+ lazy, inline,
-- * Transform comprehensions
Down(..), groupWith, sortWith, the
-- | 'the' ensures that all the elements of the list are identical
-- and then returns that unique element
the :: Eq a => [a] -> a
-the (x:xs)
+the (x:xs)
| all (x ==) xs = x
| otherwise = error "GHC.Exts.the: non-identical elements"
the [] = error "GHC.Exts.the: empty list"
module GHC.Handle (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
-
+
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
fillReadBuffer, fillReadBufferWithoutBlocking,
readRawBuffer, readRawBufferPtr,
readRawBufferNoBlock, readRawBufferPtrNoBlock,
import GHC.Arr
import GHC.Base
-import GHC.Read ( Read )
+import GHC.Read ( Read )
import GHC.List
import GHC.IOBase
import GHC.Exception
import GHC.Enum
-import GHC.Num ( Integer(..), Num(..) )
+import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
-import GHC.Real ( toInteger )
+import GHC.Real ( toInteger )
#if defined(DEBUG_DUMP)
import GHC.Pack
#endif
-- 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)
+-- 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
-- Creating a new handle
newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle filepath finalizer hc = do
+newFileHandle filepath finalizer hc = do
m <- newMVar hc
addMVarFinalizer m (finalizer m)
return (FileHandle filepath m)
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
+ - 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,
withHandle' :: String -> Handle -> MVar Handle__
-> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle' fun h m act =
+withHandle' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ (h',v) <- catchException (act h_)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return v
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 =
+withHandle_' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- v <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ v <- catchException (act h_)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h_
putMVar m h_
return v
withHandle__' fun h r act
withHandle__' fun h w act
-withHandle__' fun h m act =
+withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
h' <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return ()
augmentIOError (IOError _ iot _ str fp) fun h
= IOError (Just h) iot fun str filepath
where filepath
- | Just _ <- fp = fp
- | otherwise = case h of
- FileHandle fp _ -> Just fp
- DuplexHandle fp _ _ -> Just fp
+ | Just _ <- fp = fp
+ | otherwise = case h of
+ FileHandle fp _ -> Just fp
+ DuplexHandle fp _ _ -> Just fp
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
-- ToDo: in the Duplex case, we don't need to checkWritableHandle
wantWritableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
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_
+ = 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.
-- ToDo: in the Duplex case, we don't need to checkReadableHandle
wantReadableHandle'
- :: String -> Handle -> MVar Handle__
- -> (Handle__ -> IO a) -> IO a
+ :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO a) -> IO a
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
-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_
+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)
+ ioException (IOError (Just h) IllegalOperation fun
+ "handle is not seekable" Nothing)
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
-
-checkSeekableHandle act handle_ =
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+
+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_closedHandle, ioe_EOF,
+ ioe_notReadable, ioe_notWritable,
ioe_notSeekable, ioe_notSeekable_notBin :: IO a
-ioe_closedHandle = ioException
- (IOError Nothing IllegalOperation ""
- "handle is closed" Nothing)
-ioe_EOF = ioException
+ioe_closedHandle = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is closed" Nothing)
+ioe_EOF = ioException
(IOError Nothing EOF "" "" Nothing)
-ioe_notReadable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for reading" Nothing)
-ioe_notWritable = ioException
- (IOError Nothing IllegalOperation ""
- "handle is not open for writing" Nothing)
-ioe_notSeekable = ioException
+ioe_notReadable = ioException
(IOError Nothing IllegalOperation ""
- "handle is not seekable" Nothing)
-ioe_notSeekable_notBin = ioException
+ "handle is not open for reading" Nothing)
+ioe_notWritable = ioException
(IOError Nothing IllegalOperation ""
- "seek operations on text-mode handles are not allowed on this platform"
+ "handle is not open for writing" Nothing)
+ioe_notSeekable = ioException
+ (IOError Nothing IllegalOperation ""
+ "handle is not seekable" Nothing)
+ioe_notSeekable_notBin = ioException
+ (IOError Nothing IllegalOperation ""
+ "seek operations on text-mode handles are not allowed on this platform"
Nothing)
-
+
ioe_finalizedHandle fp = throw (IOException
- (IOError Nothing IllegalOperation ""
- "handle is finalized" (Just fp)))
+ (IOError Nothing IllegalOperation ""
+ "handle is finalized" (Just fp)))
ioe_bufsiz :: Int -> IO a
-ioe_bufsiz n = ioException
+ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
- ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
- -- 9 => should be parens'ified.
+ ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
+ -- 9 => should be parens'ified.
-- -----------------------------------------------------------------------------
-- Handle Finalizers
handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
handleFinalizer fp m = do
handle_ <- takeMVar m
- case haType handle_ of
+ case haType handle_ of
ClosedHandle -> return ()
_ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
- -- ignore errors and async exceptions, and close the
- -- descriptor anyway...
- hClose_handle_ handle_
- return ()
+ -- ignore errors and async exceptions, and close the
+ -- descriptor anyway...
+ hClose_handle_ handle_
+ return ()
putMVar m (ioe_finalizedHandle fp)
-- ---------------------------------------------------------------------------
#ifdef DEBUG
checkBufferInvariants h_ = do
- let ref = haBuffer h_
+ 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
+ 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 ()
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#) #)
+ 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#)) #)
+ (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
ref = haBuffer h_
buf <- readIORef ref
new_buf <- if bufferIsWritable buf
- then flushWriteBuffer fd (haIsStream h_) buf
- else return buf
+ then flushWriteBuffer fd (haIsStream h_) buf
+ else return buf
writeIORef ref new_buf
-- flushBuffer syncs the file with the buffer, including moving the
puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek fd (fromIntegral off) sEEK_CUR)
+ (c_lseek fd (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
- (fromIntegral r) (fromIntegral bytes)
+ (fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
res <- readRawBuffer "fillReadBuffer" fd is_stream b
- (fromIntegral w) (fromIntegral bytes)
+ (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 }
+ 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' }
+ 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
puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
- 0 (fromIntegral size)
+ 0 (fromIntegral size)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
else do threadWaitWrite (fromIntegral fd); unsafe_write
where
do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
+ (threadWaitWrite (fromIntegral fd))
unsafe_write = do_write (write_rawBuffer fd buf off len)
safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
else do threadWaitWrite (fromIntegral fd); unsafe_write
where
do_write call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitWrite (fromIntegral fd))
+ (threadWaitWrite (fromIntegral fd))
unsafe_write = do_write (write_off fd buf off len)
safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
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
+ (fromIntegral len) off buf
if l == (-1)
then
- ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
else return (fromIntegral l)
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)
+ (fromIntegral len) (buf `plusPtr` off)
if l == (-1)
then
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
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
+ (fromIntegral len) off buf
if l == (-1)
then
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
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)
+ (fromIntegral len) (buf `plusPtr` off)
if l == (-1)
then
ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
let
oflags1 = case mode of
- ReadMode -> read_flags
+ ReadMode -> read_flags
#ifdef mingw32_HOST_OS
- WriteMode -> write_flags .|. o_TRUNC
+ WriteMode -> write_flags .|. o_TRUNC
#else
- WriteMode -> write_flags
+ WriteMode -> write_flags
#endif
- ReadWriteMode -> rw_flags
- AppendMode -> append_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
binary_flags
- | binary = o_BINARY
- | otherwise = 0
+ | binary = o_BINARY
+ | otherwise = 0
oflags = oflags1 .|. binary_flags
in do
-- 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)
+ (c_open f (fromIntegral oflags) 0o666)
stat@(fd_type,_,_) <- fdStat fd
h <- fdToHandle_stat fd (Just stat) False filepath mode binary
`catchException` \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).
+ -- 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.
+ -- 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)
#endif
let (ha_type, write) =
- case mode of
- ReadMode -> ( ReadHandle, False )
- WriteMode -> ( WriteHandle, True )
- ReadWriteMode -> ( ReadWriteHandle, True )
- AppendMode -> ( AppendHandle, True )
+ 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
+ Nothing -> fdStat fd
case fd_type of
- Directory ->
- ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing)
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
- -- regular files need to be locked
- RegularFile -> do
+ -- regular files need to be locked
+ RegularFile -> do
#ifndef mingw32_HOST_OS
- r <- lockFile fd dev ino (fromBool write)
- when (r == -1) $
- ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing)
+ r <- lockFile fd dev ino (fromBool write)
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
#endif
- mkFileHandle fd is_stream filepath ha_type binary
+ 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
+ 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
+ RawDevice ->
+ mkFileHandle fd is_stream filepath ha_type binary
-- | Old API kept to avoid breaking clients
fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool
#endif
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
- -> IO Handle
+ -> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
spares <- newIORef BufferListNil
newFileHandle filepath (stdHandleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
+ (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
- })
+ 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
-- from read mode to write mode on a buffered text-mode handle, see bug
-- \#679.
bmode <- case ha_type of
- ReadWriteHandle | not binary -> return NoBuffering
- _other -> return bmode
+ ReadWriteHandle | not binary -> return NoBuffering
+ _other -> return bmode
#endif
spares <- newIORef BufferListNil
newFileHandle filepath (handleFinalizer filepath)
- (Handle__ { haFD = fd,
- haType = ha_type,
+ (Handle__ { haFD = fd,
+ haType = ha_type,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = bmode,
- haBuffer = buf,
- haBuffers = spares,
- haOtherSide = Nothing
- })
+ haIsStream = is_stream,
+ haBufferMode = bmode,
+ 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,
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = w_bmode,
- haBuffer = w_buf,
- haBuffers = w_spares,
- haOtherSide = Nothing
- }
+ 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,
+ Handle__ { haFD = fd,
+ haType = ReadHandle,
haIsBin = binary,
- haIsStream = is_stream,
- haBufferMode = r_bmode,
- haBuffer = r_buf,
- haBuffers = r_spares,
- haOtherSide = Just write_side
- }
+ 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)
initBufferState ReadHandle = ReadBuffer
-initBufferState _ = WriteBuffer
+initBufferState _ = WriteBuffer
-- ---------------------------------------------------------------------------
-- Closing a handle
case haType handle_ of
ClosedHandle -> return (handle_,Nothing)
_ -> do flushWriteBufferOnly handle_ -- interruptible
- hClose_handle_ handle_
+ hClose_handle_ handle_
hClose_handle_ handle_ = do
let fd = haFD handle_
Nothing -> (do
throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_HOST_OS
- (closeFd (haIsStream handle_) fd)
+ (closeFd (haIsStream handle_) fd)
#else
- (c_close fd)
+ (c_close fd)
#endif
return Nothing
)
-- 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
- },
+ haType = ClosedHandle
+ },
maybe_exception)
{-# NOINLINE noBuffer #-}
hFileSize handle =
withHandle_ "hFileSize" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+ 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)
+ r <- fdFileSize (haFD handle_)
+ if r /= -1
+ then return r
+ else ioException (IOError Nothing InappropriateType "hFileSize"
+ "not a regular file" Nothing)
-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
hSetFileSize handle size =
withHandle_ "hSetFileSize" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
_ -> do flushWriteBufferOnly handle_
- throwErrnoIf (/=0) "hSetFileSize"
- (c_ftruncate (haFD handle_) (fromIntegral size))
- return ()
+ throwErrnoIf (/=0) "hSetFileSize"
+ (c_ftruncate (haFD handle_) (fromIntegral size))
+ return ()
-- ---------------------------------------------------------------------------
-- Detecting the End of Input
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
- then fillReadBuffer fd True (haIsStream handle_) buf
- else return buf
+ then fillReadBuffer fd True (haIsStream handle_) buf
+ else return buf
writeIORef ref new_buf
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
+ {- 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
+ -- '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 ()
+ NoBuffering -> return ()
#endif
- _ -> setCooked (haFD handle_) True
+ _ -> setCooked (haFD handle_) True
- -- throw away spare buffers, they might be the wrong size
- writeIORef (haBuffers handle_) BufferListNil
+ -- throw away spare buffers, they might be the wrong size
+ writeIORef (haBuffers handle_) BufferListNil
- return (handle_{ haBufferMode = mode })
+ return (handle_{ haBufferMode = mode })
-- -----------------------------------------------------------------------------
-- hFlush
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 ()
+ then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
+ writeIORef (haBuffer handle_) flushed_buf
+ else return ()
-- -----------------------------------------------------------------------------
instance Show HandlePosn where
showsPrec p (HandlePosn h pos) =
- showsPrec p h . showString " at position " . shows 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
-- | 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.
+ = 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:
fd = haFD handle_
let do_seek =
- throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (haFD handle_) (fromIntegral offset) whence)
+ throwErrnoIfMinus1Retry_ "hSeek"
+ (c_lseek (haFD handle_) (fromIntegral offset) whence)
whence :: CInt
whence = case mode of
SeekFromEnd -> sEEK_END
if bufferIsWritable buf
- then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
- writeIORef ref new_buf
- do_seek
- else do
+ 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
+ then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
+ else do
new_buf <- flushReadBuffer (haFD handle_) buf
writeIORef ref new_buf
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.
+ -- 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)
+ 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)
+ | 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")
case haType handle_ of
ClosedHandle -> return False
SemiClosedHandle -> return False
- _ -> return True
+ _ -> return True
hIsClosed :: Handle -> IO Bool
hIsClosed handle =
withHandle_ "hIsClosed" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> return True
- _ -> return False
+ ClosedHandle -> return True
+ _ -> return False
{- not defined, nor exported, but mentioned
here for documentation purposes:
hIsReadable handle =
withHandle_ "hIsReadable" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isReadableHandleType htype)
+ 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)
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritableHandleType htype)
-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
-- for @hdl@.
hGetBuffering handle =
withHandle_ "hGetBuffering" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
+ 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..
+ -- 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
+ 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))
flushBuffer h_
-- Windows' dup2 does not return the new descriptor, unlike Unix
throwErrnoIfMinus1 "dupHandleTo" $
- c_dup2 (haFD h_) (haFD hto_)
+ c_dup2 (haFD h_) (haFD hto_)
dupHandle_ other_side h_ (haFD hto_)
dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
ioref_buffers <- newIORef BufferListNil
let new_handle_ = h_{ haFD = new_fd,
- haBuffer = ioref,
- haBuffers = ioref_buffers,
- haOtherSide = other_side }
+ haBuffer = ioref,
+ haBuffers = ioref_buffers,
+ haOtherSide = other_side }
return (h_, new_handle_)
-- -----------------------------------------------------------------------------
withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
hDuplicateTo h1 _ =
ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
- "handles are incompatible" Nothing)
+ "handles are incompatible" Nothing)
-- ---------------------------------------------------------------------------
-- showing Handles.
withHandle_ "showHandle" h $ \hdl_ ->
let
showType | is_duplex = showString "duplex (read-write)"
- | otherwise = shows (haType hdl_)
+ | 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 "}" )
+ (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 ht cont =
case ht of
ClosedHandle -> shows ht . showString "}"
- _ -> cont
+ _ -> 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)
+ 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
#if defined(DEBUG_DUMP)
puts :: String -> IO ()
puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
- return ()
+ return ()
#endif
-- -----------------------------------------------------------------------------
res <- f
if (res :: CInt) == -1
then do
- err <- getErrno
- if err == eINTR
- then throwErrnoIfMinus1RetryOnBlock loc f on_block
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1RetryOnBlock loc f on_block
else if err == eWOULDBLOCK || err == eAGAIN
- then do on_block
+ then do on_block
else throwErrno loc
else return res
-- #hide
module GHC.IO (
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
- commitBuffer', -- hack, see below
- hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
+ commitBuffer', -- hack, see below
+ hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile,
memcpy_ba_baoff,
memcpy_ptr_baoff,
import GHC.Enum
import GHC.Base
import GHC.IOBase
-import GHC.Handle -- much of the real stuff is in here
+import GHC.Handle -- much of the real stuff is in here
import GHC.Real
import GHC.Num
import GHC.Show
buf <- readIORef ref
if not (bufferEmpty buf)
- then return True
- else do
+ 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)
+ 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_)
- return (r /= 0)
+ return (r /= 0)
foreign import ccall safe "fdReady"
fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
buf <- readIORef ref
if not (bufferEmpty buf)
- then hGetcBuffered fd ref buf
- else do
+ 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
+ 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
+ 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
+ -- 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 ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
= do (c,r) <- readCharFromBuffer b r
let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
- | otherwise = buf{ bufRPtr=r }
+ | otherwise = buf{ bufRPtr=r }
writeIORef ref new_buf
return c
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 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
+ Nothing -> hGetLineUnBuffered h
+ Just l -> return l
hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_ = do
maybeFillReadBuffer fd is_line is_stream buf
= catch
(do buf <- fillReadBuffer fd is_line is_stream buf
- return (Just buf)
+ return (Just buf)
)
(\e -> do if isEOFError e
- then return Nothing
- else ioError e)
+ then return Nothing
+ else ioError e)
unpack :: RawBuffer -> Int -> Int -> IO [Char]
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+ (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
hGetLineUnBuffered :: Handle -> IO String
(hGetChar h)
(\ err -> do
if isEOFError err then
- return '\n'
- else
- ioError err)
+ return '\n'
+ else
+ ioError err)
if c == '\n' then
return ""
else do
hGetContents handle =
withHandle "hGetContents" handle $ \handle_ ->
case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ AppendHandle -> ioe_notReadable
+ WriteHandle -> ioe_notReadable
_ -> do xs <- lazyRead handle
- return (handle_{ haType=SemiClosedHandle}, xs )
+ 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,
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)
+ 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)
lazyRead' h handle_ = do
let ref = haBuffer handle_
-- (see hLookAhead)
buf <- readIORef ref
if not (bufferEmpty buf)
- then lazyReadHaveBuffer h handle_ fd ref buf
- else do
+ 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)
+ -- 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
-- is_line==True, which tells it to "just read what there is".
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.
- (\e -> do (handle_,_) <- hClose_help handle_
- return (handle_, "")
- )
+ (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.
+ (\e -> do (handle_,_) <- hClose_help handle_
+ return (handle_, "")
+ )
lazyReadHaveBuffer h handle_ fd ref buf = do
more <- lazyRead h
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+ (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
-- ---------------------------------------------------------------------------
-- hPutChar
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 ()
+ 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_ is_line c = do
let ref = haBuffer handle_
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
+ flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
+ writeIORef ref flushed_buf
else do
- writeIORef ref new_buf
+ writeIORef ref new_buf
hPutChars :: Handle -> [Char] -> IO ()
-- I/O operation on the same handle which would lead to deadlock. The classic
-- case is
--
--- putStr (trace "hello" "world")
+-- putStr (trace "hello" "world")
--
-- so the basic scheme is this:
--
--- * copy the string into a fresh buffer,
--- * "commit" the buffer to the handle.
+-- * 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
hPutStr :: Handle -> String -> IO ()
hPutStr handle str = do
buffer_mode <- wantWritableHandle "hPutStr" handle
- (\ handle_ -> do getSpareBuffer handle_)
+ (\ handle_ -> do getSpareBuffer handle_)
case buffer_mode of
(NoBuffering, _) -> do
- hPutChars handle str -- v. slow, but we don't care
+ hPutChars handle str -- v. slow, but we don't care
(LineBuffering, buf) -> do
- writeLines handle buf str
+ 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}
+ 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)
+ 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.
+ -- 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
+ 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 ()
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
+ n' <- writeCharIntoBuffer raw n c
if (c == '\n')
then do
new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
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.
+ -- 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
+ 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 ()
+ commitBuffer hdl raw len n False{-no flush-} True{-release-}
+ return ()
shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- shoveString n' cs
+ n' <- writeCharIntoBuffer raw n c
+ shoveString n' cs
in
shoveString 0 s
-- Implementation:
--
-- for block/line buffering,
--- 1. If there isn't room in the handle buffer, flush the handle
--- buffer.
+-- 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.
+-- 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.
+-- 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
+ :: 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 $
#ifdef DEBUG_DUMP
puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
- ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
+ ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
#endif
old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
- <- readIORef ref
+ <- 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
+ 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
+ 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.
-- 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 :: 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
+ :: 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 -- 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_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
- bufWrite fd ref is_stream ptr count can_block
+ bufWrite fd ref is_stream ptr count can_block
bufWrite fd ref is_stream ptr count can_block =
seq count $ seq fd $ do -- strictness hack
-- 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
+ -- 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 bytes = loop 0 bytes
loop _ bytes | bytes <= 0 = return ()
loop off bytes = do
r <- fromIntegral `liftM`
- writeRawBufferPtr "writeChunk" fd is_stream ptr
- off (fromIntegral bytes)
+ writeRawBufferPtr "writeChunk" fd is_stream ptr
+ off (fromIntegral bytes)
-- write can't return 0
loop (off + r) (bytes - r)
let r = fromIntegral ssize :: Int
if (r == -1)
then do errno <- getErrno
- if (errno == eAGAIN || errno == eWOULDBLOCK)
- then return off
- else throwErrno "writeChunk"
+ 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)
+ (fromIntegral bytes)
+ (ptr `plusPtr` off)
let r = fromIntegral ssize :: Int
if r == (-1)
then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle "hGetBuf" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufRead fd ref is_stream ptr 0 count
+ \ handle_@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
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
+ 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
+ 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
+ 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
+ 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)
+ rest <- readChunk fd is_stream ptr' remaining
+ return (so_far' + rest)
readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
readChunk fd is_stream ptr bytes = loop 0 bytes
loop off bytes = do
r <- fromIntegral `liftM`
readRawBufferPtr "readChunk" fd is_stream
- (castPtr ptr) off (fromIntegral bytes)
+ (castPtr ptr) off (fromIntegral bytes)
if r == 0
- then return off
- else loop (off + r) (bytes - r)
+ then return off
+ else loop (off + r) (bytes - r)
-- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
| count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
| otherwise =
wantReadableHandle "hGetBufNonBlocking" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
- bufReadNonBlocking fd ref is_stream ptr 0 count
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
+ bufReadNonBlocking fd ref is_stream ptr 0 count
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.
- }
+ 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)
+ 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)
+ (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,
illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn (sz :: Int) =
- ioException (IOError (Just handle)
- InvalidArgument fn
- ("illegal buffer size " ++ showsPrec 9 sz [])
- Nothing)
+ ioException (IOError (Just handle)
+ InvalidArgument fn
+ ("illegal buffer size " ++ showsPrec 9 sz [])
+ Nothing)
unsafePerformIO, unsafeInterleaveIO,
unsafeDupablePerformIO, unsafeDupableInterleaveIO,
noDuplicate,
-
- -- To and from from ST
+
+ -- To and from from ST
stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
- -- References
+ -- References
IORef(..), newIORef, readIORef, writeIORef,
IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
MVar(..),
- -- Handles, file descriptors,
+ -- Handles, file descriptors,
FilePath,
Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
-
- -- Buffers
+
+ -- Buffers
Buffer(..), RawBuffer, BufferState(..), BufferList(..), BufferMode(..),
bufferIsWritable, bufferEmpty, bufferFull,
- -- Exceptions
+ -- Exceptions
Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
stackOverflow, heapOverflow, throw, throwIO, ioException,
IOError, IOException(..), IOErrorType(..), ioError, userError,
ExitCode(..)
) where
-
+
import GHC.ST
-import GHC.Arr -- to derive Ix class
+import GHC.Arr -- to derive Ix class
import GHC.Enum -- to derive Enum class
import GHC.STRef
import GHC.Base
--- import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude
+-- import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude
import Data.Maybe ( Maybe(..) )
import GHC.Show
import GHC.List
import Foreign.C.Types (CInt)
#ifndef __HADDOCK__
-import {-# SOURCE #-} Data.Typeable ( showsTypeRep )
-import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep )
+import {-# SOURCE #-} Data.Typeable ( showsTypeRep )
+import {-# SOURCE #-} Data.Dynamic ( Dynamic, dynTypeRep )
#endif
-- ---------------------------------------------------------------------------
Compiler - types of various primitives in PrimOp.lhs
-RTS - forceIO (StgMiscClosures.hc)
- - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
- (Exceptions.hc)
- - raiseAsync (Schedule.c)
+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.
+ GHC.Exception.lhs.
Libraries - parts of hslibs/lang.
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
- return x = returnIO x
+ return x = returnIO x
m >>= k = bindIO m k
- fail s = failIO s
+ fail s = failIO s
failIO :: String -> IO a
failIO s = ioError (userError s)
-- 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 RealWorld a -> IO a
stToIO (ST m) = IO m
-ioToST :: IO a -> ST RealWorld a
+ioToST :: IO a -> ST RealWorld a
ioToST (IO m) = (ST m)
-- This relies on IO and ST having the same representation modulo the
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.
+ 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).
+ 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.
+ 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 = unsafePerformIO $ newIORef []
>
> main = do
-> writeIORef test [42]
-> bang <- readIORef test
-> print (bang :: [Char])
+> 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
possible to write @coerce :: a -> b@ with the
help of 'unsafePerformIO'. So be careful!
-}
-unsafePerformIO :: IO a -> a
+unsafePerformIO :: IO a -> a
unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
{-|
it gives the same results each time.
-}
{-# NOINLINE unsafeDupablePerformIO #-}
-unsafeDupablePerformIO :: IO a -> a
+unsafeDupablePerformIO :: IO a -> a
unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with
-- 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 #)
+-- 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'
+-- by hiding it with 'lazy'
{-|
'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily.
unsafeDupableInterleaveIO :: IO a -> IO a
unsafeDupableInterleaveIO (IO m)
= IO ( \ s -> let
- r = case m s of (# _, res #) -> res
- in
- (# s, r #))
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
{-|
Ensures that the suspensions under evaluation by the current thread
-- 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#
+ (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
-- * buffering mode
-- * buffer, and spare buffers
-- * user-friendly name (usually the
--- FilePath used when IO.openFile was called)
+-- 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.
-- ensure that this doesn't happen.
data Handle
- = FileHandle -- A normal handle to a file
- FilePath -- the file (invariant)
- !(MVar 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
+ | 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
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?
+ 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
+ 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.
+ -- duplex handle.
}
-- ---------------------------------------------------------------------------
data Buffer
= Buffer {
- bufBuf :: RawBuffer,
- bufRPtr :: !Int,
- bufWPtr :: !Int,
- bufSize :: !Int,
- bufState :: BufferState
+ bufBuf :: RawBuffer,
+ bufRPtr :: !Int,
+ bufWPtr :: !Int,
+ bufSize :: !Int,
+ bufState :: BufferState
}
data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
isReadableHandleType ReadHandle = True
isReadableHandleType ReadWriteHandle = True
-isReadableHandleType _ = False
+isReadableHandleType _ = False
isWritableHandleType AppendHandle = True
isWritableHandleType WriteHandle = True
isWritableHandleType ReadWriteHandle = True
-isWritableHandleType _ = False
+isWritableHandleType _ = False
isReadWriteHandleType ReadWriteHandle{} = True
isReadWriteHandleType _ = False
-- and terminals will normally be line-buffered.
data BufferMode
- = NoBuffering -- ^ buffering is disabled if possible.
+ = NoBuffering -- ^ buffering is disabled if possible.
| LineBuffering
- -- ^ line-buffering should be enabled if possible.
+ -- ^ 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.
+ -- ^ 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)
-- ---------------------------------------------------------------------------
-- 'Data.Dynamic.Dynamic' (see the section on Dynamic Exceptions:
-- "Control.Exception\#DynamicExceptions").
data Exception
- = ArithException ArithException
- -- ^Exceptions raised by arithmetic
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArithException's except for 'DivideByZero').
- | ArrayException ArrayException
- -- ^Exceptions raised by array-related
- -- operations. (NOTE: GHC currently does not throw
- -- 'ArrayException's).
- | AssertionFailed String
- -- ^This exception is thrown by the
- -- 'assert' operation when the condition
- -- fails. The 'String' argument contains the
- -- location of the assertion in the source program.
- | AsyncException AsyncException
- -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions").
+ = ArithException ArithException
+ -- ^Exceptions raised by arithmetic
+ -- operations. (NOTE: GHC currently does not throw
+ -- 'ArithException's except for 'DivideByZero').
+ | ArrayException ArrayException
+ -- ^Exceptions raised by array-related
+ -- operations. (NOTE: GHC currently does not throw
+ -- 'ArrayException's).
+ | AssertionFailed String
+ -- ^This exception is thrown by the
+ -- 'assert' operation when the condition
+ -- fails. The 'String' argument contains the
+ -- location of the assertion in the source program.
+ | AsyncException AsyncException
+ -- ^Asynchronous exceptions (see section on Asynchronous Exceptions: "Control.Exception\#AsynchronousExceptions").
| BlockedOnDeadMVar
- -- ^The current thread was executing a call to
- -- 'Control.Concurrent.MVar.takeMVar' that could never return,
- -- because there are no other references to this 'MVar'.
+ -- ^The current thread was executing a call to
+ -- 'Control.Concurrent.MVar.takeMVar' that could never return,
+ -- because there are no other references to this 'MVar'.
| BlockedIndefinitely
- -- ^The current thread was waiting to retry an atomic memory transaction
- -- that could never become possible to complete because there are no other
- -- threads referring to any of the TVars involved.
+ -- ^The current thread was waiting to retry an atomic memory transaction
+ -- that could never become possible to complete because there are no other
+ -- threads referring to any of the TVars involved.
| NestedAtomically
- -- ^The runtime detected an attempt to nest one STM transaction
- -- inside another one, presumably due to the use of
- -- 'unsafePeformIO' with 'atomically'.
+ -- ^The runtime detected an attempt to nest one STM transaction
+ -- inside another one, presumably due to the use of
+ -- 'unsafePeformIO' with 'atomically'.
| Deadlock
- -- ^There are no runnable threads, so the program is
- -- deadlocked. The 'Deadlock' exception is
- -- raised in the main thread only (see also: "Control.Concurrent").
- | DynException Dynamic
- -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions").
- | ErrorCall String
- -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String'
- -- argument of 'ErrorCall' is the string passed to 'error' when it was
- -- called.
- | ExitException ExitCode
- -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
- -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed
- -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the
- -- main thread will cause the program to be terminated with the given
- -- exit code.
- | IOException IOException
- -- ^These are the standard IO exceptions generated by
- -- Haskell\'s @IO@ operations. See also "System.IO.Error".
+ -- ^There are no runnable threads, so the program is
+ -- deadlocked. The 'Deadlock' exception is
+ -- raised in the main thread only (see also: "Control.Concurrent").
+ | DynException Dynamic
+ -- ^Dynamically typed exceptions (see section on Dynamic Exceptions: "Control.Exception\#DynamicExceptions").
+ | ErrorCall String
+ -- ^The 'ErrorCall' exception is thrown by 'error'. The 'String'
+ -- argument of 'ErrorCall' is the string passed to 'error' when it was
+ -- called.
+ | ExitException ExitCode
+ -- ^The 'ExitException' exception is thrown by 'System.Exit.exitWith' (and
+ -- 'System.Exit.exitFailure'). The 'ExitCode' argument is the value passed
+ -- to 'System.Exit.exitWith'. An unhandled 'ExitException' exception in the
+ -- main thread will cause the program to be terminated with the given
+ -- exit code.
+ | IOException IOException
+ -- ^These are the standard IO exceptions generated by
+ -- Haskell\'s @IO@ operations. See also "System.IO.Error".
| NoMethodError String
- -- ^An attempt was made to invoke a class method which has
- -- no definition in this instance, and there was no default
- -- definition given in the class declaration. GHC issues a
- -- warning when you compile an instance which has missing
- -- methods.
+ -- ^An attempt was made to invoke a class method which has
+ -- no definition in this instance, and there was no default
+ -- definition given in the class declaration. GHC issues a
+ -- warning when you compile an instance which has missing
+ -- methods.
| NonTermination
- -- ^The current thread is stuck in an infinite loop. This
- -- exception may or may not be thrown when the program is
- -- non-terminating.
- | PatternMatchFail String
- -- ^A pattern matching failure. The 'String' argument should contain a
- -- descriptive message including the function name, source file
- -- and line number.
- | RecConError String
- -- ^An attempt was made to evaluate a field of a record
- -- for which no value was given at construction time. The
- -- 'String' argument gives the location of the
- -- record construction in the source program.
- | RecSelError String
- -- ^A field selection was attempted on a constructor that
- -- doesn\'t have the requested field. This can happen with
- -- multi-constructor records when one or more fields are
- -- missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record selection in the source program.
- | RecUpdError String
- -- ^An attempt was made to update a field in a record,
- -- where the record doesn\'t have the requested field. This can
- -- only occur with multi-constructor records, when one or more
- -- fields are missing from some of the constructors. The
- -- 'String' argument gives the location of the
- -- record update in the source program.
+ -- ^The current thread is stuck in an infinite loop. This
+ -- exception may or may not be thrown when the program is
+ -- non-terminating.
+ | PatternMatchFail String
+ -- ^A pattern matching failure. The 'String' argument should contain a
+ -- descriptive message including the function name, source file
+ -- and line number.
+ | RecConError String
+ -- ^An attempt was made to evaluate a field of a record
+ -- for which no value was given at construction time. The
+ -- 'String' argument gives the location of the
+ -- record construction in the source program.
+ | RecSelError String
+ -- ^A field selection was attempted on a constructor that
+ -- doesn\'t have the requested field. This can happen with
+ -- multi-constructor records when one or more fields are
+ -- missing from some of the constructors. The
+ -- 'String' argument gives the location of the
+ -- record selection in the source program.
+ | RecUpdError String
+ -- ^An attempt was made to update a field in a record,
+ -- where the record doesn\'t have the requested field. This can
+ -- only occur with multi-constructor records, when one or more
+ -- fields are missing from some of the constructors. The
+ -- 'String' argument gives the location of the
+ -- record update in the source program.
-- |The type of arithmetic exceptions
data ArithException
-- |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.
+ -- ^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.
+ -- ^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.
+ -- ^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.
deriving (Eq, Ord)
-- | 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.
+ = 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)
stackOverflow, heapOverflow :: Exception -- for the RTS
instance Show ArrayException where
showsPrec _ (IndexOutOfBounds s)
- = showString "array index out of range"
- . (if not (null s) then showString ": " . showString s
- else id)
+ = 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)
+ = showString "undefined array element"
+ . (if not (null s) then showString ": " . showString s
+ else id)
instance Show Exception where
- showsPrec _ (IOException err) = shows err
+ showsPrec _ (IOException err) = shows err
showsPrec _ (ArithException err) = shows err
showsPrec _ (ArrayException err) = shows err
- showsPrec _ (ErrorCall err) = showString err
+ showsPrec _ (ErrorCall err) = showString err
showsPrec _ (ExitException err) = showString "exit: " . shows err
showsPrec _ (NoMethodError err) = showString err
showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
+ showsPrec _ (RecSelError err) = showString err
+ showsPrec _ (RecConError err) = showString err
+ showsPrec _ (RecUpdError err) = showString err
showsPrec _ (AssertionFailed err) = showString err
showsPrec _ (DynException err) = showString "exception :: " . showsTypeRep (dynTypeRep err)
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
- showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely"
- showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested"
+ showsPrec _ (AsyncException e) = shows e
+ showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
+ showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely"
+ showsPrec _ (NestedAtomically) = showString "Control.Concurrent.STM.atomically was nested"
showsPrec _ (NonTermination) = showString "<<loop>>"
showsPrec _ (Deadlock) = showString "<<deadlock>>"
IOException e1 == IOException e2 = e1 == e2
ArithException e1 == ArithException e2 = e1 == e2
ArrayException e1 == ArrayException e2 = e1 == e2
- ErrorCall e1 == ErrorCall e2 = e1 == e2
- ExitException e1 == ExitException e2 = e1 == e2
+ ErrorCall e1 == ErrorCall e2 = e1 == e2
+ ExitException e1 == ExitException e2 = e1 == e2
NoMethodError e1 == NoMethodError e2 = e1 == e2
PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
RecSelError e1 == RecSelError e2 = e1 == e2
-- Exception datatype (above).
data ExitCode
- = ExitSuccess -- ^ indicates successful termination;
+ = 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).
+ -- ^ 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)
-- --------------------------------------------------------------------------
-- ordering with respect to other 'IO' operations, whereas 'throw'
-- does not.
throwIO :: Exception -> IO a
-throwIO err = IO $ raiseIO# err
+throwIO err = IO $ raiseIO# err
-ioException :: IOException -> IO a
+ioException :: IOException -> IO a
ioException err = IO $ raiseIO# (IOException err)
-- | Raise an 'IOError' in the 'IO' monad.
ioError :: IOError -> IO a
-ioError = ioException
+ioError = ioException
-- ---------------------------------------------------------------------------
-- IOError type
data IOException
= IOError {
ioe_handle :: Maybe Handle, -- the handle used by the action flagging
- -- the error.
+ -- the error.
ioe_type :: IOErrorType, -- what it was.
- ioe_location :: String, -- location.
+ ioe_location :: String, -- location.
ioe_description :: String, -- error type specific information.
ioe_filename :: Maybe FilePath -- filename the error is related to.
}
showsPrec _ e =
showString $
case e of
- AlreadyExists -> "already exists"
+ AlreadyExists -> "already exists"
NoSuchThing -> "does not exist"
ResourceBusy -> "resource busy"
ResourceExhausted -> "resource exhausted"
- EOF -> "end of file"
- IllegalOperation -> "illegal operation"
+ EOF -> "end of file"
+ IllegalOperation -> "illegal operation"
PermissionDenied -> "permission denied"
- UserError -> "user error"
- HardwareFault -> "hardware fault"
+ 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"
+ SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UnsupportedOperation -> "unsupported operation"
-- > fail s = ioError (userError s)
--
userError :: String -> IOError
-userError str = IOError Nothing UserError "" str Nothing
+userError str = IOError Nothing UserError "" str 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 ": ") .
+ Nothing -> case hdl of
+ Nothing -> id
+ Just h -> showsPrec p h . showString ": "
+ Just name -> showString name . showString ": ") .
(case loc of
"" -> id
- _ -> showString loc . showString ": ") .
+ _ -> showString loc . showString ": ") .
showsPrec p iot .
(case s of
- "" -> id
- _ -> showString " (" . showString s . showString ")")
+ "" -> id
+ _ -> showString " (" . showString s . showString ")")
-- -----------------------------------------------------------------------------
-- IOMode type
-- #hide
module GHC.List (
- -- [] (..), -- Not Haskell 98; built in syntax
+ -- [] (..), -- Not Haskell 98; built in syntax
map, (++), filter, concat,
- head, last, tail, init, null, length, (!!),
+ head, last, tail, init, null, length, (!!),
foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1,
iterate, repeat, replicate, cycle,
take, drop, splitAt, takeWhile, dropWhile, span, break,
) where
-import Data.Tuple() -- Instances
+import Data.Tuple() -- Instances
import Data.Maybe
import GHC.Base
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{List-manipulation functions}
-%* *
+%* *
%*********************************************************
\begin{code}
badHead = errorEmptyList "head"
-- This rule is useful in cases like
--- head [y | (x,y) <- ps, x==t]
+-- head [y | (x,y) <- ps, x==t]
{-# RULES
-"head/build" forall (g::forall b.(a->b->b)->b->b) .
- head (build g) = g (\x _ -> x) badHead
-"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) .
- head (augment g xs) = g (\x _ -> x) (head xs)
+"head/build" forall (g::forall b.(a->b->b)->b->b) .
+ head (build g) = g (\x _ -> x) badHead
+"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) .
+ head (augment g xs) = g (\x _ -> x) (head xs)
#-}
-- | Extract the elements after the head of a list, which must be non-empty.
last [] = errorEmptyList "last"
#else
-- eliminate repeated cases
-last [] = errorEmptyList "last"
-last (x:xs) = last' x xs
+last [] = errorEmptyList "last"
+last (x:xs) = last' x xs
where last' y [] = y
- last' _ (y:ys) = last' y ys
+ last' _ (y:ys) = last' y ys
#endif
-- | Return all the elements of a list except the last one.
init [] = errorEmptyList "init"
init (x:xs) = init' x xs
where init' _ [] = []
- init' y (z:zs) = y : init' z zs
+ init' y (z:zs) = y : init' z zs
#endif
-- | Test whether a list is empty.
filter _pred [] = []
filter pred (x:xs)
| pred x = x : filter pred xs
- | otherwise = filter pred xs
+ | otherwise = filter pred xs
{-# NOINLINE [0] filterFB #-}
filterFB c p x r | p x = x `c` r
- | otherwise = r
+ | otherwise = r
{-# RULES
"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
-"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
-"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
+"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p
+"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
#-}
-- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.
foldl :: (a -> b -> a) -> a -> [b] -> a
foldl f z xs = lgo z xs
- where
- lgo z [] = z
- lgo z (x:xs) = lgo (f z x) xs
+ where
+ lgo z [] = z
+ lgo z (x:xs) = lgo (f z x) xs
-- | 'scanl' is similar to 'foldl', but returns a list of successive
-- reduced values from the left:
--
-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
-scanl1 :: (a -> a -> a) -> [a] -> [a]
-scanl1 f (x:xs) = scanl f x xs
-scanl1 _ [] = []
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+scanl1 _ [] = []
-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
-- above functions.
-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.
scanr1 :: (a -> a -> a) -> [a] -> [a]
-scanr1 f [] = []
-scanr1 f [x] = [x]
-scanr1 f (x:xs) = f x q : qs
+scanr1 f [] = []
+scanr1 f [x] = [x]
+scanr1 f (x:xs) = f x q : qs
where qs@(q:_) = scanr1 f xs
-- | 'iterate' @f x@ returns an infinite list of repeated applications
{-# RULES
-"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x)
-"iterateFB" [1] iterateFB (:) = iterate
+"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+"iterateFB" [1] iterateFB (:) = iterate
#-}
-- The pragma just gives the rules more chance to fire
repeat x = xs where xs = x : xs
-{-# INLINE [0] repeatFB #-} -- ditto
+{-# INLINE [0] repeatFB #-} -- ditto
repeatFB c x = xs where xs = x `c` xs
{-# RULES
"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x)
-"repeatFB" [1] repeatFB (:) = repeat
+"repeatFB" [1] repeatFB (:) = repeat
#-}
-- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of
-- on infinite lists.
cycle :: [a] -> [a]
-cycle [] = error "Prelude.cycle: empty list"
-cycle xs = xs' where xs' = xs ++ xs'
+cycle [] = error "Prelude.cycle: empty list"
+cycle xs = xs' where xs' = xs ++ xs'
-- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the
-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@:
#else /* hack away */
{-# RULES
-"take" [~1] forall n xs . take n xs = takeFoldr n xs
+"take" [~1] forall n xs . take n xs = takeFoldr n xs
"takeList" [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs
#-}
{-# NOINLINE [0] takeFB #-}
takeFB :: (a -> b -> b) -> b -> a -> (Int# -> b) -> Int# -> b
takeFB c n x xs m | m <=# 1# = x `c` n
- | otherwise = x `c` xs (m -# 1#)
+ | otherwise = x `c` xs (m -# 1#)
{-# INLINE [0] take #-}
take (I# n#) xs = takeUInt n# xs
| n >=# 0# = take_unsafe_UInt_append n xs rs
| otherwise = []
-take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]
-take_unsafe_UInt_append 0# _ rs = rs
-take_unsafe_UInt_append m ls rs =
+take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b]
+take_unsafe_UInt_append 0# _ rs = rs
+take_unsafe_UInt_append m ls rs =
case ls of
[] -> rs
(x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs
drop (I# n#) ls
- | n# <# 0# = ls
- | otherwise = drop# n# ls
+ | n# <# 0# = ls
+ | otherwise = drop# n# ls
where
- drop# :: Int# -> [a] -> [a]
- drop# 0# xs = xs
- drop# _ xs@[] = xs
- drop# m# (_:xs) = drop# (m# -# 1#) xs
+ drop# :: Int# -> [a] -> [a]
+ drop# 0# xs = xs
+ drop# _ xs@[] = xs
+ drop# m# (_:xs) = drop# (m# -# 1#) xs
splitAt (I# n#) ls
- | n# <# 0# = ([], ls)
- | otherwise = splitAt# n# ls
+ | n# <# 0# = ([], ls)
+ | otherwise = splitAt# n# ls
where
- splitAt# :: Int# -> [a] -> ([a], [a])
- splitAt# 0# xs = ([], xs)
- splitAt# _ xs@[] = (xs, xs)
- splitAt# m# (x:xs) = (x:xs', xs'')
- where
- (xs', xs'') = splitAt# (m# -# 1#) xs
+ splitAt# :: Int# -> [a] -> ([a], [a])
+ splitAt# 0# xs = ([], xs)
+ splitAt# _ xs@[] = (xs, xs)
+ splitAt# m# (x:xs) = (x:xs', xs'')
+ where
+ (xs', xs'') = splitAt# (m# -# 1#) xs
#endif /* USE_REPORT_PRELUDE */
break p = span (not . p)
#else
-- HBC version (stolen)
-break _ xs@[] = (xs, xs)
+break _ xs@[] = (xs, xs)
break p xs@(x:xs')
- | p x = ([],xs)
- | otherwise = let (ys,zs) = break p xs' in (x:ys,zs)
+ | p x = ([],xs)
+ | otherwise = let (ys,zs) = break p xs' in (x:ys,zs)
#endif
-- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.
and = foldr (&&) True
or = foldr (||) False
#else
-and [] = True
-and (x:xs) = x && and xs
-or [] = False
-or (x:xs) = x || or xs
+and [] = True
+and (x:xs) = x && and xs
+or [] = False
+or (x:xs) = x || or xs
{-# RULES
-"and/build" forall (g::forall b.(Bool->b->b)->b->b) .
- and (build g) = g (&&) True
-"or/build" forall (g::forall b.(Bool->b->b)->b->b) .
- or (build g) = g (||) False
+"and/build" forall (g::forall b.(Bool->b->b)->b->b) .
+ and (build g) = g (&&) True
+"or/build" forall (g::forall b.(Bool->b->b)->b->b) .
+ or (build g) = g (||) False
#-}
#endif
any p = or . map p
all p = and . map p
#else
-any _ [] = False
-any p (x:xs) = p x || any p xs
+any _ [] = False
+any p (x:xs) = p x || any p xs
-all _ [] = True
-all p (x:xs) = p x && all p xs
+all _ [] = True
+all p (x:xs) = p x && all p xs
{-# RULES
-"any/build" forall p (g::forall b.(a->b->b)->b->b) .
- any p (build g) = g ((||) . p) False
-"all/build" forall p (g::forall b.(a->b->b)->b->b) .
- all p (build g) = g ((&&) . p) True
+"any/build" forall p (g::forall b.(a->b->b)->b->b) .
+ any p (build g) = g ((||) . p) False
+"all/build" forall p (g::forall b.(a->b->b)->b->b) .
+ all p (build g) = g ((&&) . p) True
#-}
#endif
elem x = any (== x)
notElem x = all (/= x)
#else
-elem _ [] = False
-elem x (y:ys) = x==y || elem x ys
+elem _ [] = False
+elem x (y:ys) = x==y || elem x ys
-notElem _ [] = True
+notElem _ [] = True
notElem x (y:ys)= x /= y && notElem x ys
#endif
-- in the more efficient version.
--
xs !! (I# n) | n <# 0# = error "Prelude.(!!): negative index\n"
- | otherwise = sub xs n
+ | otherwise = sub xs n
where
- sub :: [a] -> Int# -> a
+ sub :: [a] -> Int# -> a
sub [] _ = error "Prelude.(!!): index too large\n"
sub (y:ys) n = if n ==# 0#
- then y
- else sub ys (n -# 1#)
+ then y
+ else sub ys (n -# 1#)
#endif
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{The zip family}
-%* *
+%* *
%*********************************************************
\begin{code}
-foldr2 _k z [] _ys = z
-foldr2 _k z _xs [] = z
+foldr2 _k z [] _ys = z
+foldr2 _k z _xs [] = z
foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys)
foldr2_left _k z _x _r [] = z
-- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys
-- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs
{-# RULES
-"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) .
- foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys
+"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) .
+ foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys
-"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) .
- foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs
+"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) .
+ foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs
#-}
\end{code}
zipFB c x y r = (x,y) `c` r
{-# RULES
-"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
-"zipList" [1] foldr2 (zipFB (:)) [] = zip
+"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
+"zipList" [1] foldr2 (zipFB (:)) [] = zip
#-}
\end{code}
zipWithFB c f x y r = (x `f` y) `c` r
{-# RULES
-"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
-"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f
+"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
+"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f
#-}
\end{code}
%*********************************************************
-%* *
+%* *
\subsection{Error code}
-%* *
+%* *
%*********************************************************
Common up near identical calls to `error' to reduce the number
projects / ghc-base.git / commitdiff