From: Ian Lynagh Date: Wed, 20 Aug 2008 22:32:52 +0000 (+0000) Subject: Fix some more warnings X-Git-Tag: 6_10_branch_has_been_forked~35 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c1f3c4852894174a3f7b855b29e8a42f60d4c019;hp=5c99290b8ab03f819f7b630f374187a254b0cea1;p=ghc-base.git Fix some more warnings --- diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index c8f4d09..b6893fb 100644 --- a/Control/Exception/Base.hs +++ b/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/Foreign/Marshal/Alloc.hs b/Foreign/Marshal/Alloc.hs index 9911718..9fd576d 100644 --- 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 -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/Foreign/Marshal/Array.hs b/Foreign/Marshal/Array.hs index ce28ddb..2297a4d 100644 --- 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 -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/GHC/Conc.lhs b/GHC/Conc.lhs index 6ae157e..f2875be 100644 --- 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 -> - 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/GHC/Handle.hs b/GHC/Handle.hs index e94d2d5..2876260 100644 --- 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.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/GHC/IO.hs b/GHC/IO.hs index a5e34f2..f0d2fc1 100644 --- a/GHC/IO.hs +++ b/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/GHC/Read.lhs b/GHC/Read.lhs index b890b46..f99e2df 100644 --- a/GHC/Read.lhs +++ b/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/GHC/Word.hs b/GHC/Word.hs index 4af74fa..68afadf 100644 --- a/GHC/Word.hs +++ b/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/Prelude.hs b/Prelude.hs index 050da04..4f01b9f 100644 --- a/Prelude.hs +++ b/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/System/IO.hs b/System/IO.hs index 3d3893d..0142d10 100644 --- 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 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/System/Posix/Internals.hs b/System/Posix/Internals.hs index 5b9eb95..0b4f7d4 100644 --- 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 +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/System/Posix/Types.hs b/System/Posix/Types.hs index 14fdcf8..1935179 100644 --- a/System/Posix/Types.hs +++ b/System/Posix/Types.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} ----------------------------------------------------------------------------- -- | -- Module : System.Posix.Types diff --git a/base.cabal b/base.cabal index b17a05e..7871047 100644 --- a/base.cabal +++ b/base.cabal @@ -66,7 +66,7 @@ Library { ForeignFunctionInterface, UnliftedFFITypes, DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleInstances, PatternSignatures, StandaloneDeriving, - PatternGuards + PatternGuards, EmptyDataDecls } exposed-modules: Control.Applicative, diff --git a/include/HsBase.h b/include/HsBase.h index f69e9cf..63b0d5c 100644 --- 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; } -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); }