{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "Typeable.h"
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.List
import GHC.Show
import GHC.IOBase
import GHC.Exception hiding ( Exception )
--
#ifdef __GLASGOW_HASKELL__
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
-allocaBytes (I# size) action = IO $ \ s ->
- case newPinnedByteArray# size s of { (# s, mbarr# #) ->
- case unsafeFreezeByteArray# mbarr# s of { (# s, barr# #) ->
+allocaBytes (I# size) action = IO $ \ s0 ->
+ case newPinnedByteArray# size s0 of { (# s1, mbarr# #) ->
+ case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
- case action addr of { IO action ->
- case action s of { (# s, r #) ->
- case touch# barr# s of { s ->
- (# s, r #)
+ case action addr of { IO action' ->
+ case action' s2 of { (# s3, r #) ->
+ case touch# barr# s3 of { s4 ->
+ (# s4, r #)
}}}}}
#else
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
#ifndef __GLASGOW_HASKELL__
pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals
#else
-pokeArray ptr vals = go vals 0#
- where go [] n# = return ()
+pokeArray ptr vals0 = go vals0 0#
+ where go [] _ = return ()
go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
pokeArray ptr vals
pokeElemOff ptr (length vals) marker
#else
-pokeArray0 marker ptr vals = go vals 0#
+pokeArray0 marker ptr vals0 = go vals0 0#
where go [] n# = pokeElemOff ptr (I# n#) marker
go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
-}
forkIO :: IO () -> IO ThreadId
forkIO action = IO $ \ s ->
- case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (fork# action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
where
action_plus = catchException action childHandler
-}
forkOnIO :: Int -> IO () -> IO ThreadId
forkOnIO (I# cpu) action = IO $ \ s ->
- case (forkOn# cpu action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #)
where
action_plus = catchException action childHandler
-}
throwTo :: Exception e => ThreadId -> e -> IO ()
-throwTo (ThreadId id) ex = IO $ \ s ->
- case (killThread# id (toException ex) s) of s1 -> (# s1, () #)
+throwTo (ThreadId tid) ex = IO $ \ s ->
+ case (killThread# tid (toException ex) s) of s1 -> (# s1, () #)
-- | Returns the 'ThreadId' of the calling thread (GHC only).
myThreadId :: IO ThreadId
myThreadId = IO $ \s ->
- case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
+ case (myThreadId# s) of (# s1, tid #) -> (# s1, ThreadId tid #)
-- |The 'yield' action allows (forces, in a co-operative multitasking
thenSTM :: STM a -> STM b -> STM b
thenSTM (STM m) k = STM ( \s ->
case m s of
- (# new_s, a #) -> unSTM k new_s
+ (# new_s, _ #) -> unSTM k new_s
)
returnSTM :: a -> STM a
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
-- "System.Mem.Weak" for more about finalizers.
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) finalizer =
- IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) }
+ IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar m io =
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
- case waitRead# fd# s of { s -> (# s, () #)
+ case waitRead# fd# s of { s' -> (# s', () #)
}}
-- | Block the current thread until data can be written to the
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
- case waitWrite# fd# s of { s -> (# s, () #)
+ case waitWrite# fd# s of { s' -> (# s', () #)
}}
-- | Suspends the current thread for a given number of microseconds
| threaded = waitForDelayEvent time
| otherwise = IO $ \s ->
case fromIntegral time of { I# time# ->
- case delay# time# s of { s -> (# s, () #)
+ case delay# time# s of { s' -> (# s', () #)
}}
-- pick up new delay requests
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
- let delays = foldr insertDelay old_delays new_delays
+ let delays0 = foldr insertDelay old_delays new_delays
-- build the FDSets for select()
fdZero readfds
else
return (False,delays')
- (wakeup_all,delays') <- do_select delays
+ (wakeup_all,delays') <- do_select delays0
exit <-
if wakeup_all then return False
service_loop wakeup readfds writefds ptimeval reqs' delays'
-io_MANAGER_WAKEUP = 0xff :: CChar
-io_MANAGER_DIE = 0xfe :: CChar
+io_MANAGER_WAKEUP, io_MANAGER_DIE :: CChar
+io_MANAGER_WAKEUP = 0xff
+io_MANAGER_DIE = 0xfe
stick :: IORef Fd
{-# NOINLINE stick #-}
-- -----------------------------------------------------------------------------
-- IO requests
-buildFdSets maxfd readfds writefds [] = return maxfd
-buildFdSets maxfd readfds writefds (Read fd m : reqs)
+buildFdSets :: Fd -> Ptr CFdSet -> Ptr CFdSet -> [IOReq] -> IO Fd
+buildFdSets maxfd _ _ [] = return maxfd
+buildFdSets maxfd readfds writefds (Read fd _ : reqs)
| fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
| otherwise = do
fdSet fd readfds
buildFdSets (max maxfd fd) readfds writefds reqs
-buildFdSets maxfd readfds writefds (Write fd m : reqs)
+buildFdSets maxfd readfds writefds (Write fd _ : reqs)
| fd >= fD_SETSIZE = error "buildFdSets: file descriptor out of range"
| otherwise = do
fdSet fd writefds
buildFdSets (max maxfd fd) readfds writefds reqs
+completeRequests :: [IOReq] -> Ptr CFdSet -> Ptr CFdSet -> [IOReq]
+ -> IO [IOReq]
completeRequests [] _ _ reqs' = return reqs'
completeRequests (Read fd m : reqs) readfds writefds reqs' = do
b <- fdIsSet fd readfds
then do putMVar m (); completeRequests reqs readfds writefds reqs'
else completeRequests reqs readfds writefds (Write fd m : reqs')
+wakeupAll :: [IOReq] -> IO ()
wakeupAll [] = return ()
-wakeupAll (Read fd m : reqs) = do putMVar m (); wakeupAll reqs
-wakeupAll (Write fd m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Read _ m : reqs) = do putMVar m (); wakeupAll reqs
+wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs
waitForReadEvent :: Fd -> IO ()
waitForReadEvent fd = do
-- and return the smallest delay to wait for. The queue of pending
-- delays is kept ordered.
getDelay :: USecs -> Ptr CTimeVal -> [DelayReq] -> IO ([DelayReq], Ptr CTimeVal)
-getDelay now ptimeval [] = return ([],nullPtr)
+getDelay _ _ [] = return ([],nullPtr)
getDelay now ptimeval all@(d : rest)
= case d of
Delay time m | now >= time -> do
setTimevalTicks ptimeval (delayTime d - now)
return (all,ptimeval)
-newtype CTimeVal = CTimeVal ()
+data CTimeVal
foreign import ccall unsafe "sizeofTimeVal"
sizeofTimeVal :: Int
-- ToDo: move to System.Posix.Internals?
-newtype CFdSet = CFdSet ()
+data CFdSet
foreign import ccall safe "select"
c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
fD_SETSIZE :: Fd
fD_SETSIZE = fromIntegral c_fD_SETSIZE
-foreign import ccall unsafe "hsFD_CLR"
- c_fdClr :: CInt -> Ptr CFdSet -> IO ()
-
-fdClr :: Fd -> Ptr CFdSet -> IO ()
-fdClr (Fd fd) fdset = c_fdClr fd fdset
-
foreign import ccall unsafe "hsFD_ISSET"
c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
import GHC.IOBase
import GHC.Exception
import GHC.Enum
-import GHC.Num ( Integer(..), Num(..) )
+import GHC.Num ( Integer, Num(..) )
import GHC.Show
#if defined(DEBUG_DUMP)
import GHC.Pack
-- Are files opened by default in text or binary mode, if the user doesn't
-- specify?
-dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
-- ---------------------------------------------------------------------------
-- Creating a new handle
withHandle__' fun h r act
withHandle__' fun h w act
+withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
+ -> IO ()
withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
putMVar m h'
return ()
+augmentIOError :: IOException -> String -> Handle -> IOException
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
+ FileHandle path _ -> Just path
+ DuplexHandle path _ _ -> Just path
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
+checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkWritableHandle act handle_
= case haType handle_ of
ClosedHandle -> ioe_closedHandle
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
+checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkReadableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
+checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
checkSeekableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
+ioe_finalizedHandle :: FilePath -> Handle__
ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
"handle is finalized" (Just fp))
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
+checkBufferInvariants :: Handle__ -> IO ()
#ifdef DEBUG
checkBufferInvariants h_ = do
let ref = haBuffer h_
then error "buffer invariant violation"
else return ()
#else
-checkBufferInvariants h_ = return ()
+checkBufferInvariants _ = return ()
#endif
newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
-- We sometimes need to pass the address of this buffer to
-- a "safe" foreign call, hence it must be immovable.
- case newPinnedByteArray# size s of { (# s, b #) ->
- (# s, newEmptyBuffer b state sz #) }
+ case newPinnedByteArray# size s of { (# s', b #) ->
+ (# s', newEmptyBuffer b state sz #) }
writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
writeCharIntoBuffer slab (I# off) (C# c)
= IO $ \s -> case writeCharArray# slab off c s of
- s -> (# s, I# (off +# 1#) #)
+ 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
-- appears to be what GHC has done for a long time, and I suspect it
-- is more useful than line buffering in most cases.
+fillReadBufferLoop :: FD -> Bool -> Bool -> Buffer -> RawBuffer -> Int -> Int
+ -> IO Buffer
fillReadBufferLoop fd is_line is_stream buf b w size = do
let bytes = size - w
if bytes == 0 -- buffer full?
-- or output channel respectively. The third manages output to the
-- standard error channel. These handles are initially open.
-fd_stdin = 0 :: FD
-fd_stdout = 1 :: FD
-fd_stderr = 2 :: FD
+fd_stdin, fd_stdout, fd_stderr :: FD
+fd_stdin = 0
+fd_stdout = 1
+fd_stderr = 2
-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
addFilePathToIOError fun fp (IOError h iot _ str _)
= IOError h iot fun str (Just fp)
(openFile' fp m True)
(\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
+openFile' :: String -> IOMode -> Bool -> IO Handle
openFile' filepath mode binary =
withCString filepath $ \ f ->
return h
+std_flags, output_flags, read_flags, write_flags, rw_flags,
+ append_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
read_flags = std_flags .|. o_RDONLY
addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
-
+initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
Nothing -> return ()
Just e -> throwIO e
+hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
hClose' h m = withHandle' "hClose" h m $ hClose_help
-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
maybe_exception)
{-# NOINLINE noBuffer #-}
+noBuffer :: Buffer
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
hLookAhead' handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
- is_line = haBufferMode handle_ == LineBuffering
buf <- readIORef ref
-- fill up the read buffer if necessary
Just r -> withHandle_' "dupHandle" h r (return . haFD)
dupHandle_ other_side h_ new_fd
+dupHandleTo :: Maybe (MVar Handle__) -> Handle__ -> Handle__
+ -> IO (Handle__, Handle__)
dupHandleTo other_side hto_ h_ = do
flushBuffer h_
-- Windows' dup2 does not return the new descriptor, unlike Unix
hShow h@(FileHandle path _) = showHandle' path False h
hShow h@(DuplexHandle path _ _) = showHandle' path True h
+showHandle' :: String -> Bool -> Handle -> IO String
showHandle' filepath is_duplex h =
withHandle_ "showHandle" h $ \hdl_ ->
let
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
+hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char
+hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w }
+ = do (c, r) <- readCharFromBuffer b r0
let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
| otherwise = buf{ bufRPtr=r }
writeIORef ref new_buf
hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
-> IO String
hGetLineBufferedLoop handle_ ref
- buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
+ buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } xss =
let
-- find the end-of-line character, if there is one
loop raw r
then return (True, r) -- NB. not r': don't include the '\n'
else loop raw r'
in do
- (eol, off) <- loop raw r
+ (eol, off) <- loop raw0 r0
#ifdef DEBUG_DUMP
- puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
+ puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
#endif
- xs <- unpack raw r off
+ xs <- unpack raw0 r0 off
-- if eol == True, then off is the offset of the '\n'
-- otherwise off == w and the buffer is now empty.
Just new_buf ->
hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
-
+maybeFillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO (Maybe Buffer)
maybeFillReadBuffer fd is_line is_stream buf
= catch
- (do buf <- fillReadBuffer fd is_line is_stream buf
- return (Just buf)
+ (do buf' <- fillReadBuffer fd is_line is_stream buf
+ return (Just buf')
)
(\e -> do if isEOFError e
then return Nothing
unpack :: RawBuffer -> Int -> Int -> IO [Char]
-unpack buf r 0 = return ""
-unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s
+unpack _ _ 0 = return ""
+unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s
where
- unpack acc i s
+ unpackRB acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+ (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'
hGetLineUnBuffered :: Handle -> IO String
(IOError (Just handle) IllegalOperation "lazyRead"
"illegal handle type" Nothing)
+lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyRead' h handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
let raw = bufBuf buf
r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
if r == 0
- then do (handle_,_) <- hClose_help handle_
- return (handle_, "")
+ then do (handle_', _) <- hClose_help handle_
+ return (handle_', "")
else do (c,_) <- readCharFromBuffer raw 0
rest <- lazyRead h
return (handle_, c : rest)
-- we never want to block during the read, so we call fillReadBuffer with
-- is_line==True, which tells it to "just read what there is".
+lazyReadBuffered :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer
+ -> IO (Handle__, [Char])
lazyReadBuffered h handle_ fd ref buf = do
catch
- (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
- lazyReadHaveBuffer h handle_ fd ref buf
+ (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 (handle_', _) <- hClose_help handle_
+ return (handle_', "")
)
-lazyReadHaveBuffer h handle_ fd ref buf = do
+lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char])
+lazyReadHaveBuffer h handle_ _ ref buf = do
more <- lazyRead h
writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc buf r 0 acc = return acc
-unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s
+unpackAcc _ _ 0 acc = return acc
+unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s
where
- unpack acc i s
+ unpackRB acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
- (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s
+ (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s'
-- ---------------------------------------------------------------------------
-- hPutChar
writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
return ()
+hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
hPutcBuffered handle_ is_line c = do
let ref = haBuffer handle_
buf <- readIORef ref
hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
+hPutChars _ [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-- ---------------------------------------------------------------------------
--
-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
--
+commitBuffer' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__
+ -> IO Buffer
commitBuffer' raw sz@(I# _) count@(I# _) flush release
handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
#endif
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+ old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
<- readIORef ref
buf_ret <-
| count < 0 = illegalBufferSize handle "hPutBuf" count
| otherwise =
wantWritableHandle "hPutBuf" handle $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
+ \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } ->
bufWrite fd ref is_stream ptr count can_block
+bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int
bufWrite fd ref is_stream ptr count can_block =
seq count $ seq fd $ do -- strictness hack
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
+ old_buf@Buffer{ bufBuf=old_raw, bufWPtr=w, bufSize=size }
<- readIORef ref
-- enough room in handle buffer?
else writeChunkNonBlocking fd is_stream ptr count
writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
-writeChunk fd is_stream ptr bytes = loop 0 bytes
+writeChunk fd is_stream ptr bytes0 = loop 0 bytes0
where
loop :: Int -> Int -> IO ()
loop _ bytes | bytes <= 0 = return ()
loop (off + r) (bytes - r)
writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
-writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
+writeChunkNonBlocking fd
+#ifndef mingw32_HOST_OS
+ _
+#else
+ is_stream
+#endif
+ ptr bytes0 = loop 0 bytes0
where
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle "hGetBuf" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
+ \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
bufRead fd ref is_stream ptr 0 count
-- small reads go through the buffer, large reads are satisfied by
-- taking data first from the buffer and then direct from the file
-- descriptor.
+bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int
bufRead fd ref is_stream ptr so_far count =
seq fd $ seq so_far $ seq count $ do -- strictness hack
buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
return (so_far' + rest)
readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
-readChunk fd is_stream ptr bytes = loop 0 bytes
+readChunk fd is_stream ptr bytes0 = loop 0 bytes0
where
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
| count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
| otherwise =
wantReadableHandle "hGetBufNonBlocking" h $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
+ \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do
bufReadNonBlocking fd ref is_stream ptr 0 count
+bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int
+ -> IO Int
bufReadNonBlocking fd ref is_stream ptr so_far count =
seq fd $ seq so_far $ seq count $ do -- strictness hack
buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
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)
+ 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_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.
#endif
import GHC.Num
import GHC.Real
-import GHC.Float
+import GHC.Float ()
import GHC.Show
import GHC.Base
import GHC.Arr
enumFromThenTo = integralEnumFromThenTo
instance Integral Word64 where
- quot x@(W64# x#) y@(W64# y#)
+ quot (W64# x#) y@(W64# y#)
| y /= 0 = W64# (x# `quotWord64#` y#)
| otherwise = divZeroError
- rem x@(W64# x#) y@(W64# y#)
+ rem (W64# x#) y@(W64# y#)
| y /= 0 = W64# (x# `remWord64#` y#)
| otherwise = divZeroError
- div x@(W64# x#) y@(W64# y#)
+ div (W64# x#) y@(W64# y#)
| y /= 0 = W64# (x# `quotWord64#` y#)
| otherwise = divZeroError
- mod x@(W64# x#) y@(W64# y#)
+ mod (W64# x#) y@(W64# y#)
| y /= 0 = W64# (x# `remWord64#` y#)
| otherwise = divZeroError
- quotRem x@(W64# x#) y@(W64# y#)
+ quotRem (W64# x#) y@(W64# y#)
| y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
| otherwise = divZeroError
- divMod x@(W64# x#) y@(W64# y#)
+ divMod (W64# x#) y@(W64# y#)
| y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
| otherwise = divZeroError
toInteger (W64# x#) = word64ToInteger x#
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.Exception ( throw )
import Text.Read
import GHC.Enum
import GHC.Num
import Data.Maybe
import Foreign.C.Error
import Foreign.C.String
+import Foreign.C.Types
import System.Posix.Internals
#endif
#ifndef __NHC__
-- XXX Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
-read_flags = std_flags .|. o_RDONLY
-write_flags = output_flags .|. o_WRONLY
rw_flags = output_flags .|. o_RDWR
-append_flags = write_flags .|. o_APPEND
#endif
#ifdef __NHC__
fdType :: FD -> IO FDType
fdType fd = do (ty,_,_) <- fdStat fd; return ty
+statGetType :: Ptr CStat -> IO FDType
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
| s_isblk c_mode -> return RawDevice
| otherwise -> ioError ioe_unknownfiletype
-
+ioe_unknownfiletype :: IOException
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
"unknown file type" Nothing
setEcho :: FD -> Bool -> IO ()
setEcho fd on = do
tcSetAttr fd $ \ p_tios -> do
- c_lflag <- c_lflag p_tios :: IO CTcflag
- let new_c_lflag
- | on = c_lflag .|. fromIntegral const_echo
- | otherwise = c_lflag .&. complement (fromIntegral const_echo)
- poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+ lflag <- c_lflag p_tios :: IO CTcflag
+ let new_lflag
+ | on = lflag .|. fromIntegral const_echo
+ | otherwise = lflag .&. complement (fromIntegral const_echo)
+ poke_c_lflag p_tios (new_lflag :: CTcflag)
getEcho :: FD -> IO Bool
getEcho fd = do
tcSetAttr fd $ \ p_tios -> do
- c_lflag <- c_lflag p_tios :: IO CTcflag
- return ((c_lflag .&. fromIntegral const_echo) /= 0)
+ lflag <- c_lflag p_tios :: IO CTcflag
+ return ((lflag .&. fromIntegral const_echo) /= 0)
setCooked :: FD -> Bool -> IO ()
setCooked fd cooked =
tcSetAttr fd $ \ p_tios -> do
-- turn on/off ICANON
- c_lflag <- c_lflag p_tios :: IO CTcflag
- let new_c_lflag | cooked = c_lflag .|. (fromIntegral const_icanon)
- | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
- poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+ lflag <- c_lflag p_tios :: IO CTcflag
+ let new_lflag | cooked = lflag .|. (fromIntegral const_icanon)
+ | otherwise = lflag .&. complement (fromIntegral const_icanon)
+ poke_c_lflag p_tios (new_lflag :: CTcflag)
-- set VMIN & VTIME to 1/0 respectively
when (not cooked) $ do
-- Turning on non-blocking for a file descriptor
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
+setNonBlockingFD :: FD -> IO ()
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
(c_fcntl_read fd const_f_getfl)
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Types
ForeignFunctionInterface, UnliftedFFITypes,
DeriveDataTypeable, GeneralizedNewtypeDeriving,
FlexibleInstances, PatternSignatures, StandaloneDeriving,
- PatternGuards
+ PatternGuards, EmptyDataDecls
}
exposed-modules:
Control.Applicative,
#if !defined(__MINGW32__)
INLINE int hsFD_SETSIZE(void) { return FD_SETSIZE; }
-INLINE void hsFD_CLR(int fd, fd_set *fds) { FD_CLR(fd, fds); }
INLINE int hsFD_ISSET(int fd, fd_set *fds) { return FD_ISSET(fd, fds); }
INLINE void hsFD_SET(int fd, fd_set *fds) { FD_SET(fd, fds); }
INLINE HsInt sizeof_fd_set(void) { return sizeof(fd_set); }
projects / ghc-base.git / commitdiff