projects
/
ghc-base.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (from parent 1:
5c99290
)
Fix some more warnings
author
Ian Lynagh
<igloo@earth.li>
Wed, 20 Aug 2008 22:32:52 +0000
(22:32 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Wed, 20 Aug 2008 22:32:52 +0000
(22:32 +0000)
14 files changed:
Control/Exception/Base.hs
patch
|
blob
|
history
Foreign/Marshal/Alloc.hs
patch
|
blob
|
history
Foreign/Marshal/Array.hs
patch
|
blob
|
history
GHC/Conc.lhs
patch
|
blob
|
history
GHC/Handle.hs
patch
|
blob
|
history
GHC/IO.hs
patch
|
blob
|
history
GHC/Read.lhs
patch
|
blob
|
history
GHC/Word.hs
patch
|
blob
|
history
Prelude.hs
patch
|
blob
|
history
System/IO.hs
patch
|
blob
|
history
System/Posix/Internals.hs
patch
|
blob
|
history
System/Posix/Types.hs
patch
|
blob
|
history
base.cabal
patch
|
blob
|
history
include/HsBase.h
patch
|
blob
|
history
diff --git
a/Control/Exception/Base.hs
b/Control/Exception/Base.hs
index
c8f4d09
..
b6893fb
100644
(file)
--- a/
Control/Exception/Base.hs
+++ b/
Control/Exception/Base.hs
@@
-1,4
+1,5
@@
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "Typeable.h"
#include "Typeable.h"
@@
-106,7
+107,6
@@
module Control.Exception.Base (
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.List
import GHC.Show
import GHC.IOBase
import GHC.Exception hiding ( Exception )
import GHC.Show
import GHC.IOBase
import GHC.Exception hiding ( Exception )
diff --git
a/Foreign/Marshal/Alloc.hs
b/Foreign/Marshal/Alloc.hs
index
9911718
..
9fd576d
100644
(file)
--- a/
Foreign/Marshal/Alloc.hs
+++ b/
Foreign/Marshal/Alloc.hs
@@
-109,14
+109,14
@@
alloca = doAlloca undefined
--
#ifdef __GLASGOW_HASKELL__
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
--
#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
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
}}}}}
#else
allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
diff --git
a/Foreign/Marshal/Array.hs
b/Foreign/Marshal/Array.hs
index
ce28ddb
..
2297a4d
100644
(file)
--- a/
Foreign/Marshal/Array.hs
+++ b/
Foreign/Marshal/Array.hs
@@
-152,8
+152,8
@@
pokeArray :: Storable a => Ptr a -> [a] -> IO ()
#ifndef __GLASGOW_HASKELL__
pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals
#else
#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
go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
@@
-166,7
+166,7
@@
pokeArray0 marker ptr vals = do
pokeArray ptr vals
pokeElemOff ptr (length vals) marker
#else
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
where go [] n# = pokeElemOff ptr (I# n#) marker
go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
diff --git
a/GHC/Conc.lhs
b/GHC/Conc.lhs
index
6ae157e
..
f2875be
100644
(file)
--- a/
GHC/Conc.lhs
+++ b/
GHC/Conc.lhs
@@
-205,7
+205,7
@@
GHC note: the new thread inherits the /blocked/ state of the parent
-}
forkIO :: IO () -> IO ThreadId
forkIO action = IO $ \ s ->
-}
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
where
action_plus = catchException action childHandler
@@
-224,7
+224,7
@@
equivalent).
-}
forkOnIO :: Int -> IO () -> IO ThreadId
forkOnIO (I# cpu) action = IO $ \ s ->
-}
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
where
action_plus = catchException action childHandler
@@
-300,13
+300,13
@@
a pending 'throwTo'. This is arguably undesirable behaviour.
-}
throwTo :: Exception e => ThreadId -> e -> IO ()
-}
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 ->
-- | 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
-- |The 'yield' action allows (forces, in a co-operative multitasking
@@
-439,7
+439,7
@@
bindSTM (STM m) k = STM ( \s ->
thenSTM :: STM a -> STM b -> STM b
thenSTM (STM m) k = STM ( \s ->
case m s of
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
)
returnSTM :: a -> STM a
@@
-634,8
+634,8
@@
putMVar (MVar mvar#) x = IO $ \ s# ->
tryTakeMVar :: MVar a -> IO (Maybe a)
tryTakeMVar (MVar m) = IO $ \ s ->
case tryTakeMVar# m s of
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
-- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
@@
-661,7
+661,7
@@
isEmptyMVar (MVar mv#) = IO $ \ s# ->
-- "System.Mem.Weak" for more about finalizers.
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) finalizer =
-- "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 =
withMVar :: MVar a -> (a -> IO b) -> IO b
withMVar m io =
@@
-730,7
+730,7
@@
threadWaitRead fd
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
#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
}}
-- | Block the current thread until data can be written to the
@@
-742,7
+742,7
@@
threadWaitWrite fd
#endif
| otherwise = IO $ \s ->
case fromIntegral fd of { I# fd# ->
#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
}}
-- | Suspends the current thread for a given number of microseconds
@@
-757,7
+757,7
@@
threadDelay time
| threaded = waitForDelayEvent time
| otherwise = IO $ \s ->
case fromIntegral time of { I# time# ->
| 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', () #)
}}
}}
@@
-1045,7
+1045,7
@@
service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
-- pick up new delay requests
new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a))
-- 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
-- build the FDSets for select()
fdZero readfds
@@
-1078,7
+1078,7
@@
service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
else
return (False,delays')
else
return (False,delays')
- (wakeup_all,delays') <- do_select delays
+ (wakeup_all,delays') <- do_select delays0
exit <-
if wakeup_all then return False
exit <-
if wakeup_all then return False
@@
-1108,8
+1108,9
@@
service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
service_loop wakeup readfds writefds ptimeval reqs' delays'
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 #-}
stick :: IORef Fd
{-# NOINLINE stick #-}
@@
-1135,18
+1136,21
@@
foreign import ccall "setIOManagerPipe"
-- -----------------------------------------------------------------------------
-- IO requests
-- -----------------------------------------------------------------------------
-- 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
| 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
| 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
completeRequests [] _ _ reqs' = return reqs'
completeRequests (Read fd m : reqs) readfds writefds reqs' = do
b <- fdIsSet fd readfds
@@
-1159,9
+1163,10
@@
completeRequests (Write fd m : reqs) readfds writefds reqs' = do
then do putMVar m (); completeRequests reqs readfds writefds reqs'
else completeRequests reqs readfds writefds (Write fd m : reqs')
then do putMVar m (); completeRequests reqs readfds writefds reqs'
else completeRequests reqs readfds writefds (Write fd m : reqs')
+wakeupAll :: [IOReq] -> IO ()
wakeupAll [] = return ()
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
waitForReadEvent :: Fd -> IO ()
waitForReadEvent fd = do
@@
-1184,7
+1189,7
@@
waitForWriteEvent 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)
-- 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
getDelay now ptimeval all@(d : rest)
= case d of
Delay time m | now >= time -> do
@@
-1197,7
+1202,7
@@
getDelay now ptimeval all@(d : rest)
setTimevalTicks ptimeval (delayTime d - now)
return (all,ptimeval)
setTimevalTicks ptimeval (delayTime d - now)
return (all,ptimeval)
-newtype CTimeVal = CTimeVal ()
+data CTimeVal
foreign import ccall unsafe "sizeofTimeVal"
sizeofTimeVal :: Int
foreign import ccall unsafe "sizeofTimeVal"
sizeofTimeVal :: Int
@@
-1216,7
+1221,7
@@
foreign import ccall unsafe "setTimevalTicks"
-- ToDo: move to System.Posix.Internals?
-- 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
foreign import ccall safe "select"
c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal
@@
-1228,12
+1233,6
@@
foreign import ccall unsafe "hsFD_SETSIZE"
fD_SETSIZE :: Fd
fD_SETSIZE = fromIntegral c_fD_SETSIZE
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
foreign import ccall unsafe "hsFD_ISSET"
c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt
diff --git
a/GHC/Handle.hs
b/GHC/Handle.hs
index
e94d2d5
..
2876260
100644
(file)
--- a/
GHC/Handle.hs
+++ b/
GHC/Handle.hs
@@
-74,7
+74,7
@@
import GHC.List
import GHC.IOBase
import GHC.Exception
import GHC.Enum
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
import GHC.Show
#if defined(DEBUG_DUMP)
import GHC.Pack
@@
-96,7
+96,8
@@
import GHC.Conc
-- Are files opened by default in text or binary mode, if the user doesn't
-- specify?
-- 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
-- ---------------------------------------------------------------------------
-- Creating a new handle
@@
-171,6
+172,8
@@
withAllHandles__ fun h@(DuplexHandle _ r w) act = do
withHandle__' fun h r act
withHandle__' fun h w act
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
withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
@@
-181,13
+184,14
@@
withHandle__' fun h m act =
putMVar m h'
return ()
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
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.
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
@@
-205,6
+209,7
@@
wantWritableHandle'
wantWritableHandle' fun h m act
= withHandle_' fun h m (checkWritableHandle act)
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
checkWritableHandle act handle_
= case haType handle_ of
ClosedHandle -> ioe_closedHandle
@@
-238,6
+243,7
@@
wantReadableHandle'
wantReadableHandle' fun h m act
= withHandle_' fun h m (checkReadableHandle act)
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
checkReadableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
@@
-263,6
+269,7
@@
wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
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
checkSeekableHandle act handle_ =
case haType handle_ of
ClosedHandle -> ioe_closedHandle
@@
-297,6
+304,7
@@
ioe_notSeekable_notBin = ioException
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
"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))
ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
"handle is finalized" (Just fp))
@@
-344,6
+352,7
@@
handleFinalizer fp m = do
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
+checkBufferInvariants :: Handle__ -> IO ()
#ifdef DEBUG
checkBufferInvariants h_ = do
let ref = haBuffer h_
#ifdef DEBUG
checkBufferInvariants h_ = do
let ref = haBuffer h_
@@
-359,7
+368,7
@@
checkBufferInvariants h_ = do
then error "buffer invariant violation"
else return ()
#else
then error "buffer invariant violation"
else return ()
#else
-checkBufferInvariants h_ = return ()
+checkBufferInvariants _ = return ()
#endif
newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
#endif
newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
@@
-370,18
+379,18
@@
allocateBuffer :: Int -> BufferState -> IO Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
-- We sometimes need to pass the address of this buffer to
-- a "safe" foreign call, hence it must be immovable.
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
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
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
getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
getBuffer fd state = do
@@
-472,6
+481,8
@@
fillReadBuffer fd is_line is_stream
-- appears to be what GHC has done for a long time, and I suspect it
-- is more useful than line buffering in most cases.
-- 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?
fillReadBufferLoop fd is_line is_stream buf b w size = do
let bytes = size - w
if bytes == 0 -- buffer full?
@@
-775,9
+786,10
@@
foreign import ccall safe "__hscore_PrelHandle_write"
-- or output channel respectively. The third manages output to the
-- standard error channel. These handles are initially open.
-- 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
-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
@@
-812,6
+824,7
@@
stderr = unsafePerformIO $ do
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
addFilePathToIOError fun fp (IOError h iot _ str _)
= IOError h iot fun str (Just fp)
addFilePathToIOError fun fp (IOError h iot _ str _)
= IOError h iot fun str (Just fp)
@@
-862,6
+875,7
@@
openBinaryFile fp m =
(openFile' fp m True)
(\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
(openFile' fp m True)
(\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
+openFile' :: String -> IOMode -> Bool -> IO Handle
openFile' filepath mode binary =
withCString filepath $ \ f ->
openFile' filepath mode binary =
withCString filepath $ \ f ->
@@
-913,6
+927,8
@@
openFile' filepath mode binary =
return h
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
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
read_flags = std_flags .|. o_RDONLY
@@
-1090,7
+1106,7
@@
mkDuplexHandle fd is_stream filepath binary = do
addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
-
+initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
@@
-1119,6
+1135,7
@@
hClose h@(DuplexHandle _ r w) = do
Nothing -> return ()
Just e -> throwIO e
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
hClose' h m = withHandle' "hClose" h m $ hClose_help
-- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
@@
-1175,6
+1192,7
@@
hClose_handle_ handle_ = do
maybe_exception)
{-# NOINLINE noBuffer #-}
maybe_exception)
{-# NOINLINE noBuffer #-}
+noBuffer :: Buffer
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
@@
-1252,7
+1270,6
@@
hLookAhead' :: Handle__ -> IO Char
hLookAhead' handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
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
buf <- readIORef ref
-- fill up the read buffer if necessary
@@
-1660,6
+1677,8
@@
dupHandle h other_side h_ = do
Just r -> withHandle_' "dupHandle" h r (return . haFD)
dupHandle_ other_side h_ new_fd
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
dupHandleTo other_side hto_ h_ = do
flushBuffer h_
-- Windows' dup2 does not return the new descriptor, unlike Unix
@@
-1719,6
+1738,7
@@
hShow :: Handle -> IO String
hShow h@(FileHandle path _) = showHandle' path False h
hShow h@(DuplexHandle path _ _) = showHandle' path True h
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
showHandle' filepath is_duplex h =
withHandle_ "showHandle" h $ \hdl_ ->
let
diff --git
a/GHC/IO.hs
b/GHC/IO.hs
index
a5e34f2
..
f0d2fc1
100644
(file)
--- a/
GHC/IO.hs
+++ b/
GHC/IO.hs
@@
-143,8
+143,9
@@
hGetChar handle =
else do (c,_) <- readCharFromBuffer raw 0
return c
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
let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
| otherwise = buf{ bufRPtr=r }
writeIORef ref new_buf
@@
-192,7
+193,7
@@
hGetLineBuffered handle_ = do
hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String]
-> IO String
hGetLineBufferedLoop handle_ ref
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
let
-- find the end-of-line character, if there is one
loop raw r
@@
-203,13
+204,13
@@
hGetLineBufferedLoop handle_ ref
then return (True, r) -- NB. not r': don't include the '\n'
else loop raw r'
in do
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
#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
#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.
-- if eol == True, then off is the offset of the '\n'
-- otherwise off == w and the buffer is now empty.
@@
-233,11
+234,11
@@
hGetLineBufferedLoop handle_ ref
Just new_buf ->
hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
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
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
)
(\e -> do if isEOFError e
then return Nothing
@@
-245,14
+246,14
@@
maybeFillReadBuffer fd is_line is_stream buf
unpack :: RawBuffer -> Int -> Int -> IO [Char]
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
where
- unpack acc i s
+ unpackRB acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
| 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
hGetLineUnBuffered :: Handle -> IO String
@@
-340,6
+341,7
@@
lazyRead handle =
(IOError (Just handle) IllegalOperation "lazyRead"
"illegal handle type" Nothing)
(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_
lazyRead' h handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
@@
-357,8
+359,8
@@
lazyRead' h handle_ = do
let raw = bufBuf buf
r <- readRawBuffer "lazyRead" fd (haIsStream handle_) raw 0 1
if r == 0
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)
else do (c,_) <- readCharFromBuffer raw 0
rest <- lazyRead h
return (handle_, c : rest)
@@
-368,17
+370,20
@@
lazyRead' h handle_ = do
-- 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".
-- 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
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.
)
-- 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
more <- lazyRead h
writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
@@
-386,14
+391,14
@@
lazyReadHaveBuffer h handle_ fd ref buf = do
unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
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
where
- unpack acc i s
+ unpackRB acc i s
| i <# r = (# s, acc #)
| otherwise =
case readCharArray# buf i s of
| 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
-- ---------------------------------------------------------------------------
-- hPutChar
@@
-421,6
+426,7
@@
hPutChar handle c = do
writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
return ()
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
hPutcBuffered handle_ is_line c = do
let ref = haBuffer handle_
buf <- readIORef ref
@@
-436,7
+442,7
@@
hPutcBuffered handle_ is_line c = do
hPutChars :: Handle -> [Char] -> IO ()
hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
+hPutChars _ [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-- ---------------------------------------------------------------------------
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-- ---------------------------------------------------------------------------
@@
-583,6
+589,8
@@
commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do
--
-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
--
--
-- 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
commitBuffer' raw sz@(I# _) count@(I# _) flush release
handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
@@
-591,7
+599,7
@@
commitBuffer' raw sz@(I# _) count@(I# _) flush release
++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
#endif
++ ", 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 <-
<- readIORef ref
buf_ret <-
@@
-688,12
+696,13
@@
hPutBuf' handle ptr count can_block
| count < 0 = illegalBufferSize handle "hPutBuf" count
| otherwise =
wantWritableHandle "hPutBuf" handle $
| 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 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
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?
<- readIORef ref
-- enough room in handle buffer?
@@
-717,7
+726,7
@@
bufWrite fd ref is_stream ptr count can_block =
else writeChunkNonBlocking fd is_stream ptr count
writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
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 ()
where
loop :: Int -> Int -> IO ()
loop _ bytes | bytes <= 0 = return ()
@@
-729,7
+738,13
@@
writeChunk fd is_stream ptr bytes = loop 0 bytes
loop (off + r) (bytes - r)
writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
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
where
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
@@
-775,12
+790,13
@@
hGetBuf h ptr count
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle "hGetBuf" h $
| 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 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
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
@@
-823,7
+839,7
@@
bufRead fd ref is_stream ptr so_far count =
return (so_far' + rest)
readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int
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
where
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
@@
-855,9
+871,11
@@
hGetBufNonBlocking h ptr count
| count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
| otherwise =
wantReadableHandle "hGetBufNonBlocking" h $
| 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 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
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
@@
-866,13
+884,13
@@
bufReadNonBlocking fd ref is_stream ptr so_far count =
then do rest <- readChunkNonBlocking fd is_stream ptr count
return (so_far + rest)
else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf
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
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.
-- so we will just copy the contents of the
-- buffer in the recursive call, and not
-- loop again.
diff --git
a/GHC/Read.lhs
b/GHC/Read.lhs
index
b890b46
..
f99e2df
100644
(file)
--- a/
GHC/Read.lhs
+++ b/
GHC/Read.lhs
@@
-67,7
+67,7
@@
import {-# SOURCE #-} GHC.Unicode ( isDigit )
#endif
import GHC.Num
import GHC.Real
#endif
import GHC.Num
import GHC.Real
-import GHC.Float
+import GHC.Float ()
import GHC.Show
import GHC.Base
import GHC.Arr
import GHC.Show
import GHC.Base
import GHC.Arr
diff --git
a/GHC/Word.hs
b/GHC/Word.hs
index
4af74fa
..
68afadf
100644
(file)
--- a/
GHC/Word.hs
+++ b/
GHC/Word.hs
@@
-690,22
+690,22
@@
instance Enum Word64 where
enumFromThenTo = integralEnumFromThenTo
instance Integral Word64 where
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
| 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
| 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
| 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
| 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
| 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#
| y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
| otherwise = divZeroError
toInteger (W64# x#) = word64ToInteger x#
diff --git
a/Prelude.hs
b/Prelude.hs
index
050da04
..
4f01b9f
100644
(file)
--- a/
Prelude.hs
+++ b/
Prelude.hs
@@
-155,7
+155,6
@@
import Data.Tuple
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.Exception ( throw )
import Text.Read
import GHC.Enum
import GHC.Num
import Text.Read
import GHC.Enum
import GHC.Num
diff --git
a/System/IO.hs
b/System/IO.hs
index
3d3893d
..
0142d10
100644
(file)
--- a/
System/IO.hs
+++ b/
System/IO.hs
@@
-169,6
+169,7
@@
import Data.List
import Data.Maybe
import Foreign.C.Error
import Foreign.C.String
import Data.Maybe
import Foreign.C.Error
import Foreign.C.String
+import Foreign.C.Types
import System.Posix.Internals
#endif
import System.Posix.Internals
#endif
@@
-510,12
+511,10
@@
pathSeparator = '/'
#ifndef __NHC__
-- XXX Copied from GHC.Handle
#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
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
rw_flags = output_flags .|. o_RDWR
-append_flags = write_flags .|. o_APPEND
#endif
#ifdef __NHC__
#endif
#ifdef __NHC__
diff --git
a/System/Posix/Internals.hs
b/System/Posix/Internals.hs
index
5b9eb95
..
0b4f7d4
100644
(file)
--- a/
System/Posix/Internals.hs
+++ b/
System/Posix/Internals.hs
@@
-112,6
+112,7
@@
fdStat fd =
fdType :: FD -> IO FDType
fdType fd = do (ty,_,_) <- fdStat fd; return ty
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
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
@@
-123,7
+124,7
@@
statGetType p_stat = do
| s_isblk c_mode -> return RawDevice
| otherwise -> ioError ioe_unknownfiletype
| s_isblk c_mode -> return RawDevice
| otherwise -> ioError ioe_unknownfiletype
-
+ioe_unknownfiletype :: IOException
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
"unknown file type" Nothing
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
"unknown file type" Nothing
@@
-171,27
+172,27
@@
fdIsTTY fd = c_isatty fd >>= return.toBool
setEcho :: FD -> Bool -> IO ()
setEcho fd on = do
tcSetAttr fd $ \ p_tios -> do
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
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
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
-- set VMIN & VTIME to 1/0 respectively
when (not cooked) $ do
@@
-293,7
+294,7
@@
foreign import ccall unsafe "consUtils.h get_console_echo__"
-- Turning on non-blocking for a file descriptor
#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-- 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)
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
(c_fcntl_read fd const_f_getfl)
diff --git
a/System/Posix/Types.hs
b/System/Posix/Types.hs
index
14fdcf8
..
1935179
100644
(file)
--- a/
System/Posix/Types.hs
+++ b/
System/Posix/Types.hs
@@
-1,4
+1,5
@@
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Types
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Types
diff --git
a/base.cabal
b/base.cabal
index
b17a05e
..
7871047
100644
(file)
--- a/
base.cabal
+++ b/
base.cabal
@@
-66,7
+66,7
@@
Library {
ForeignFunctionInterface, UnliftedFFITypes,
DeriveDataTypeable, GeneralizedNewtypeDeriving,
FlexibleInstances, PatternSignatures, StandaloneDeriving,
ForeignFunctionInterface, UnliftedFFITypes,
DeriveDataTypeable, GeneralizedNewtypeDeriving,
FlexibleInstances, PatternSignatures, StandaloneDeriving,
- PatternGuards
+ PatternGuards, EmptyDataDecls
}
exposed-modules:
Control.Applicative,
}
exposed-modules:
Control.Applicative,
diff --git
a/include/HsBase.h
b/include/HsBase.h
index
f69e9cf
..
63b0d5c
100644
(file)
--- a/
include/HsBase.h
+++ b/
include/HsBase.h
@@
-691,7
+691,6
@@
INLINE int __hscore_fstat(int fd, struct_stat *buf) {
#if !defined(__MINGW32__)
INLINE int hsFD_SETSIZE(void) { return FD_SETSIZE; }
#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); }
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); }