summaryrefslogtreecommitdiff
path: root/libraries
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2008-08-20 22:32:52 +0000
committerIan Lynagh <igloo@earth.li>2008-08-20 22:32:52 +0000
commitcff5e3cb247cd2241ec95838ebb8bee3c677b0c0 (patch)
tree39a0d28a2c8ffdafc158a3596e982408db407953 /libraries
parent48612e58abc0b46b3a8a0f897e1edc5536313c3a (diff)
downloadhaskell-cff5e3cb247cd2241ec95838ebb8bee3c677b0c0.tar.gz
Fix some more warnings
Diffstat (limited to 'libraries')
-rw-r--r--libraries/base/Control/Exception/Base.hs2
-rw-r--r--libraries/base/Foreign/Marshal/Alloc.hs14
-rw-r--r--libraries/base/Foreign/Marshal/Array.hs6
-rw-r--r--libraries/base/GHC/Conc.lhs59
-rw-r--r--libraries/base/GHC/Handle.hs48
-rw-r--r--libraries/base/GHC/IO.hs92
-rw-r--r--libraries/base/GHC/Read.lhs2
-rw-r--r--libraries/base/GHC/Word.hs12
-rw-r--r--libraries/base/Prelude.hs1
-rw-r--r--libraries/base/System/IO.hs5
-rw-r--r--libraries/base/System/Posix/Internals.hs27
-rw-r--r--libraries/base/System/Posix/Types.hs1
-rw-r--r--libraries/base/base.cabal2
-rw-r--r--libraries/base/include/HsBase.h1
14 files changed, 154 insertions, 118 deletions
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index c8f4d09e3e..b6893fb2d9 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "Typeable.h"
@@ -106,7 +107,6 @@ module Control.Exception.Base (
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.List
import GHC.Show
import GHC.IOBase
import GHC.Exception hiding ( Exception )
diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs
index 9911718256..9fd576d365 100644
--- a/libraries/base/Foreign/Marshal/Alloc.hs
+++ b/libraries/base/Foreign/Marshal/Alloc.hs
@@ -109,14 +109,14 @@ alloca = doAlloca undefined
--
#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
diff --git a/libraries/base/Foreign/Marshal/Array.hs b/libraries/base/Foreign/Marshal/Array.hs
index ce28ddb573..2297a4ddd2 100644
--- a/libraries/base/Foreign/Marshal/Array.hs
+++ b/libraries/base/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
-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
@@ -166,7 +166,7 @@ pokeArray0 marker ptr vals = do
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
diff --git a/libraries/base/GHC/Conc.lhs b/libraries/base/GHC/Conc.lhs
index 6ae157edb6..f2875bea1c 100644
--- a/libraries/base/GHC/Conc.lhs
+++ b/libraries/base/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 ->
- 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
@@ -224,7 +224,7 @@ equivalent).
-}
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
@@ -300,13 +300,13 @@ a pending 'throwTo'. This is arguably undesirable behaviour.
-}
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
@@ -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
- (# new_s, a #) -> unSTM k new_s
+ (# new_s, _ #) -> unSTM k new_s
)
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
- (# 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
@@ -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 =
- 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 =
@@ -730,7 +730,7 @@ threadWaitRead 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
@@ -742,7 +742,7 @@ threadWaitWrite 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
@@ -757,7 +757,7 @@ threadDelay 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))
- let delays = foldr insertDelay old_delays new_delays
+ let delays0 = foldr insertDelay old_delays new_delays
-- 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')
- (wakeup_all,delays') <- do_select delays
+ (wakeup_all,delays') <- do_select delays0
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'
-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 #-}
@@ -1135,18 +1136,21 @@ foreign import ccall "setIOManagerPipe"
-- -----------------------------------------------------------------------------
-- 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
@@ -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')
+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
@@ -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)
-getDelay now ptimeval [] = return ([],nullPtr)
+getDelay _ _ [] = return ([],nullPtr)
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)
-newtype CTimeVal = CTimeVal ()
+data CTimeVal
foreign import ccall unsafe "sizeofTimeVal"
sizeofTimeVal :: Int
@@ -1216,7 +1221,7 @@ foreign import ccall unsafe "setTimevalTicks"
-- 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
@@ -1228,12 +1233,6 @@ foreign import ccall unsafe "hsFD_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
diff --git a/libraries/base/GHC/Handle.hs b/libraries/base/GHC/Handle.hs
index e94d2d56f0..287626008e 100644
--- a/libraries/base/GHC/Handle.hs
+++ b/libraries/base/GHC/Handle.hs
@@ -74,7 +74,7 @@ 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
#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?
-dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
-- ---------------------------------------------------------------------------
-- 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__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
+ -> IO ()
withHandle__' fun h m act =
block $ do
h_ <- takeMVar m
@@ -181,13 +184,14 @@ withHandle__' fun h m act =
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.
@@ -205,6 +209,7 @@ wantWritableHandle'
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
@@ -238,6 +243,7 @@ wantReadableHandle'
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
@@ -263,6 +269,7 @@ wantSeekableHandle fun h@(DuplexHandle _ _ _) _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
@@ -297,6 +304,7 @@ ioe_notSeekable_notBin = ioException
"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))
@@ -344,6 +352,7 @@ handleFinalizer fp m = do
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
+checkBufferInvariants :: Handle__ -> IO ()
#ifdef DEBUG
checkBufferInvariants h_ = do
let ref = haBuffer h_
@@ -359,7 +368,7 @@ checkBufferInvariants h_ = do
then error "buffer invariant violation"
else return ()
#else
-checkBufferInvariants h_ = return ()
+checkBufferInvariants _ = return ()
#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.
- 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
@@ -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.
+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?
@@ -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.
-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
@@ -812,6 +824,7 @@ stderr = unsafePerformIO $ do
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
+addFilePathToIOError :: String -> FilePath -> IOException -> IOException
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' :: String -> IOMode -> Bool -> IO Handle
openFile' filepath mode binary =
withCString filepath $ \ f ->
@@ -913,6 +927,8 @@ openFile' filepath mode binary =
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
@@ -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)
-
+initBufferState :: HandleType -> BufferState
initBufferState ReadHandle = ReadBuffer
initBufferState _ = WriteBuffer
@@ -1119,6 +1135,7 @@ hClose h@(DuplexHandle _ r w) = do
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
@@ -1175,6 +1192,7 @@ hClose_handle_ handle_ = do
maybe_exception)
{-# NOINLINE noBuffer #-}
+noBuffer :: Buffer
noBuffer = unsafePerformIO $ allocateBuffer 1 ReadBuffer
-----------------------------------------------------------------------------
@@ -1252,7 +1270,6 @@ hLookAhead' :: Handle__ -> IO Char
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
@@ -1660,6 +1677,8 @@ dupHandle h other_side h_ = do
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
@@ -1719,6 +1738,7 @@ hShow :: Handle -> IO String
hShow h@(FileHandle path _) = showHandle' path False h
hShow h@(DuplexHandle path _ _) = showHandle' path True h
+showHandle' :: String -> Bool -> Handle -> IO String
showHandle' filepath is_duplex h =
withHandle_ "showHandle" h $ \hdl_ ->
let
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index a5e34f2f83..f0d2fc134c 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -143,8 +143,9 @@ hGetChar handle =
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
@@ -192,7 +193,7 @@ hGetLineBuffered handle_ = do
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
@@ -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
- (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.
@@ -233,11 +234,11 @@ hGetLineBufferedLoop handle_ ref
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
@@ -245,14 +246,14 @@ maybeFillReadBuffer fd is_line is_stream buf
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
@@ -340,6 +341,7 @@ lazyRead handle =
(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_
@@ -357,8 +359,8 @@ lazyRead' h handle_ = do
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)
@@ -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".
+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
@@ -386,14 +391,14 @@ lazyReadHaveBuffer h handle_ fd ref buf = do
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
@@ -421,6 +426,7 @@ hPutChar handle c = do
writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1
return ()
+hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
hPutcBuffered handle_ is_line c = do
let ref = haBuffer handle_
buf <- readIORef ref
@@ -436,7 +442,7 @@ hPutcBuffered handle_ is_line c = do
hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
+hPutChars _ [] = return ()
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
--
+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
@@ -591,7 +599,7 @@ commitBuffer' raw sz@(I# _) count@(I# _) flush release
++ ", 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 <-
@@ -688,12 +696,13 @@ hPutBuf' handle ptr count can_block
| 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?
@@ -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 ()
-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 ()
@@ -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
-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
@@ -775,12 +790,13 @@ hGetBuf h ptr count
| 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
@@ -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
-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
@@ -855,9 +871,11 @@ hGetBufNonBlocking h ptr count
| 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
@@ -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
- 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.
diff --git a/libraries/base/GHC/Read.lhs b/libraries/base/GHC/Read.lhs
index b890b46229..f99e2df758 100644
--- a/libraries/base/GHC/Read.lhs
+++ b/libraries/base/GHC/Read.lhs
@@ -67,7 +67,7 @@ import {-# SOURCE #-} GHC.Unicode ( isDigit )
#endif
import GHC.Num
import GHC.Real
-import GHC.Float
+import GHC.Float ()
import GHC.Show
import GHC.Base
import GHC.Arr
diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs
index 4af74faf32..68afadfa6a 100644
--- a/libraries/base/GHC/Word.hs
+++ b/libraries/base/GHC/Word.hs
@@ -690,22 +690,22 @@ instance Enum 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
- 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#
diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs
index 050da0487c..4f01b9ffc3 100644
--- a/libraries/base/Prelude.hs
+++ b/libraries/base/Prelude.hs
@@ -155,7 +155,6 @@ import Data.Tuple
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
-import GHC.Exception ( throw )
import Text.Read
import GHC.Enum
import GHC.Num
diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs
index 3d3893d585..0142d10868 100644
--- a/libraries/base/System/IO.hs
+++ b/libraries/base/System/IO.hs
@@ -169,6 +169,7 @@ import Data.List
import Data.Maybe
import Foreign.C.Error
import Foreign.C.String
+import Foreign.C.Types
import System.Posix.Internals
#endif
@@ -510,12 +511,10 @@ pathSeparator = '/'
#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__
diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs
index 5b9eb95352..0b4f7d486f 100644
--- a/libraries/base/System/Posix/Internals.hs
+++ b/libraries/base/System/Posix/Internals.hs
@@ -112,6 +112,7 @@ fdStat fd =
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
@@ -123,7 +124,7 @@ statGetType p_stat = do
| s_isblk c_mode -> return RawDevice
| otherwise -> ioError ioe_unknownfiletype
-
+ioe_unknownfiletype :: IOException
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
- 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
@@ -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__)
-
+setNonBlockingFD :: FD -> IO ()
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
(c_fcntl_read fd const_f_getfl)
diff --git a/libraries/base/System/Posix/Types.hs b/libraries/base/System/Posix/Types.hs
index 14fdcf86a1..1935179d49 100644
--- a/libraries/base/System/Posix/Types.hs
+++ b/libraries/base/System/Posix/Types.hs
@@ -1,4 +1,5 @@
{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Posix.Types
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index b17a05edcd..78710470dc 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -66,7 +66,7 @@ Library {
ForeignFunctionInterface, UnliftedFFITypes,
DeriveDataTypeable, GeneralizedNewtypeDeriving,
FlexibleInstances, PatternSignatures, StandaloneDeriving,
- PatternGuards
+ PatternGuards, EmptyDataDecls
}
exposed-modules:
Control.Applicative,
diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h
index f69e9cf656..63b0d5c35b 100644
--- a/libraries/base/include/HsBase.h
+++ b/libraries/base/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; }
-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); }