hunk ./Control/Monad.hs 43 + , void hunk ./System/IO.hs 237 +import GHC.Real hunk ./System/IO.hs 241 +import qualified GHC.IO.FD as FD hunk ./System/IO.hs 550 -#ifdef __NHC__ +#if defined(__NHC__) hunk ./System/IO.hs 553 -#else +#elif defined(__GLASGOW_HASKELL__) hunk ./System/IO.hs 564 - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently + + (fD,fd_type) <- FD.mkFD (fromIntegral fd) ReadWriteMode Nothing{-no stat-} + False{-is_socket-} + True{-is_nonblock-} + + h <- mkHandleFromFD fD fd_type filepath ReadWriteMode False{-set non-block-} + (Just localeEncoding) + + return (filepath, h) +#else hunk ./System/IO.hs 577 + hunk ./System/CPUTime.hsc 111 - times p_tms + _ <- times p_tms hunk ./System/IO/Unsafe.hs 31 -import NHC.Internal (unsafePerformIO) +import NHC.Internal (unsafePerformIO, unsafeInterleaveIO) hunk ./System/IO/Unsafe.hs 34 -#if !__GLASGOW_HASKELL__ && !__HUGS__ -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO f = return (unsafePerformIO f) -#endif hunk ./GHC/Float.lhs 174 - toRational x = (m%1)*(b%1)^^n + toRational x | isInfinite x = if x < 0 then -infinity else infinity + | isNaN x = notANumber + | isNegativeZero x = negativeZero + | otherwise = (m%1)*(b%1)^^n hunk ./GHC/Float.lhs 309 - toRational x = (m%1)*(b%1)^^n + toRational x | isInfinite x = if x < 0 then -infinity else infinity + | isNaN x = notANumber + | isNegativeZero x = negativeZero + | otherwise = (m%1)*(b%1)^^n hunk ./GHC/Float.lhs 722 + | d < 0 = 0/(-1) -- -0.0 hunk ./GHC/Real.lhs 57 -infinity, notANumber :: Rational +infinity, notANumber, negativeZero :: Rational hunk ./GHC/Real.lhs 60 +negativeZero = 0 :% (-1) hunk ./System/Exit.hs 45 --- | Computation 'exitWith' @code@ throws 'ExitException' @code@. +-- | Computation 'exitWith' @code@ throws 'ExitCode' @code@. hunk ./System/Exit.hs 55 --- As an 'ExitException' is not an 'IOError', 'exitWith' bypasses +-- As an 'ExitCode' is not an 'IOError', 'exitWith' bypasses hunk ./System/Exit.hs 57 --- 'catch' from the "Prelude". However it is an 'Exception', and can +-- 'catch' from the "Prelude". However it is a 'SomeException', and can hunk ./Makefile.nhc98 22 - Data/Foldable.hs Data/Traversable.hs \ + Data/Functor.hs Data/Foldable.hs Data/Traversable.hs \ hunk ./GHC/List.lhs 111 --- | 'length' returns the length of a finite list as an 'Int'. +-- | /O(n)/. 'length' returns the length of a finite list as an 'Int'. hunk ./GHC/Real.lhs 60 -negativeZero = 0 :% (-1) hunk ./GHC/Real.lhs 57 -infinity, notANumber, negativeZero :: Rational +infinity, notANumber :: Rational hunk ./GHC/Float.lhs 722 - | d < 0 = 0/(-1) -- -0.0 hunk ./GHC/Float.lhs 309 - toRational x | isInfinite x = if x < 0 then -infinity else infinity - | isNaN x = notANumber - | isNegativeZero x = negativeZero - | otherwise = (m%1)*(b%1)^^n + toRational x = (m%1)*(b%1)^^n hunk ./GHC/Float.lhs 174 - toRational x | isInfinite x = if x < 0 then -infinity else infinity - | isNaN x = notANumber - | isNegativeZero x = negativeZero - | otherwise = (m%1)*(b%1)^^n + toRational x = (m%1)*(b%1)^^n hunk ./Data/Data.hs 483 - --- | Representation of constructors +-- | Representation of constructors. Note that equality on constructors +-- with different types may not work -- i.e. the constructors for 'False' and +-- 'Nothing' may compare equal. hunk ./GHC/Conc.lhs 840 - was_set <- readIORef prodding - writeIORef prodding True - -- no need for atomicModifyIORef, extra prods are harmless. - if (not (was_set)) then wakeupIOManager else return () + -- NB. use atomicModifyIORef here, otherwise there are race + -- conditions in which prodding is left at True but the server is + -- blocked in select(). + was_set <- atomicModifyIORef prodding $ \b -> (True,b) + if (not (was_set)) then wakeupIOManager else return () hunk ./GHC/Conc.lhs 1018 + -- reset prodding before we look at the new requests. If a new + -- client arrives after this point they will send a wakup which will + -- cause the server to loop around again, so we can be sure to not + -- miss any requests. + -- + -- NB. it's important to do this in the *first* iteration of + -- service_loop, rather than after calling select(), since a client + -- may have set prodding to True without sending a wakeup byte down + -- the pipe, because the pipe wasn't set up. + atomicModifyIORef prodding (\_ -> (False, ())) + hunk ./GHC/Conc.lhs 1099 - atomicModifyIORef prodding (\_ -> (False, ())) - hunk ./Control/Exception/Base.hs 342 --- to catch exceptions of any type, see $catchall for an explanation --- of the problems with doing so. +-- to catch exceptions of any type, see the previous section \"Catching all +-- exceptions \" for an explanation of the problems with doing so. hunk ./GHC/IO/Exception.hs 67 --- |The thread is awiting to retry an STM transaction, but there are no +-- |The thread is awaiting to retry an STM transaction, but there are no hunk ./GHC/IO/Exception.hs 94 --- |There are no runnable threads, so the program is deadlocked. --- The @Deadlock@ exception is raised in the main thread only. +-- |'assert' was applied to 'False'. hunk ./GHC/Conc.lhs 218 -exceptions 'BlockedOnDeadMVar', 'BlockedIndefinitely', and +exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and hunk ./Control/Exception/Base.hs 343 --- exceptions \" for an explanation of the problems with doing so. +-- exceptions\" for an explanation of the problems with doing so. hunk ./GHC/IO/Exception.hs 67 --- |The thread is awaiting to retry an STM transaction, but there are no +-- |The thread is waiting to retry an STM transaction, but there are no hunk ./Data/Unique.hs 24 -import Control.Concurrent.MVar hunk ./Data/Unique.hs 29 +import GHC.Conc hunk ./Data/Unique.hs 36 -uniqSource :: MVar Integer -uniqSource = unsafePerformIO (newMVar 0) +uniqSource :: TVar Integer +uniqSource = unsafePerformIO (newTVarIO 0) hunk ./Data/Unique.hs 45 -newUnique = do - val <- takeMVar uniqSource - let next = val+1 - putMVar uniqSource next - return (Unique next) +newUnique = atomically $ do + val <- readTVar uniqSource + let next = val+1 + writeTVar uniqSource $! val + 1 + return (Unique next) + +-- SDM (18/3/2010): changed from MVar to STM. This fixes +-- 1. there was no async exception protection +-- 2. there was a space leak (now new value is strict) +-- 3. using atomicModifyIORef would be slightly quicker, but can +-- suffer from adverse scheduling issues (see #3838) +-- 4. also, the STM version is faster. hunk ./Data/Unique.hs 48 - writeTVar uniqSource $! val + 1 + writeTVar uniqSource $! next hunk ./Control/Concurrent/SampleVar.hs 33 +import Control.Exception ( block ) + hunk ./Control/Concurrent/SampleVar.hs 71 -emptySampleVar v = do - (readers, var) <- takeMVar v +emptySampleVar v = block $ do + s@(readers, var) <- block $ takeMVar v hunk ./Control/Concurrent/SampleVar.hs 77 - putMVar v (readers,var) + putMVar v s hunk ./Control/Concurrent/SampleVar.hs 81 -readSampleVar svar = do +readSampleVar svar = block $ do hunk ./Control/Concurrent/SampleVar.hs 87 - putMVar svar (readers-1,val) + let readers' = readers-1 + readers' `seq` putMVar svar (readers',val) hunk ./Control/Concurrent/SampleVar.hs 94 -writeSampleVar svar v = do +writeSampleVar svar v = block $ do hunk ./Control/Concurrent/SampleVar.hs 99 - (readers,val) <- takeMVar svar + s@(readers,val) <- takeMVar svar hunk ./Control/Concurrent/SampleVar.hs 101 - 1 -> - swapMVar val v >> - putMVar svar (1,val) - _ -> - putMVar val v >> - putMVar svar (min 1 (readers+1), val) + 1 -> + swapMVar val v >> + putMVar svar s + _ -> + putMVar val v >> + let readers' = min 1 (readers+1) + in readers' `seq` putMVar svar (readers', val) hunk ./Control/Concurrent/SampleVar.hs 35 +import Data.Functor ( (<$>) ) + hunk ./Control/Concurrent/SampleVar.hs 53 -type SampleVar a - = MVar (Int, -- 1 == full - -- 0 == empty - -- <0 no of readers blocked - MVar a) +newtype SampleVar a = SampleVar ( MVar ( Int -- 1 == full + -- 0 == empty + -- <0 no of readers blocked + , MVar a + ) + ) + deriving (Eq) hunk ./Control/Concurrent/SampleVar.hs 65 - newMVar (0,v) + SampleVar <$> newMVar (0,v) hunk ./Control/Concurrent/SampleVar.hs 71 - newMVar (1,v) + SampleVar <$> newMVar (1,v) hunk ./Control/Concurrent/SampleVar.hs 75 -emptySampleVar v = block $ do +emptySampleVar (SampleVar v) = block $ do hunk ./Control/Concurrent/SampleVar.hs 85 -readSampleVar svar = block $ do +readSampleVar (SampleVar svar) = block $ do hunk ./Control/Concurrent/SampleVar.hs 98 -writeSampleVar svar v = block $ do +writeSampleVar (SampleVar svar) v = block $ do hunk ./Control/Concurrent/SampleVar.hs 121 -isEmptySampleVar svar = do +isEmptySampleVar (SampleVar svar) = do hunk ./GHC/Handle.hs 18 -module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle.Base instead" #-} ( +module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle instead" #-} ( hunk ./Control/Concurrent.hs 433 - _ <- forkIO (Exception.try action >>= putMVar mv) + b <- blocked + _ <- block $ forkIO $ + Exception.try (if b then action else unblock action) >>= + putMVar mv hunk ./Control/Concurrent.hs 485 - _ <- forkIO $ try io >>= putMVar m + _ <- block $ forkIO $ try io >>= putMVar m hunk ./GHC/IO/Handle/Text.hs 164 --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. - hunk ./GHC/Conc.lhs 844 - if (not (was_set)) then wakeupIOManager else return () + unless was_set wakeupIOManager hunk ./GHC/IO/Encoding/Iconv.hs 33 -#undef DEBUG_DUMP - hunk ./GHC/IO/Encoding/Iconv.hs 42 -#ifdef DEBUG_DUMP hunk ./GHC/IO/Encoding/Iconv.hs 43 -#endif - -iconv_trace :: String -> IO () hunk ./GHC/IO/Encoding/Iconv.hs 44 -#ifdef DEBUG_DUMP +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False hunk ./GHC/IO/Encoding/Iconv.hs 47 -iconv_trace s = puts s +iconv_trace :: String -> IO () +iconv_trace s + | c_DEBUG_DUMP = puts s + | otherwise = return () hunk ./GHC/IO/Encoding/Iconv.hs 53 -puts s = do withCStringLen (s++"\n") $ \(p, len) -> - c_write 1 (castPtr p) (fromIntegral len) +puts s = do _ <- withCStringLen (s ++ "\n") $ \(p, len) -> + c_write 1 (castPtr p) (fromIntegral len) hunk ./GHC/IO/Encoding/Iconv.hs 57 -#else - -iconv_trace _ = return () - -#endif - hunk ./GHC/IO/FD.hs 25 -#undef DEBUG_DUMP - hunk ./GHC/IO/FD.hs 31 -#ifndef mingw32_HOST_OS hunk ./GHC/IO/FD.hs 32 -#endif hunk ./GHC/IO/FD.hs 50 +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + hunk ./GHC/IO/FD.hs 110 -#ifdef DEBUG_DUMP - puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") hunk ./GHC/IO/FD.hs 113 -#ifdef DEBUG_DUMP - puts ("after: " ++ summaryBuffer buf' ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("after: " ++ summaryBuffer buf' ++ "\n") hunk ./GHC/IO/FD.hs 119 -#ifdef DEBUG_DUMP - puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") -#endif + when c_DEBUG_DUMP $ + puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n") hunk ./GHC/IO/FD.hs 625 -#if defined(DEBUG_DUMP) hunk ./GHC/IO/FD.hs 626 -puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len) +puts s = do _ <- withCStringLen s $ \(p,len) -> + c_write 1 (castPtr p) (fromIntegral len) hunk ./GHC/IO/FD.hs 629 -#endif hunk ./GHC/IO/Handle/Internals.hs 7 -#undef DEBUG_DUMP - hunk ./GHC/IO/Handle/Internals.hs 75 -#ifdef DEBUG_DUMP hunk ./GHC/IO/Handle/Internals.hs 76 -#endif + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False hunk ./GHC/IO/Handle/Internals.hs 675 -#if defined(DEBUG_DUMP) -debugIO s = do - withCStringLen (s++"\n") $ \(p,len) -> c_write 1 (castPtr p) (fromIntegral len) - return () -#else -debugIO s = return () -#endif +debugIO s + | c_DEBUG_DUMP + = do _ <- withCStringLen (s ++ "\n") $ + \(p, len) -> c_write 1 (castPtr p) (fromIntegral len) + return () + | otherwise = return () hunk ./System/Posix/Internals.hs 330 - throwErrnoIfMinus1Retry_ "fcntl_write" $ - c_fcntl_write fd const_f_setfl (fromIntegral flags') + _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags') + return () hunk ./System/Posix/Internals.hs 324 - -- An error when setting O_NONBLOCK isn't fatal: on some systems - -- there are certain file handles on which this will fail (eg. /dev/null - -- on FreeBSD) so we throw away the return code from fcntl_write. hunk ./System/Posix/Internals.hs 327 + -- An error when setting O_NONBLOCK isn't fatal: on some systems + -- there are certain file handles on which this will fail (eg. /dev/null + -- on FreeBSD) so we throw away the return code from fcntl_write. hunk ./Foreign/Marshal/Alloc.hs 73 +{-# INLINE malloc #-} hunk ./Foreign/Marshal/Alloc.hs 97 +{-# INLINE alloca #-} hunk ./GHC/IO/Handle/FD.hs 54 +{-# NOINLINE stdin #-} hunk ./GHC/IO/Handle/FD.hs 64 +{-# NOINLINE stdout #-} hunk ./GHC/IO/Handle/FD.hs 74 +{-# NOINLINE stderr #-} hunk ./GHC/IO/Handle/Internals.hs 61 +import GHC.Conc hunk ./GHC/IO/Handle/Internals.hs 126 - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) + block $ do + (h',v) <- do_operation fun h act m hunk ./GHC/IO/Handle/Internals.hs 138 -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) - checkHandleInvariants h_ - putMVar m h_ - return v +withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do + a <- act h_ + return (h_,a) hunk ./GHC/IO/Handle/Internals.hs 151 - block $ do - h_ <- takeMVar m - checkHandleInvariants h_ - h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err) - `catchException` \ex -> ioError (augmentIOError ex fun h) + block $ do + h' <- do_operation fun h act m hunk ./GHC/IO/Handle/Internals.hs 157 +do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a +do_operation fun h act m = do + h_ <- takeMVar m + checkHandleInvariants h_ + act h_ `catchException` handler h_ + where + handler h_ e = do + putMVar m h_ + case () of + _ | Just ioe <- fromException e -> + ioError (augmentIOError ioe fun h) + _ | Just async_ex <- fromException e -> do -- see Note [async] + let _ = async_ex :: AsyncException + t <- myThreadId + throwTo t e + do_operation fun h act m + _otherwise -> + throwIO e + +-- Note [async] +-- +-- If an asynchronous exception is raised during an I/O operation, +-- normally it is fine to just re-throw the exception synchronously. +-- However, if we are inside an unsafePerformIO or an +-- unsafeInterleaveIO, this would replace the enclosing thunk with the +-- exception raised, which is wrong (#3997). We have to release the +-- lock on the Handle, but what do we replace the thunk with? What +-- should happen when the thunk is subsequently demanded again? +-- +-- The only sensible choice we have is to re-do the IO operation on +-- resumption, but then we have to be careful in the IO library that +-- this is always safe to do. In particular we should +-- +-- never perform any side-effects before an interruptible operation +-- +-- because the interruptible operation may raise an asynchronous +-- exception, which may cause the operation and its side effects to be +-- subsequently performed again. +-- +-- Re-doing the IO operation is achieved by: +-- - using throwTo to re-throw the asynchronous exception asynchronously +-- in the current thread +-- - on resumption, it will be as if throwTo returns. In that case, we +-- recursively invoke the original operation (see do_operation above). +-- +-- Interruptible operations in the I/O library are: +-- - threadWaitRead/threadWaitWrite +-- - fillReadBuffer/flushWriteBuffer +-- - readTextDevice/writeTextDevice + hunk ./Foreign/Marshal/Array.hs 111 +{-# INLINE allocaArray0 #-} + -- needed to get allocaArray to inline into withCString, for unknown + -- reasons --SDM 23/4/2010, see #4004 for benchmark hunk ./Data/Tuple.hs 23 + , swap -- :: (a,b) -> (b,a) hunk ./Data/Tuple.hs 108 + +-- | Swap the components of a pair. +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) hunk ./GHC/IO/Handle/Text.hs 25 - hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, hunk ./GHC/IO/Handle/Text.hs 66 --- or 'False' if no input is available within @t@ milliseconds. +-- or 'False' if no input is available within @t@ milliseconds. Note that +-- 'hWaitForInput' waits until one or more full /characters/ are available, +-- which means that it needs to do decoding, and hence may fail +-- with a decoding error. hunk ./GHC/IO/Handle/Text.hs 76 +-- * a decoding error, if the input begins with an invalid byte sequence +-- in this Handle's encoding. hunk ./GHC/IO/Handle/Text.hs 83 +-- hunk ./GHC/IO/Handle/Text.hs 799 --- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently --- using, and reads bytes directly from the underlying IO device. --- hunk ./GHC/IO/Handle/Text.hs 874 +-- --------------------------------------------------------------------------- +-- hGetBufSome + +-- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@. If there is any data available to read, +-- then 'hGetBufSome' returns it immediately; it only blocks if there +-- is no data to be read. +-- +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBufSome' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufSome' will behave as if EOF was reached. +-- +-- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- on the 'Handle', and reads bytes directly. + +hGetBufSome :: Handle -> Ptr a -> Int -> IO Int +hGetBufSome h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBuf" count + | otherwise = + wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do + flushCharReadBuffer h_ + buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- large read? + then do RawIO.read (haFD h_) (castPtr ptr) count + else do (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return 0 + else do writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 count + else + bufReadNBEmpty h_ buf (castPtr ptr) 0 count + +haFD :: Handle__ -> FD +haFD h_@Handle__{} = + case cast h_ of + Nothing -> error "not an FD" + Just fd -> fd + hunk ./GHC/IO/Handle/Text.hs 929 --- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle' --- is currently using, and reads bytes directly from the underlying IO --- device. --- hunk ./GHC/IO/Handle/Text.hs 949 - then if count > sz -- large read? - then do rest <- readChunkNonBlocking h_ ptr count - return (so_far + rest) - else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf - case r of - Nothing -> return so_far - Just 0 -> return so_far - Just r -> do - writeIORef haByteBuffer buf' - bufReadNonBlocking h_ ptr so_far (min count r) - -- NOTE: new count is min count w' - -- so we will just copy the contents of the - -- buffer in the recursive call, and not - -- loop again. - else do + then bufReadNBEmpty h_ buf ptr so_far count + else bufReadNBNonEmpty h_ buf ptr so_far count + +bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + = if count > sz -- large read? + then do rest <- readChunkNonBlocking h_ ptr count + return (so_far + rest) + else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf + case r of + Nothing -> return so_far + Just 0 -> return so_far + Just r -> do + writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' ptr so_far (min count r) + -- 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. + +bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBNonEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + = do hunk ./GHC/IO/Handle/Text.hs 991 - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + let buf' = buf{ bufR=0, bufL=0 } + writeIORef haByteBuffer buf' hunk ./GHC/IO/Handle/Text.hs 997 - -- we haven't attempted to read anything yet if we get to here. - if remaining < sz - then bufReadNonBlocking h_ ptr' so_far' remaining - else do - - rest <- readChunkNonBlocking h_ ptr' remaining - return (so_far' + rest) + bufReadNBEmpty h_ buf' ptr' so_far' remaining hunk ./Data/Unique.hs 30 +import Data.Typeable hunk ./Data/Unique.hs 35 -newtype Unique = Unique Integer deriving (Eq,Ord) +newtype Unique = Unique Integer deriving (Eq,Ord +#ifdef __GLASGOW_HASKELL__ + ,Typeable +#endif + ) hunk ./GHC/IO.hs 104 -If the I\/O computation wrapped in 'unsafePerformIO' -performs side effects, then the relative order in which those side -effects take place (relative to the main I\/O trunk, or other calls to -'unsafePerformIO') is indeterminate. You have to be careful when -writing and compiling modules that use 'unsafePerformIO': +If the I\/O computation wrapped in 'unsafePerformIO' performs side +effects, then the relative order in which those side effects take +place (relative to the main I\/O trunk, or other calls to +'unsafePerformIO') is indeterminate. Furthermore, when using +'unsafePerformIO' to cause side-effects, you should take the following +precautions to ensure the side effects are performed as many times as +you expect them to be. Note that these precautions are necessary for +GHC, but may not be sufficient, and other compilers may require +different precautions: hunk ./GHC/IO.hs 123 - * Make sure that the either you switch off let-floating, or that the + * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the hunk ./GHC/Conc.lhs 278 -{- | 'killThread' terminates the given thread (GHC only). -Any work already done by the thread isn\'t -lost: the computation is suspended until required by another thread. -The memory used by the thread will be garbage collected if it isn\'t -referenced from anywhere. The 'killThread' function is defined in -terms of 'throwTo': +{- | 'killThread' raises the 'ThreadKilled' exception in the given +thread (GHC only). hunk ./GHC/Conc.lhs 283 -Killthread is a no-op if the target thread has already completed. hunk ./GHC/Conc.lhs 297 +Whatever work the target thread was doing when the exception was +raised is not lost: the computation is suspended until required by +another thread. + hunk ./GHC/Conc.lhs 315 -There is currently no guarantee that the exception delivered by 'throwTo' will be -delivered at the first possible opportunity. In particular, a thread may -unblock and then re-block exceptions (using 'unblock' and 'block') without receiving -a pending 'throwTo'. This is arguably undesirable behaviour. +There is no guarantee that the exception will be delivered promptly, +although the runtime will endeavour to ensure that arbitrary +delays don't occur. In GHC, an exception can only be raised when a +thread reaches a /safe point/, where a safe point is where memory +allocation occurs. Some loops do not perform any memory allocation +inside the loop and therefore cannot be interrupted by a 'throwTo'. + +Blocked 'throwTo' is fair: if multiple threads are trying to throw an +exception to the same target thread, they will succeed in FIFO order. hunk ./GHC/Conc.lhs 325 - -} + -} hunk ./GHC/IO/Handle/Text.hs 914 -haFD h_@Handle__{} = - case cast h_ of +haFD h_@Handle__{..} = + case cast haDevice of hunk ./GHC/IO/Exception.hs 196 --- in pure code, see 'Control.Exception.Exception'. +-- in pure code, see "Control.Exception.Exception". hunk ./GHC/IO/Handle.hs 271 - withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do + withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do hunk ./GHC/IO/Handle.hs 279 - haCodec = Just encoding, .. }, - ()) + haCodec = Just encoding, .. }) hunk ./GHC/IO/Handle/Internals.hs 38 + decodeByteBuf, hunk ./GHC/IO/Handle/Internals.hs 826 - bbuf1 <- if not (isEmptyBuffer bbuf0) - then return bbuf0 - else do - (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 - if isNothing r then ioe_EOF else do -- raise EOF - return bbuf1 + when (isEmptyBuffer bbuf0) $ do + (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0 + if isNothing r then ioe_EOF else do -- raise EOF + writeIORef haByteBuffer bbuf1 + + decodeByteBuf h_ cbuf + +-- Decode bytes from the byte buffer into the supplied CharBuffer. +decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer +decodeByteBuf h_@Handle__{..} cbuf = do + -- + bbuf0 <- readIORef haByteBuffer hunk ./GHC/IO/Handle/Internals.hs 842 - writeIORef haLastDecode (error "codec_state", bbuf1) - latin1_decode bbuf1 cbuf + writeIORef haLastDecode (error "codec_state", bbuf0) + latin1_decode bbuf0 cbuf hunk ./GHC/IO/Handle/Internals.hs 846 - writeIORef haLastDecode (state, bbuf1) - (encode decoder) bbuf1 cbuf + writeIORef haLastDecode (state, bbuf0) + (encode decoder) bbuf0 cbuf hunk ./GHC/IO/Handle/Text.hs 98 - cbuf' <- readTextDeviceNonBlocking handle_ cbuf + cbuf' <- decodeByteBuf handle_ cbuf hunk ./System/IO.hs 154 + hGetBufSome, -- :: Handle -> Ptr a -> Int -> IO Int hunk ./System/IO.hs 244 +import GHC.IO.Handle.Text ( hGetBufSome ) hunk ./Data/Foldable.hs 93 --- > instance Foldable Tree +-- > instance Foldable Tree where hunk ./Data/Traversable.hs 65 --- > instance Traversable Tree +-- > instance Traversable Tree where hunk ./Data/Foldable.hs 99 --- to satisfy the monoid laws. +-- to satisfy the monoid laws. Alternatively, one could define @foldr@: +-- +-- > instance Foldable Tree where +-- > foldr f z Empty = z +-- > foldr f z (Leaf x) = f x z +-- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l hunk ./Data/Foldable.hs 165 + foldl f z = Prelude.foldl f z . elems + foldr1 f = Prelude.foldr1 f . elems + foldl1 f = Prelude.foldl1 f . elems hunk ./Control/Applicative.hs 48 +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc (STM, retry, orElse) +#endif + hunk ./Control/Applicative.hs 152 +#ifdef __GLASGOW_HASKELL__ +instance Applicative STM where + pure = return + (<*>) = ap + +instance Alternative STM where + empty = retry + (<|>) = orElse +#endif + hunk ./GHC/Conc.lhs 479 +instance MonadPlus STM where + mzero = retry + mplus = orElse + hunk ./base.cabal 2 -version: 4.2.0.0 +version: 4.3.0.0 hunk ./Control/Concurrent/MVar.hs 1 +{-# OPTIONS_GHC -XNoImplicitPrelude #-} hunk ./Control/Concurrent/MVar.hs 49 +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#else hunk ./Control/Concurrent/MVar.hs 53 +#endif + hunk ./Data/Monoid.hs 1 +{-# OPTIONS_GHC -XNoImplicitPrelude #-} hunk ./Data/Monoid.hs 34 +-- Push down the module in the dependency hierarchy. +#if defined(__GLASGOW_HASKELL__) +import GHC.Base hiding (Any) +import GHC.Enum +import GHC.Num +import GHC.Read +import GHC.Show +import Data.Maybe +#else hunk ./Data/Monoid.hs 44 +#endif hunk ./GHC/IO/Handle/Text.hs 934 +-- +-- NOTE: on Windows, this function does not work correctly; it +-- behaves identically to 'hGetBuf'. hunk ./GHC/Conc.lhs 313 -the paper). +the paper). Unlike other interruptible operations, however, 'throwTo' +is /always/ interruptible, even if it does not actually block. hunk ./GHC/IO/Encoding/Iconv.hs 95 -#if HAVE_LANGINFO_H - cstr <- c_localeEncoding -- use nl_langinfo(CODESET) to get the encoding - -- if we have it + -- Use locale_charset() or nl_langinfo(CODESET) to get the encoding + -- if we have either of them. + cstr <- c_localeEncoding hunk ./GHC/IO/Encoding/Iconv.hs 100 -#else - mkTextEncoding "" -- GNU iconv accepts "" to mean the -- locale encoding. -#endif hunk ./cbits/PrelIOUtils.c 27 -// Use a C wrapper for this because we avoid hsc2hs in base -#if HAVE_LANGINFO_H -#include -char *localeEncoding (void) +#if defined(HAVE_LIBCHARSET) +# include +#elif defined(HAVE_LANGINFO_H) +# include +#endif + +const char* localeEncoding(void) hunk ./cbits/PrelIOUtils.c 35 +#if defined(HAVE_LIBCHARSET) + return locale_charset(); + +#elif defined(HAVE_LANGINFO_H) hunk ./cbits/PrelIOUtils.c 40 -} + +#else +#warning Depending on the unportable behavior of GNU iconv due to absence of both libcharset and langinfo.h + /* GNU iconv accepts "" to mean the current locale's + * encoding. Warning: This isn't portable. + */ + return ""; hunk ./cbits/PrelIOUtils.c 48 +} hunk ./configure.ac 139 +# If possible, we use libcharset instead of nl_langinfo(CODESET) to +# determine the current locale's character encoding. +FP_SEARCH_LIBS_PROTO( + [locale_charset], + [#include ], + [const char* charset = locale_charset();], + [charset], + [AC_DEFINE([HAVE_LIBCHARSET], [1], [Define to 1 if you have libcharset.]) + EXTRA_LIBS="$EXTRA_LIBS $ac_lib"]) + + hunk ./Control/Applicative.hs 170 +instance Applicative (Either e) where + pure = Right + Left e <*> _ = Left e + Right f <*> r = fmap f r + hunk ./cbits/PrelIOUtils.c 33 +#if !defined(mingw32_HOST_OS) hunk ./cbits/PrelIOUtils.c 50 +#endif hunk ./Data/Traversable.hs 110 + {-# INLINE traverse #-} -- so that traverse can fuse hunk ./GHC/Arr.lhs 357 --- The Int is the number of elements in the Array. hunk ./GHC/IO/Exception.hs 172 +-- | Defines the exit codes that a program can return. hunk ./GHC/Arr.lhs 563 --- | The 'accumArray' deals with repeated indices in the association +-- | The 'accumArray' function deals with repeated indices in the association hunk ./GHC/IO/Handle/Text.hs 813 - wantReadableHandle_ "hGetBuf" h $ \ h_ -> do + wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do hunk ./GHC/IO/Handle/Text.hs 815 - bufRead h_ (castPtr ptr) 0 count + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + <- readIORef haByteBuffer + if isEmptyBuffer buf + then bufReadEmpty h_ buf (castPtr ptr) 0 count + else bufReadNonEmpty h_ buf (castPtr ptr) 0 count hunk ./GHC/IO/Handle/Text.hs 824 -bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int -bufRead h_@Handle__{..} ptr so_far count = - seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer - if isEmptyBuffer buf - then if count > sz -- small read? - then do rest <- readChunk h_ ptr count - return (so_far + rest) - else do (r,buf') <- Buffered.fillReadBuffer haDevice buf - if r == 0 - then return so_far - else do writeIORef haByteBuffer buf' - bufRead h_ ptr so_far count - else do + +bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNonEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr !so_far !count + = do hunk ./GHC/IO/Handle/Text.hs 831 - if (count == avail) - then do - copyFromRawBuffer ptr raw r count - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } - return (so_far + count) - else do hunk ./GHC/IO/Handle/Text.hs 839 - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + let buf' = buf{ bufR=0, bufL=0 } + writeIORef haByteBuffer buf' hunk ./GHC/IO/Handle/Text.hs 845 - if remaining < sz - then bufRead h_ ptr' so_far' remaining - else do + if remaining == 0 + then return so_far' + else bufReadEmpty h_ buf' ptr' so_far' remaining hunk ./GHC/IO/Handle/Text.hs 849 - rest <- readChunk h_ ptr' remaining - return (so_far' + rest) hunk ./GHC/IO/Handle/Text.hs 850 -readChunk :: Handle__ -> Ptr a -> Int -> IO Int -readChunk h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = loop fd 0 bytes - | otherwise = error "ToDo: hGetBuf" +bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + | count > sz, Just fd <- cast haDevice = loop fd 0 count + | otherwise = do + (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return so_far + else do writeIORef haByteBuffer buf' + bufReadNonEmpty h_ buf' ptr so_far count hunk ./GHC/IO/Handle/Text.hs 867 - then return off + then return (so_far + off) hunk ./GHC/IO/Handle/Text.hs 939 - wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do + wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do hunk ./GHC/IO/Handle/Text.hs 941 - bufReadNonBlocking h_ (castPtr ptr) 0 count - -bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int -bufReadNonBlocking h_@Handle__{..} ptr so_far count = - seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer - if isEmptyBuffer buf - then bufReadNBEmpty h_ buf ptr so_far count - else bufReadNBNonEmpty h_ buf ptr so_far count + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + <- readIORef haByteBuffer + if isEmptyBuffer buf + then bufReadNBEmpty h_ buf (castPtr ptr) 0 count + else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count hunk ./GHC/IO/Handle/Text.hs 951 - = if count > sz -- large read? - then do rest <- readChunkNonBlocking h_ ptr count - return (so_far + rest) - else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf - case r of - Nothing -> return so_far - Just 0 -> return so_far - Just r -> do - writeIORef haByteBuffer buf' - bufReadNBNonEmpty h_ buf' ptr so_far (min count r) - -- NOTE: new count is min count w' + | count > sz, False, + Just fd <- cast haDevice = do + m <- RawIO.readNonBlocking (fd::FD) ptr count + case m of + Nothing -> return so_far + Just n -> return (so_far + n) + + | otherwise = do + buf <- readIORef haByteBuffer + (r,buf') <- Buffered.fillReadBuffer0 haDevice buf + case r of + Nothing -> return so_far + Just 0 -> return so_far + Just r -> do + writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' ptr so_far (min count r) + -- NOTE: new count is min count r hunk ./GHC/IO/Handle/Text.hs 972 + hunk ./GHC/IO/Handle/Text.hs 979 - if (count == avail) - then do - copyFromRawBuffer ptr raw r count - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } - return (so_far + count) - else do hunk ./GHC/IO/Handle/Text.hs 993 - bufReadNBEmpty h_ buf' ptr' so_far' remaining - - -readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int -readChunkNonBlocking h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = do - m <- RawIO.readNonBlocking (fd::FD) ptr bytes - case m of - Nothing -> return 0 - Just n -> return n - | otherwise = error "ToDo: hGetBuf" + if remaining == 0 + then return so_far' + else bufReadNBEmpty h_ buf' ptr' so_far' remaining hunk ./GHC/Unicode.hs 66 --- | Selects white-space characters in the Latin-1 range. --- (In Unicode terms, this includes spaces and some control characters.) +-- | Returns 'True' for any Unicode space character, and the control +-- characters @\t@, @\\n@, @\\r@, @\\f@, @\\v@. hunk ./System/Exit.hs 47 --- program's caller. Before the program terminates, any open or --- semi-closed handles are first closed. +-- program's caller. +-- +-- On program termination, the standard 'Handle's 'stdout' and +-- 'stderr' are flushed automatically; any other buffered 'Handle's +-- need to be flushed manually, otherwise the buffered data will be +-- discarded. hunk ./Data/List.hs 305 --- | The 'nub' function removes duplicate elements from a list. +-- | /O(n^2)/. The 'nub' function removes duplicate elements from a list. hunk ./GHC/Unicode.hs 67 --- characters @\t@, @\\n@, @\\r@, @\\f@, @\\v@. +-- characters @\\t@, @\\n@, @\\r@, @\\f@, @\\v@. hunk ./Control/Monad.hs 31 - -- ** Basic functions from the "Prelude" + -- ** Basic @Monad@ functions hunk ./Control/Monad.hs 186 --- | Right-to-left Kleisli composition of monads. '(>=>)', with the arguments flipped +-- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped hunk ./Control/Monad.hs 223 -the list arguments. This could be an issue where '(>>)' and the `folded +the list arguments. This could be an issue where @('>>')@ and the `folded hunk ./GHC/ForeignPtr.hs 360 --- 'touchForeignPtr'. However, the later routines +-- 'touchForeignPtr'. However, the latter routines hunk ./GHC/IO/Device.hs 145 --- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: +-- | A mode that determines the effect of 'hSeek' @hdl mode i@. hunk ./GHC/IO/Handle.hs 396 +-- * 'isIllegalOperationError' if the Handle is not seekable, or does +-- not support the requested seek mode. hunk ./GHC/IO/Handle.hs 422 +-- | Computation 'hTell' @hdl@ returns the current position of the +-- handle @hdl@, as the number of bytes from the beginning of +-- the file. The value returned may be subsequently passed to +-- 'hSeek' to reposition the handle to the current position. +-- +-- This operation may fail with: +-- +-- * 'isIllegalOperationError' if the Handle is not seekable. +-- hunk ./GHC/IO/Handle/Types.hs 89 --- --- GHC note: a 'Handle' will be automatically closed when the garbage --- collector detects that it has become unreferenced by the program. --- However, relying on this behaviour is not generally recommended: --- the garbage collector is unpredictable. If possible, use explicit --- an explicit 'hClose' to close 'Handle's when they are no longer --- required. GHC does not currently attempt to free up file --- descriptors when they have run out, it is your responsibility to --- ensure that this doesn't happen. hunk ./GHC/IO/IOMode.hs 25 +-- | See 'System.IO.openFile' hunk ./System/IO.hs 28 + -- | GHC note: a 'Handle' will be automatically closed when the garbage + -- collector detects that it has become unreferenced by the program. + -- However, relying on this behaviour is not generally recommended: + -- the garbage collector is unpredictable. If possible, use explicit + -- an explicit 'hClose' to close 'Handle's when they are no longer + -- required. GHC does not currently attempt to free up file + -- descriptors when they have run out, it is your responsibility to + -- ensure that this doesn't happen. + hunk ./System/IO.hs 627 --- That is, /there may either be many handles on the same file which manage --- input, or just one handle on the file which manages output/. If any +-- That is, /there may either be many handles on the same file which manage input, or just one handle on the file which manages output/. If any hunk ./GHC/IO/Handle/Text.hs 76 +-- hunk ./GHC/Base.lhs 442 -{-| The character type 'Char' is an enumeration whose values represent -Unicode (or equivalently ISO\/IEC 10646) characters -(see for details). -This set extends the ISO 8859-1 (Latin-1) character set -(the first 256 charachers), which is itself an extension of the ASCII -character set (the first 128 characters). -A character literal in Haskell has type 'Char'. - -To convert a 'Char' to or from the corresponding 'Int' value defined -by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the -'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr'). --} - hunk ./Control/Monad.hs 227 -> foldM f a1 [x1, x2, ..., xm ] +> foldM f a1 [x1, x2, ..., xm] hunk ./GHC/Arr.lhs 414 --- list, but nonstrict in the values. Thus, recurrences such as the +-- list, but non-strict in the values. Thus, recurrences such as the hunk ./GHC/Base.lhs 176 -defined in the "Prelude" satisfy these laws. +satisfy these laws. hunk ./Data/List.hs 233 --- > stripPrefix "foo" "foobar" -> Just "bar" --- > stripPrefix "foo" "foo" -> Just "" --- > stripPrefix "foo" "barfoo" -> Nothing --- > stripPrefix "foo" "barfoobaz" -> Nothing +-- > stripPrefix "foo" "foobar" == Just "bar" +-- > stripPrefix "foo" "foo" == Just "" +-- > stripPrefix "foo" "barfoo" == Nothing +-- > stripPrefix "foo" "barfoobaz" == Nothing hunk ./Data/List.hs 300 --- >isInfixOf "Haskell" "I really like Haskell." -> True --- >isInfixOf "Ial" "I really like Haskell." -> False +-- >isInfixOf "Haskell" "I really like Haskell." == True +-- >isInfixOf "Ial" "I really like Haskell." == False hunk ./GHC/Arr.lhs 52 --- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@ +-- * @'inRange' (l,u) i == 'elem' i ('range' (l,u))@ @ @ hunk ./GHC/Arr.lhs 56 --- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@ +-- * @'map' ('index' (l,u)) ('range' (l,u))) == [0..'rangeSize' (l,u)-1]@ @ @ hunk ./GHC/Arr.lhs 58 --- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@ +-- * @'rangeSize' (l,u) == 'length' ('range' (l,u))@ @ @ hunk ./System/Exit.hs 89 --- sucessfully. +-- successfully. hunk ./Foreign/C/Error.hs 493 --- | Construct a Haskell 98 I\/O error based on the given 'Errno' value. +-- | Construct an 'IOError' based on the given 'Errno' value. hunk ./Foreign/C/Error.hs 361 --- | as 'throwErrnoIfRetry', but additionlly if the operation +-- | as 'throwErrnoIfRetry', but additionally if the operation hunk ./GHC/ForeignPtr.hs 103 --- |A Finalizer is represented as a pointer to a foreign function that, at +-- |A finalizer is represented as a pointer to a foreign function that, at hunk ./GHC/ForeignPtr.hs 235 --- ^ like 'addForeignPtrFinalizerEnv' but allows the finalizer to be +-- ^ Like 'addForeignPtrFinalizerEnv' but allows the finalizer to be hunk ./Foreign/Marshal/Array.hs 132 --- |Convert an array of given length into a Haskell list. This version --- traverses the array backwards using an accumulating parameter, --- which uses constant stack space. The previous version using mapM --- needed linear stack space. +-- |Convert an array of given length into a Haskell list. The implementation +-- is tail-recursive and so uses constant stack space. hunk ./Foreign/Marshal/Utils.hs 116 --- |Allocate storage and marshall a storable value wrapped into a 'Maybe' +-- |Allocate storage and marshal a storable value wrapped into a 'Maybe' hunk ./Foreign/C/Types.hs 46 + -- extracted from CTime, because we don't want this comment in + -- the Haskell 2010 report: + + -- | To convert 'CTime' to 'Data.Time.UTCTime', use the following formula: + -- + -- > posixSecondsToUTCTime (realToFrac :: POSIXTime) + -- + hunk ./Foreign/C/Types.hs 210 --- To convert to a @Data.Time.UTCTime@, use the following formula: --- --- > posixSecondsToUTCTime (realToFrac :: POSIXTime) --- hunk ./GHC/Ptr.lhs 82 --- i.e. 'Char', 'Int', 'Prelude.Double', 'Prelude.Float', +-- i.e. 'Char', 'Int', 'Double', 'Float', hunk ./GHC/Ptr.lhs 90 --- @'Prelude.IO' t@ where @t@ is a marshallable foreign type or @()@. +-- @'IO' t@ where @t@ is a marshallable foreign type or @()@. hunk ./Control/Monad.hs 130 - -- (but the instance for 'System.IO.IO' defined in Control.Monad.Error - -- in the mtl package does not satisfy the second one). hunk ./GHC/IO/Handle.hs 273 + closeTextCodecs h_ hunk ./GHC/IO/Handle.hs 576 + closeTextCodecs h_ hunk ./GHC/IO/Handle/FD.hs 87 + case haType h_ of + ClosedHandle -> return () + _other -> closeTextCodecs h_ hunk ./GHC/IO/Handle/Internals.hs 31 - openTextEncoding, initBufferState, + openTextEncoding, closeTextCodecs, initBufferState, hunk ./GHC/IO/Handle/Internals.hs 53 -import GHC.IO.Encoding +import GHC.IO.Encoding as Encoding hunk ./GHC/IO/Handle/Internals.hs 635 +closeTextCodecs :: Handle__ -> IO () +closeTextCodecs Handle__{..} = do + case haDecoder of Nothing -> return (); Just d -> Encoding.close d + case haEncoder of Nothing -> return (); Just d -> Encoding.close d + hunk ./GHC/IO/Handle/Internals.hs 665 -hClose_handle_ Handle__{..} = do +hClose_handle_ h_@Handle__{..} = do hunk ./GHC/IO/Handle/Internals.hs 684 - case haDecoder of Nothing -> return (); Just d -> close d - case haEncoder of Nothing -> return (); Just d -> close d + closeTextCodecs h_ hunk ./Control/Concurrent/QSemN.hs 27 +import Control.Exception ( block ) hunk ./Control/Concurrent/QSemN.hs 49 -waitQSemN (QSemN sem) sz = do +waitQSemN (QSemN sem) sz = block $ do hunk ./Control/Concurrent/QSemN.hs 51 - if (avail - sz) >= 0 then + let remaining = avail - sz + if remaining >= 0 then hunk ./Control/Concurrent/QSemN.hs 55 - putMVar sem (avail-sz,blocked) + putMVar sem (remaining,blocked) hunk ./Control/Concurrent/QSemN.hs 57 - block <- newEmptyMVar - putMVar sem (avail, blocked++[(sz,block)]) - takeMVar block + b <- newEmptyMVar + putMVar sem (avail, blocked++[(sz,b)]) + takeMVar b hunk ./Control/Concurrent/QSemN.hs 63 -signalQSemN (QSemN sem) n = do +signalQSemN (QSemN sem) n = block $ do hunk ./Control/Concurrent/QSemN.hs 66 - putMVar sem (avail',blocked') + avail' `seq` putMVar sem (avail',blocked') hunk ./Control/Concurrent/QSemN.hs 69 - free avail ((req,block):blocked) + free avail ((req,b):blocked) hunk ./Control/Concurrent/QSemN.hs 71 - putMVar block () + putMVar b () hunk ./Control/Concurrent/QSemN.hs 75 - return (avail',(req,block):blocked') + return (avail',(req,b):blocked') hunk ./Control/Concurrent/QSem.hs 25 +import Control.Exception ( block ) hunk ./Control/Concurrent/QSem.hs 54 -waitQSem (QSem sem) = do +waitQSem (QSem sem) = block $ do hunk ./Control/Concurrent/QSem.hs 57 - putMVar sem (avail-1,[]) + let avail' = avail-1 + in avail' `seq` putMVar sem (avail',[]) hunk ./Control/Concurrent/QSem.hs 60 - block <- newEmptyMVar + b <- newEmptyMVar hunk ./Control/Concurrent/QSem.hs 70 - putMVar sem (0, blocked++[block]) - takeMVar block + putMVar sem (0, blocked++[b]) + takeMVar b hunk ./Control/Concurrent/QSem.hs 75 -signalQSem (QSem sem) = do +signalQSem (QSem sem) = block $ do hunk ./Control/Concurrent/QSem.hs 78 - [] -> putMVar sem (avail+1,[]) + [] -> let avail' = avail+1 + in avail' `seq` putMVar sem (avail',blocked) hunk ./Control/Concurrent/QSem.hs 81 - (block:blocked') -> do + (b:blocked') -> do hunk ./Control/Concurrent/QSem.hs 83 - putMVar block () + putMVar b () hunk ./Control/Concurrent.hs 31 + forkIOUnmasked, hunk ./Control/Concurrent.hs 102 - threadDelay, forkIO, childHandler ) + threadDelay, forkIO, forkIOUnmasked, childHandler ) hunk ./Control/Concurrent.hs 104 -import GHC.IO ( IO(..), unsafeInterleaveIO ) +import GHC.IO ( IO(..), unsafeInterleaveIO, unsafeUnmask ) hunk ./Control/Concurrent.hs 361 - b <- Exception.blocked + b <- Exception.getMaskingState hunk ./Control/Concurrent.hs 363 - -- async exceptions are blocked in the child if they are blocked + -- async exceptions are masked in the child if they are masked hunk ./Control/Concurrent.hs 365 - -- creates a thread with exceptions blocked by default. - action1 | b = action0 - | otherwise = unblock action0 + -- creates a thread with exceptions masked by default. + action1 = case b of + Unmasked -> unsafeUnmask action0 + MaskedInterruptible -> action0 + MaskedUninterruptible -> uninterruptibleMask_ action0 hunk ./Control/Concurrent.hs 437 - _ <- block $ forkIO $ - Exception.try (if b then action else unblock action) >>= + _ <- mask $ \restore -> forkIO $ + Exception.try (if b then action else restore action) >>= hunk ./Control/Concurrent.hs 488 - _ <- block $ forkIO $ try io >>= putMVar m + _ <- mask_ $ forkIO $ try io >>= putMVar m hunk ./Control/Concurrent/MVar.hs 63 - block $ do + mask_ $ do hunk ./Control/Concurrent/MVar.hs 76 - block $ do + mask_ $ do hunk ./Control/Concurrent/MVar.hs 92 - block $ do + mask $ \restore -> do hunk ./Control/Concurrent/MVar.hs 94 - b <- unblock (io a) `onException` putMVar m a + b <- restore (io a) `onException` putMVar m a hunk ./Control/Concurrent/MVar.hs 106 - block $ do + mask $ \restore -> do hunk ./Control/Concurrent/MVar.hs 108 - a' <- unblock (io a) `onException` putMVar m a + a' <- restore (io a) `onException` putMVar m a hunk ./Control/Concurrent/MVar.hs 118 - block $ do + mask $ \restore -> do hunk ./Control/Concurrent/MVar.hs 120 - (a',b) <- unblock (io a) `onException` putMVar m a + (a',b) <- restore (io a) `onException` putMVar m a hunk ./Control/Concurrent/QSem.hs 25 -import Control.Exception ( block ) +import Control.Exception ( mask_ ) hunk ./Control/Concurrent/QSem.hs 54 -waitQSem (QSem sem) = block $ do +waitQSem (QSem sem) = mask_ $ do hunk ./Control/Concurrent/QSem.hs 75 -signalQSem (QSem sem) = block $ do +signalQSem (QSem sem) = mask_ $ do hunk ./Control/Concurrent/QSemN.hs 27 -import Control.Exception ( block ) +import Control.Exception ( mask_ ) hunk ./Control/Concurrent/QSemN.hs 49 -waitQSemN (QSemN sem) sz = block $ do +waitQSemN (QSemN sem) sz = mask_ $ do hunk ./Control/Concurrent/QSemN.hs 63 -signalQSemN (QSemN sem) n = block $ do +signalQSemN (QSemN sem) n = mask_ $ do hunk ./Control/Concurrent/SampleVar.hs 33 -import Control.Exception ( block ) +import Control.Exception ( mask_ ) hunk ./Control/Concurrent/SampleVar.hs 75 -emptySampleVar (SampleVar v) = block $ do - s@(readers, var) <- block $ takeMVar v +emptySampleVar (SampleVar v) = mask_ $ do + s@(readers, var) <- takeMVar v hunk ./Control/Concurrent/SampleVar.hs 85 -readSampleVar (SampleVar svar) = block $ do +readSampleVar (SampleVar svar) = mask_ $ do hunk ./Control/Concurrent/SampleVar.hs 98 -writeSampleVar (SampleVar svar) v = block $ do +writeSampleVar (SampleVar svar) v = mask_ $ do hunk ./Control/Exception.hs 107 - -- |The following two functions allow a thread to control delivery of + -- |The following functions allow a thread to control delivery of hunk ./Control/Exception.hs 110 + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + + -- ** (deprecated) Asynchronous exception control + hunk ./Control/Exception.hs 150 --- import GHC.IO hiding ( onException, finally ) hunk ./Control/Exception.hs 254 -There\'s an implied 'block' around every exception handler in a call +There\'s an implied 'mask' around every exception handler in a call hunk ./Control/Exception.hs 264 -> block ( -> catch (unblock (...)) -> (\e -> handler) -> ) +> block $ \restore -> +> catch (restore (...)) +> (\e -> handler) hunk ./Control/Exception.hs 278 + #interruptible# hunk ./Control/Exception.hs 288 -> block ( +> mask $ \restore -> do hunk ./Control/Exception.hs 290 -> catch (unblock (...)) +> catch (restore (...)) hunk ./Control/Exception.hs 292 -> ) hunk ./Control/Exception/Base.hs 82 + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + + -- ** (deprecated) Asynchronous exception control + hunk ./Control/Exception/Base.hs 517 - block (do + mask $ \restore -> do hunk ./Control/Exception/Base.hs 519 - r <- unblock (thing a) `onException` after a + r <- restore (thing a) `onException` after a hunk ./Control/Exception/Base.hs 522 - ) hunk ./Control/Exception/Base.hs 532 - block (do - r <- unblock a `onException` sequel + mask $ \restore -> do + r <- restore a `onException` sequel hunk ./Control/Exception/Base.hs 536 - ) hunk ./Control/Exception/Base.hs 550 - block (do + mask $ \restore -> do hunk ./Control/Exception/Base.hs 552 - unblock (thing a) `onException` after a - ) + restore (thing a) `onException` after a hunk ./Control/OldException.hs 154 -import Control.Exception ( toException, fromException, throw, block, unblock, evaluate, throwIO ) +import Control.Exception ( toException, fromException, throw, block, unblock, mask, evaluate, throwIO ) hunk ./Control/OldException.hs 455 - block (do + mask $ \restore -> do hunk ./Control/OldException.hs 458 - (unblock (thing a)) + (restore (thing a)) hunk ./Control/OldException.hs 462 - ) hunk ./Control/OldException.hs 472 - block (do + mask $ \restore -> do hunk ./Control/OldException.hs 474 - (unblock a) + (restore a) hunk ./Control/OldException.hs 478 - ) hunk ./Control/OldException.hs 492 - block (do + mask $ \restore -> do hunk ./Control/OldException.hs 495 - (unblock (thing a)) + (restore (thing a)) hunk ./Control/OldException.hs 497 - ) hunk ./Control/OldException.hs 523 -There\'s an implied 'block' around every exception handler in a call +There\'s an implied 'mask_' around every exception handler in a call hunk ./Control/OldException.hs 533 -> block ( -> catch (unblock (...)) +> mask $ \restore -> +> catch (restore (...)) hunk ./Control/OldException.hs 536 -> ) hunk ./Control/OldException.hs 543 -'block'. +'mask'. hunk ./Control/OldException.hs 549 -asynchronous exceptions even in the scope of a 'block'. Any function +asynchronous exceptions even in the scope of a 'mask'. Any function hunk ./Control/OldException.hs 557 -> block ( +> mask $ \restore -> do hunk ./Control/OldException.hs 559 -> catch (unblock (...)) +> catch (restore (...)) hunk ./Control/OldException.hs 561 -> ) hunk ./Data/HashTable.hs 1 -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -fno-warn-name-shadowing #-} hunk ./Data/Typeable.hs 99 -import GHC.IO (unsafePerformIO,block) +import GHC.IO (unsafePerformIO,mask_) hunk ./Data/Typeable.hs 684 - block $ do + mask_ $ do hunk ./Foreign/Marshal/Pool.hs 51 -import GHC.IO ( IO, block, unblock, catchAny ) +import GHC.IO ( IO, mask, catchAny ) hunk ./Foreign/Marshal/Pool.hs 100 - block (do + mask (\restore -> do hunk ./Foreign/Marshal/Pool.hs 103 - (unblock (act pool)) + (restore (act pool)) hunk ./GHC/Conc.lhs 32 + , forkIOUnmasked hunk ./GHC/Conc.lhs 34 + , forkOnIOUnmasked hunk ./GHC/Conc.lhs 216 -GHC note: the new thread inherits the /blocked/ state of the parent -(see 'Control.Exception.block'). +GHC note: the new thread inherits the /masked/ state of the parent +(see 'Control.Exception.mask'). hunk ./GHC/Conc.lhs 230 +-- | Like 'forkIO', but the child thread is created with asynchronous exceptions +-- unmasked (see 'Control.Exception.mask'). +forkIOUnmasked :: IO () -> IO ThreadId +forkIOUnmasked io = forkIO (unsafeUnmask io) + hunk ./GHC/Conc.lhs 254 +-- | Like 'forkOnIO', but the child thread is created with +-- asynchronous exceptions unmasked (see 'Control.Exception.mask'). +forkOnIOUnmasked :: Int -> IO () -> IO ThreadId +forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io) + hunk ./GHC/Conc.lhs 316 -the call is inside a 'block' or not. +the call is inside a 'mask' or not. hunk ./GHC/Conc.lhs 626 - block $ do + mask $ \restore -> do hunk ./GHC/Conc.lhs 628 - b <- catchAny (unblock (io a)) + b <- catchAny (restore (io a)) hunk ./GHC/Conc.lhs 635 - block $ do + mask $ \restore -> do hunk ./GHC/Conc.lhs 637 - a' <- catchAny (unblock (io a)) + a' <- catchAny (restore (io a)) hunk ./GHC/Conc.lhs 876 - block $ do + mask_ $ do hunk ./GHC/IO.hs 1 -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -XBangPatterns #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude, BangPatterns, RankNTypes #-} hunk ./GHC/IO.hs 31 - block, unblock, blocked, + mask, mask_, uninterruptibleMask, uninterruptibleMask_, + MaskingState(..), getMaskingState, + block, unblock, blocked, unsafeUnmask, hunk ./GHC/IO.hs 40 +import GHC.Show hunk ./GHC/IO.hs 284 --- | Applying 'block' to a computation will +{-# DEPRECATED block "use Control.Exception.mask instead" #-} +-- | Note: this function is deprecated, please use 'mask' instead. +-- +-- Applying 'block' to a computation will hunk ./GHC/IO.hs 291 --- blocked until asynchronous exceptions are enabled again. There\'s +-- blocked until asynchronous exceptions are unblocked again. There\'s hunk ./GHC/IO.hs 302 +block (IO io) = IO $ maskAsyncExceptions# io hunk ./GHC/IO.hs 304 --- | To re-enable asynchronous exceptions inside the scope of +{-# DEPRECATED unblock "use Control.Exception.mask instead" #-} +-- | Note: this function is deprecated, please use 'mask' instead. +-- +-- To re-enable asynchronous exceptions inside the scope of hunk ./GHC/IO.hs 313 +unblock = unsafeUnmask + +unsafeUnmask :: IO a -> IO a +unsafeUnmask (IO io) = IO $ unmaskAsyncExceptions# io + +blockUninterruptible :: IO a -> IO a +blockUninterruptible (IO io) = IO $ maskUninterruptible# io hunk ./GHC/IO.hs 321 -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io +-- | Describes the behaviour of a thread when an asynchronous +-- exception is received. +data MaskingState + = Unmasked -- ^ asynchronous exceptions are unmasked (the normal state) + | MaskedInterruptible + -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted + | MaskedUninterruptible + -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted + deriving (Eq,Show) + +-- | Returns the 'MaskingState' for the current thread. +getMaskingState :: IO MaskingState +getMaskingState = IO $ \s -> + case getMaskingState# s of + (# s', i #) -> (# s', case i of + 0# -> Unmasked + 1# -> MaskedUninterruptible + _ -> MaskedInterruptible #) hunk ./GHC/IO.hs 343 -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) +blocked = fmap (/= Unmasked) getMaskingState hunk ./GHC/IO.hs 349 +-- | Executes an IO computation with asynchronous +-- exceptions /masked/. That is, any thread which attempts to raise +-- an exception in the current thread with 'Control.Exception.throwTo' +-- will be blocked until asynchronous exceptions are unmasked again. +-- +-- The argument passed to 'mask' is a function that takes as its +-- argument another function, which can be used to restore the +-- prevailing masking state within the context of the masked +-- computation. For example, a common way to use 'mask' is to protect +-- the acquisition of a resource: +-- +-- > mask $ \restore -> do +-- > x <- acquire +-- > restore (do_something_with x) `onException` release +-- > release +-- +-- This code guarantees that @acquire@ is paired with @release@, by masking +-- asynchronous exceptions for the critical parts. (Rather than write +-- this code yourself, it would be better to use +-- 'Control.Exception.bracket' which abstracts the general pattern). +-- +-- Note that the @restore@ action passed to the argument to 'mask' +-- does not necessarily unmask asynchronous exceptions, it just +-- restores the masking state to that of the enclosing context. Thus +-- if asynchronous exceptions are already masked, 'mask' cannot be used +-- to unmask exceptions again. This is so that if you call a library function +-- with exceptions masked, you can be sure that the library call will not be +-- able to unmask exceptions again. If you are writing library code and need +-- to use asynchronous exceptions, the only way is to create a new thread; +-- see 'Control.Concurrent.forkIOUnmasked'. +-- +-- Asynchronous exceptions may still be received while in the masked +-- state if the masked thread /blocks/ in certain ways; see +-- "Control.Exception#interruptible". +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the masked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @mask_ $ forkIO ...@. This is particularly useful if you need +-- to establish an exception handler in the forked thread before any +-- asynchronous exceptions are received. To create a a new thread in +-- an unmasked state use 'Control.Concurrent.forkIOUnmasked'. +-- +mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b + +-- | Like 'mask', but does not pass a @restore@ action to the argument. +mask_ :: IO a -> IO a + +-- | Like 'mask', but the masked computation is not interruptible (see +-- "Control.Exception#interruptible"). THIS SHOULD BE USED WITH +-- GREAT CARE, because if a thread executing in 'uninterruptibleMask' +-- blocks for any reason, then the thread (and possibly the program, +-- if this is the main thread) will be unresponsive and unkillable. +-- This function should only be necessary if you need to mask +-- exceptions around an interruptible operation, and you can guarantee +-- that the interruptible operation will only block for a short period +-- of time. +-- +uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b + +-- | Like 'uninterruptibleMask', but does not pass a @restore@ action +-- to the argument. +uninterruptibleMask_ :: IO a -> IO a + +mask_ io = mask $ \_ -> io + +mask io = do + b <- getMaskingState + case b of + Unmasked -> block $ io unblock + _ -> io id + +uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io + +uninterruptibleMask io = do + b <- getMaskingState + case b of + Unmasked -> blockUninterruptible $ io unblock + MaskedInterruptible -> blockUninterruptible $ io block + MaskedUninterruptible -> io id + hunk ./GHC/IO.hs 434 - block (do - r <- unblock a `onException` sequel + mask $ \restore -> do + r <- restore a `onException` sequel hunk ./GHC/IO.hs 438 - ) hunk ./GHC/IO/Handle/Internals.hs 127 - block $ do + mask_ $ do hunk ./GHC/IO/Handle/Internals.hs 152 - block $ do + mask_ $ do hunk ./Control/Exception.hs 111 +#ifndef __NHC__ hunk ./Control/Exception.hs 117 +#endif hunk ./Control/Exception/Base.hs 81 - hunk ./Control/Exception/Base.hs 82 +#ifndef __NHC__ hunk ./Control/Exception/Base.hs 88 +#endif hunk ./Control/Exception/Base.hs 227 +mask :: ((IO a-> IO a) -> IO a) -> IO a +mask action = action restore + where restore act = act + hunk ./System/IO.hs 31 - -- the garbage collector is unpredictable. If possible, use explicit + -- the garbage collector is unpredictable. If possible, use hunk ./GHC/IO/Handle/Internals.hs 586 --- full-dupliex streams, such as network sockets. +-- full-duplex streams, such as network sockets. hunk ./GHC/Read.lhs 317 +-- We match both Ident and Symbol because the constructor +-- might be an operator eg (:=:) hunk ./GHC/Read.lhs 321 - try_one (s,p) = do { L.Ident s' <- lexP ; - if s == s' then p else pfail } + try_one (s,p) = do { token <- lexP ; + case token of + L.Ident s' | s==s' -> p + L.Symbol s' | s==s' -> p + _other -> pfail } hunk ./Foreign/Ptr.hs 108 --- @Ptr@. +-- @Ptr@. This type is also compatible with the C99 type @uintptr_t@, and +-- can be marshalled to and from that type safely. hunk ./Foreign/Ptr.hs 114 --- @Ptr@. +-- @Ptr@. This type is also compatible with the C99 type @intptr_t@, and +-- can be marshalled to and from that type safely. hunk ./Foreign/C/String.hs 62 + castCharToCUChar, -- :: Char -> CUChar + castCUCharToChar, -- :: CUChar -> Char + castCharToCSChar, -- :: Char -> CSChar + castCSCharToChar, -- :: CSChar -> Char + hunk ./Foreign/C/String.hs 207 +-- | Convert a C @unsigned char@, representing a Latin-1 character, to +-- the corresponding Haskell character. +castCUCharToChar :: CUChar -> Char +castCUCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) + +-- | Convert a Haskell character to a C @unsigned char@. +-- This function is only safe on the first 256 characters. +castCharToCUChar :: Char -> CUChar +castCharToCUChar ch = fromIntegral (ord ch) + +-- | Convert a C @signed char@, representing a Latin-1 character, to the +-- corresponding Haskell character. +castCSCharToChar :: CSChar -> Char +castCSCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) + +-- | Convert a Haskell character to a C @signed char@. +-- This function is only safe on the first 256 characters. +castCharToCSChar :: Char -> CSChar +castCharToCSChar ch = fromIntegral (ord ch) + hunk ./GHC/List.lhs 506 --- of the list satisfies the predicate. +-- of the list satisfies the predicate. For the result to be +-- 'False', the list must be finite; 'True', however, results from a 'True' +-- value for the predicate applied to an element at a finite index of a finite or infinite list. hunk ./GHC/List.lhs 512 --- of the list satisfy the predicate. +-- of the list satisfy the predicate. For the result to be +-- 'True', the list must be finite; 'False', however, results from a 'False' +-- value for the predicate applied to an element at a finite index of a finite or infinite list. hunk ./GHC/List.lhs 534 --- e.g., @x \`elem\` xs@. +-- e.g., @x \`elem\` xs@. For the result to be +-- 'False', the list must be finite; 'True', however, results from an element equal to @x@ found at a finite index of a finite or infinite list. hunk ./Data/Bits.hs 129 - -- | @bit i@ is a value with the @i@th bit set + -- | @bit i@ is a value with the @i@th bit set and all other bits clear hunk ./Foreign/ForeignPtr.hs 104 --- associates a finaliser with the reference. The finaliser will be +-- associates a finalizer with the reference. The finalizer will be hunk ./System/IO.hs 452 --- raising an exception. +-- raising an exception. If closing the handle raises an exception, then +-- this exception will be raised by 'withFile' rather than any exception +-- raised by 'act'. hunk ./Foreign/Marshal/Alloc.hs 12 --- Marshalling support: basic routines for memory allocation +-- The module "Foreign.Marshal.Alloc" provides operations to allocate and +-- deallocate blocks of raw memory (i.e., unstructured chunks of memory +-- outside of the area maintained by the Haskell storage manager). These +-- memory blocks are commonly used to pass compound data structures to +-- foreign functions or to provide space in which compound result values +-- are obtained from foreign functions. +-- +-- If any of the allocation functions fails, a value of 'nullPtr' is +-- produced. If 'free' or 'reallocBytes' is applied to a memory area +-- that has been allocated with 'alloca' or 'allocaBytes', the +-- behaviour is undefined. Any further access to memory areas allocated with +-- 'alloca' or 'allocaBytes', after the computation that was passed to +-- the allocation function has terminated, leads to undefined behaviour. Any +-- further access to the memory area referenced by a pointer passed to +-- 'realloc', 'reallocBytes', or 'free' entails undefined +-- behaviour. +-- +-- All storage allocated by functions that allocate based on a /size in bytes/ +-- must be sufficiently aligned for any of the basic foreign types +-- that fits into the newly allocated storage. All storage allocated by +-- functions that allocate based on a specific type must be sufficiently +-- aligned for that type. Array allocation routines need to obey the same +-- alignment constraints for each array element. hunk ./GHC/IO/Handle.hs 398 --- not support the requested seek mode. +-- not support the requested seek mode. +-- hunk ./Foreign.hs 27 - -- | For compatibility with the FFI addendum only. The recommended - -- place to get this from is "System.IO.Unsafe". + -- | 'unsafePerformIO' is exported here for backwards + -- compatibility reasons only. For doing local marshalling in + -- the FFI, use 'unsafeLocalState'. For other uses, see + -- 'System.IO.Unsafe.unsafePerformIO'. hunk ./Foreign/Marshal.hs 17 - ( module Foreign.Marshal.Alloc + ( + -- | The module "Foreign.Marshal" re-exports the other modules in the + -- @Foreign.Marshal@ hierarchy: + module Foreign.Marshal.Alloc hunk ./Foreign/Marshal.hs 25 + -- | and provides one function: + , unsafeLocalState hunk ./Foreign/Marshal.hs 34 + +import GHC.IO + +{- | +Sometimes an external entity is a pure function, except that it passes +arguments and/or results via pointers. The function +@unsafeLocalState@ permits the packaging of such entities as pure +functions. + +The only IO operations allowed in the IO action passed to +@unsafeLocalState@ are (a) local allocation (@alloca@, @allocaBytes@ +and derived operations such as @withArray@ and @withCString@), and (b) +pointer operations (@Foreign.Storable@ and @Foreign.Ptr@) on the +pointers to local storage, and (c) foreign functions whose only +observable effect is to read and/or write the locally allocated +memory. Passing an IO operation that does not obey these rules +results in undefined behaviour. + +It is expected that this operation will be +replaced in a future revision of Haskell. +-} +unsafeLocalState :: IO a -> a +unsafeLocalState = unsafePerformIO hunk ./GHC/Conc.lhs 36 + , numSparks -- :: IO Int hunk ./GHC/Conc.lhs 269 +-- | Returns the number of sparks currently in the local spark pool +numSparks :: IO Int +numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #) + hunk ./Foreign/Marshal.hs 35 +#ifdef __GLASGOW_HASKELL__ hunk ./Foreign/Marshal.hs 37 +#else +import System.IO.Unsafe +#endif hunk ./Control/Monad/Fix.hs 81 +-- Prelude types with Monad instances in Control.Monad.Instances + hunk ./Control/Monad/Fix.hs 86 +instance MonadFix (Either e) where + mfix f = let a = f (unRight a) in a + where unRight (Right x) = x + unRight (Left _) = error "mfix Either: Left" + hunk ./Control/Monad/Instances.hs 35 +instance Monad (Either e) where + return = Right + Left l >>= _ = Left l + Right r >>= k = k r + hunk ./Control/Monad.hs 49 + , mfilter -- :: (MonadPlus m) => (a -> Bool) -> m a -> m a hunk ./Control/Monad.hs 315 +-- ----------------------------------------------------------------------------- +-- Other MonadPlus functions + +-- | Direct 'MonadPlus' equivalent of 'filter' +-- @'filter'@ = @(mfilter:: (a -> Bool) -> [a] -> [a]@ +-- applicable to any 'MonadPlus', for example +-- @mfilter odd (Just 1) == Just 1@ +-- @mfilter odd (Just 2) == Nothing@ + +mfilter :: (MonadPlus m) => (a -> Bool) -> m a -> m a +mfilter p ma = do + a <- ma + if p a then return a else mzero + adddir ./GHC/Conc move ./GHC/Conc.lhs ./GHC/Conc/Sync.lhs adddir ./System/Event hunk ./Control/Exception/Base.hs 123 -import GHC.Conc +import GHC.Conc.Sync addfile ./GHC/Conc.lhs hunk ./GHC/Conc.lhs 1 +\begin{code} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +-- No: #hide, because bits of this module are exposed by the stm package. +-- However, we don't want this module to be the home location for the +-- bits it exports, we'd rather have Control.Concurrent and the other +-- higher level modules be the home. Hence: + +#include "Typeable.h" + +-- #not-home +module GHC.Conc + ( ThreadId(..) + + -- * Forking and suchlike + , forkIO -- :: IO a -> IO ThreadId + , forkIOUnmasked + , forkOnIO -- :: Int -> IO a -> IO ThreadId + , forkOnIOUnmasked + , numCapabilities -- :: Int + , numSparks -- :: IO Int + , childHandler -- :: Exception -> IO () + , myThreadId -- :: IO ThreadId + , killThread -- :: ThreadId -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () + , par -- :: a -> b -> b + , pseq -- :: a -> b -> b + , runSparks + , yield -- :: IO () + , labelThread -- :: ThreadId -> String -> IO () + + , ThreadStatus(..), BlockReason(..) + , threadStatus -- :: ThreadId -> IO ThreadStatus + + -- * Waiting + , threadDelay -- :: Int -> IO () + , registerDelay -- :: Int -> IO (TVar Bool) + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () + + -- * TVars + , STM(..) + , atomically -- :: STM a -> IO a + , retry -- :: STM a + , orElse -- :: STM a -> STM a -> STM a + , catchSTM -- :: STM a -> (Exception -> STM a) -> STM a + , alwaysSucceeds -- :: STM a -> STM () + , always -- :: STM Bool -> STM () + , TVar(..) + , newTVar -- :: a -> STM (TVar a) + , newTVarIO -- :: a -> STM (TVar a) + , readTVar -- :: TVar a -> STM a + , readTVarIO -- :: TVar a -> IO a + , writeTVar -- :: a -> TVar a -> STM () + , unsafeIOToSTM -- :: IO a -> STM a + + -- * Miscellaneous + , withMVar +#ifdef mingw32_HOST_OS + , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int + + , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) +#endif + +#ifndef mingw32_HOST_OS + , Signal, HandlerFun, setHandler, runHandlers +#endif + + , ensureIOManagerIsRunning + +#ifdef mingw32_HOST_OS + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + , setUncaughtExceptionHandler -- :: (Exception -> IO ()) -> IO () + , getUncaughtExceptionHandler -- :: IO (Exception -> IO ()) + + , reportError, reportStackOverflow + ) where + +import GHC.Conc.IO +import GHC.Conc.Sync + +#ifndef mingw32_HOST_OS +import GHC.Conc.Signal +#endif + +\end{code} addfile ./GHC/Conc/IO.hs hunk ./GHC/Conc/IO.hs 1 +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.IO +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Basic concurrency stuff. +-- +----------------------------------------------------------------------------- + +-- No: #hide, because bits of this module are exposed by the stm package. +-- However, we don't want this module to be the home location for the +-- bits it exports, we'd rather have Control.Concurrent and the other +-- higher level modules be the home. Hence: + +#include "Typeable.h" + +-- #not-home +module GHC.Conc.IO + ( ensureIOManagerIsRunning + + -- * Waiting + , threadDelay -- :: Int -> IO () + , registerDelay -- :: Int -> IO (TVar Bool) + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () + +#ifdef mingw32_HOST_OS + , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int + + , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent +#endif + ) where + +import Control.Monad +import Foreign +import GHC.Base +import GHC.Conc.Sync as Sync +import GHC.Real ( fromIntegral ) +import System.Posix.Types + +#ifdef mingw32_HOST_OS +import qualified GHC.Conc.Windows as Windows +import GHC.Conc.Windows (asyncRead, asyncWrite, asyncDoProc, asyncReadBA, + asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler, + toWin32ConsoleEvent) +#else +import qualified System.Event.Thread as Event +#endif + +ensureIOManagerIsRunning :: IO () +#ifndef mingw32_HOST_OS +ensureIOManagerIsRunning = Event.ensureIOManagerIsRunning +#else +ensureIOManagerIsRunning = Windows.ensureIOManagerIsRunning +#endif + +-- | Block the current thread until data is available to read on the +-- given file descriptor (GHC only). +threadWaitRead :: Fd -> IO () +threadWaitRead fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitRead fd +#endif + | otherwise = IO $ \s -> + case fromIntegral fd of { I# fd# -> + case waitRead# fd# s of { s' -> (# s', () #) + }} + +-- | Block the current thread until data can be written to the +-- given file descriptor (GHC only). +threadWaitWrite :: Fd -> IO () +threadWaitWrite fd +#ifndef mingw32_HOST_OS + | threaded = Event.threadWaitWrite fd +#endif + | otherwise = IO $ \s -> + case fromIntegral fd of { I# fd# -> + case waitWrite# fd# s of { s' -> (# s', () #) + }} + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +-- +threadDelay :: Int -> IO () +threadDelay time +#ifdef mingw32_HOST_OS + | threaded = Windows.threadDelay time +#else + | threaded = Event.threadDelay time +#endif + | otherwise = IO $ \s -> + case fromIntegral time of { I# time# -> + case delay# time# s of { s' -> (# s', () #) + }} + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs +#ifdef mingw32_HOST_OS + | threaded = Windows.registerDelay usecs +#else + | threaded = Event.registerDelay usecs +#endif + | otherwise = error "registerDelay: requires -threaded" + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool addfile ./GHC/Conc/Signal.hs hunk ./GHC/Conc/Signal.hs 1 +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Conc.Signal + ( Signal + , HandlerFun + , setHandler + , runHandlers + ) where + +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Data.Dynamic (Dynamic) +import Data.Maybe (Maybe(..)) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (ForeignPtr) +import Foreign.StablePtr (castPtrToStablePtr, castStablePtrToPtr, + deRefStablePtr, freeStablePtr, newStablePtr) +import Foreign.Ptr (Ptr, castPtr) +import GHC.Arr (inRange) +import GHC.Base +import GHC.Conc.Sync (forkIO) +import GHC.IO (mask_, unsafePerformIO) +import GHC.IOArray (IOArray, boundsIOArray, newIOArray, unsafeReadIOArray, + unsafeWriteIOArray) +import GHC.Num (fromInteger) +import GHC.Real (fromIntegral) +import GHC.Word (Word8) + +------------------------------------------------------------------------ +-- Signal handling + +type Signal = CInt + +maxSig :: Int +maxSig = 64 + +type HandlerFun = ForeignPtr Word8 -> IO () + +-- Lock used to protect concurrent access to signal_handlers. Symptom +-- of this race condition is GHC bug #1922, although that bug was on +-- Windows a similar bug also exists on Unix. +signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic))) +signal_handlers = unsafePerformIO $ do + arr <- newIOArray (0, maxSig) Nothing + m <- newMVar arr + sharedCAF m getOrSetGHCConcSignalSignalHandlerStore +{-# NOINLINE signal_handlers #-} + +foreign import ccall unsafe "getOrSetGHCConcSignalSignalHandlerStore" + getOrSetGHCConcSignalSignalHandlerStore :: Ptr a -> IO (Ptr a) + +setHandler :: Signal -> Maybe (HandlerFun, Dynamic) + -> IO (Maybe (HandlerFun, Dynamic)) +setHandler sig handler = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then error "GHC.Conc.setHandler: signal out of range" + else do old <- unsafeReadIOArray arr int + unsafeWriteIOArray arr int handler + return old + +runHandlers :: ForeignPtr Word8 -> Signal -> IO () +runHandlers p_info sig = do + let int = fromIntegral sig + withMVar signal_handlers $ \arr -> + if not (inRange (boundsIOArray arr) int) + then return () + else do handler <- unsafeReadIOArray arr int + case handler of + Nothing -> return () + Just (f,_) -> do _ <- forkIO (f p_info) + return () + +-- Machinery needed to ensure that we only have one copy of certain +-- CAFs in this module even when the base package is present twice, as +-- it is when base is dynamically loaded into GHCi. The RTS keeps +-- track of the single true value of the CAF, so even when the CAFs in +-- the dynamically-loaded base package are reverted, nothing bad +-- happens. +-- +sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a +sharedCAF a get_or_set = + mask_ $ do + stable_ref <- newStablePtr a + let ref = castPtr (castStablePtrToPtr stable_ref) + ref2 <- get_or_set ref + if ref == ref2 + then return a + else do freeStablePtr stable_ref + deRefStablePtr (castPtrToStablePtr (castPtr ref2)) + hunk ./GHC/Conc/Sync.lhs 7 --- Module : GHC.Conc +-- Module : GHC.Conc.Sync hunk ./GHC/Conc/Sync.lhs 10 --- +-- hunk ./GHC/Conc/Sync.lhs 16 --- +-- hunk ./GHC/Conc/Sync.lhs 27 -module GHC.Conc +module GHC.Conc.Sync hunk ./GHC/Conc/Sync.lhs 50 - -- * Waiting - , threadDelay -- :: Int -> IO () - , registerDelay -- :: Int -> IO (TVar Bool) - , threadWaitRead -- :: Int -> IO () - , threadWaitWrite -- :: Int -> IO () - hunk ./GHC/Conc/Sync.lhs 68 -#ifdef mingw32_HOST_OS - , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) - , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) - , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int - - , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) - , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) -#endif - -#ifndef mingw32_HOST_OS - , Signal, HandlerFun, setHandler, runHandlers -#endif - - , ensureIOManagerIsRunning -#ifndef mingw32_HOST_OS - , syncIOManager -#endif + , modifyMVar_ hunk ./GHC/Conc/Sync.lhs 70 -#ifdef mingw32_HOST_OS - , ConsoleEvent(..) - , win32ConsoleHandler - , toWin32ConsoleEvent -#endif hunk ./GHC/Conc/Sync.lhs 74 + + , sharedCAF hunk ./GHC/Conc/Sync.lhs 78 -import System.Posix.Types -#ifndef mingw32_HOST_OS -import System.Posix.Internals -#endif hunk ./GHC/Conc/Sync.lhs 92 -#ifndef mingw32_HOST_OS -import GHC.Debug -#endif hunk ./GHC/Conc/Sync.lhs 101 -#ifndef mingw32_HOST_OS -import GHC.IOArray -import GHC.Arr ( inRange ) -#endif -#ifdef mingw32_HOST_OS -import GHC.Real ( div ) -import GHC.Ptr -#endif -#ifdef mingw32_HOST_OS -import GHC.Read ( Read ) -import GHC.Enum ( Enum ) -#endif hunk ./GHC/Conc/Sync.lhs 137 - showsPrec d t = - showString "ThreadId " . + showsPrec d t = + showString "ThreadId " . hunk ./GHC/Conc/Sync.lhs 150 -cmpThread t1 t2 = +cmpThread t1 t2 = hunk ./GHC/Conc/Sync.lhs 157 - t1 == t2 = + t1 == t2 = hunk ./GHC/Conc/Sync.lhs 182 -forkIO action = IO $ \ s -> +forkIO action = IO $ \ s -> hunk ./GHC/Conc/Sync.lhs 206 -forkOnIO (I# cpu) action = IO $ \ s -> +forkOnIO (I# cpu) action = IO $ \ s -> hunk ./GHC/Conc/Sync.lhs 221 -numCapabilities = unsafePerformIO $ do +numCapabilities = unsafePerformIO $ do hunk ./GHC/Conc/Sync.lhs 252 -thread (GHC only). +thread (GHC only). hunk ./GHC/Conc/Sync.lhs 263 -target thread. +target thread. hunk ./GHC/Conc/Sync.lhs 315 -yield = IO $ \s -> +yield = IO $ \s -> hunk ./GHC/Conc/Sync.lhs 343 --- "y" before "x", which is totally wrong. +-- "y" before "x", which is totally wrong. hunk ./GHC/Conc/Sync.lhs 440 - case m s of + case m s of hunk ./GHC/Conc/Sync.lhs 446 - case m s of + case m s of hunk ./GHC/Conc/Sync.lhs 458 --- dangerous thing to do. +-- dangerous thing to do. hunk ./GHC/Conc/Sync.lhs 482 --- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. +-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. hunk ./GHC/Conc/Sync.lhs 514 --- checkInv differs form these in that (i) the invariant is not +-- checkInv differs form these in that (i) the invariant is not hunk ./GHC/Conc/Sync.lhs 527 -alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) +alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () ) hunk ./GHC/Conc/Sync.lhs 579 - + hunk ./GHC/Conc/Sync.lhs 586 -withMVar m io = +withMVar m io = hunk ./GHC/Conc/Sync.lhs 611 -#ifdef mingw32_HOST_OS - --- Note: threadWaitRead and threadWaitWrite aren't really functional --- on Win32, but left in there because lib code (still) uses them (the manner --- in which they're used doesn't cause problems on a Win32 platform though.) - -asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) -asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = - IO $ \s -> case asyncRead# fd isSock len buf s of - (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) - -asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) -asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = - IO $ \s -> case asyncWrite# fd isSock len buf s of - (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) hunk ./GHC/Conc/Sync.lhs 612 -asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int -asyncDoProc (FunPtr proc) (Ptr param) = - -- the 'length' value is ignored; simplifies implementation of - -- the async*# primops to have them all return the same result. - IO $ \s -> case asyncDoProc# proc param s of - (# s', _len#, err# #) -> (# s', I# err# #) - --- to aid the use of these primops by the IO Handle implementation, --- provide the following convenience funs: - --- this better be a pinned byte array! -asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) -asyncReadBA fd isSock len off bufB = - asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) - -asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) -asyncWriteBA fd isSock len off bufB = - asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) - -#endif - --- ----------------------------------------------------------------------------- --- Thread IO API - --- | Block the current thread until data is available to read on the --- given file descriptor (GHC only). -threadWaitRead :: Fd -> IO () -threadWaitRead fd -#ifndef mingw32_HOST_OS - | threaded = waitForReadEvent fd -#endif - | otherwise = IO $ \s -> - case fromIntegral fd of { I# fd# -> - case waitRead# fd# s of { s' -> (# s', () #) - }} - --- | Block the current thread until data can be written to the --- given file descriptor (GHC only). -threadWaitWrite :: Fd -> IO () -threadWaitWrite fd -#ifndef mingw32_HOST_OS - | threaded = waitForWriteEvent fd -#endif - | otherwise = IO $ \s -> - case fromIntegral fd of { I# fd# -> - case waitWrite# fd# s of { s' -> (# s', () #) - }} - --- | Suspends the current thread for a given number of microseconds --- (GHC only). --- --- There is no guarantee that the thread will be rescheduled promptly --- when the delay has expired, but the thread will never continue to --- run /earlier/ than specified. --- -threadDelay :: Int -> IO () -threadDelay time - | threaded = waitForDelayEvent time - | otherwise = IO $ \s -> - case fromIntegral time of { I# time# -> - case delay# time# s of { s' -> (# s', () #) - }} - - --- | Set the value of returned TVar to True after a given number of --- microseconds. The caveats associated with threadDelay also apply. --- -registerDelay :: Int -> IO (TVar Bool) -registerDelay usecs - | threaded = waitForDelayEventSTM usecs - | otherwise = error "registerDelay: requires -threaded" - -foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool - -waitForDelayEvent :: Int -> IO () -waitForDelayEvent usecs = do - m <- newEmptyMVar - target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) - prodServiceThread - takeMVar m - --- Delays for use in STM -waitForDelayEventSTM :: Int -> IO (TVar Bool) -waitForDelayEventSTM usecs = do - t <- atomically $ newTVar False - target <- calculateTarget usecs - atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) - prodServiceThread - return t - -calculateTarget :: Int -> IO USecs -calculateTarget usecs = do - now <- getUSecOfDay - return $ now + (fromIntegral usecs) - - --- ---------------------------------------------------------------------------- --- Threaded RTS implementation of threadWaitRead, threadWaitWrite, threadDelay - --- In the threaded RTS, we employ a single IO Manager thread to wait --- for all outstanding IO requests (threadWaitRead,threadWaitWrite) --- and delays (threadDelay). --- --- We can do this because in the threaded RTS the IO Manager can make --- a non-blocking call to select(), so we don't have to do select() in --- the scheduler as we have to in the non-threaded RTS. We get performance --- benefits from doing it this way, because we only have to restart the select() --- when a new request arrives, rather than doing one select() each time --- around the scheduler loop. Furthermore, the scheduler can be simplified --- by not having to check for completed IO requests. - -#ifndef mingw32_HOST_OS -data IOReq - = Read {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ()) - | Write {-# UNPACK #-} !Fd {-# UNPACK #-} !(MVar ()) -#endif - -data DelayReq - = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ()) - | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) - -#ifndef mingw32_HOST_OS -{-# NOINLINE pendingEvents #-} -pendingEvents :: IORef [IOReq] -pendingEvents = unsafePerformIO $ do - m <- newIORef [] - sharedCAF m getOrSetGHCConcPendingEventsStore - -foreign import ccall unsafe "getOrSetGHCConcPendingEventsStore" - getOrSetGHCConcPendingEventsStore :: Ptr a -> IO (Ptr a) -#endif - -{-# NOINLINE pendingDelays #-} -pendingDelays :: IORef [DelayReq] -pendingDelays = unsafePerformIO $ do - m <- newIORef [] - sharedCAF m getOrSetGHCConcPendingDelaysStore - -foreign import ccall unsafe "getOrSetGHCConcPendingDelaysStore" - getOrSetGHCConcPendingDelaysStore :: Ptr a -> IO (Ptr a) - -{-# NOINLINE ioManagerThread #-} -ioManagerThread :: MVar (Maybe ThreadId) -ioManagerThread = unsafePerformIO $ do - m <- newMVar Nothing - sharedCAF m getOrSetGHCConcIOManagerThreadStore - -foreign import ccall unsafe "getOrSetGHCConcIOManagerThreadStore" - getOrSetGHCConcIOManagerThreadStore :: Ptr a -> IO (Ptr a) - -ensureIOManagerIsRunning :: IO () -ensureIOManagerIsRunning - | threaded = startIOManagerThread - | otherwise = return () - -startIOManagerThread :: IO () -startIOManagerThread = do - modifyMVar_ ioManagerThread $ \old -> do - let create = do t <- forkIO ioManager; return (Just t) - case old of - Nothing -> create - Just t -> do - s <- threadStatus t - case s of - ThreadFinished -> create - ThreadDied -> create - _other -> return (Just t) - -insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] -insertDelay d [] = [d] -insertDelay d1 ds@(d2 : rest) - | delayTime d1 <= delayTime d2 = d1 : ds - | otherwise = d2 : insertDelay d1 rest - -delayTime :: DelayReq -> USecs -delayTime (Delay t _) = t -delayTime (DelaySTM t _) = t - -type USecs = Word64 - -foreign import ccall unsafe "getUSecOfDay" - getUSecOfDay :: IO USecs - -{-# NOINLINE prodding #-} -prodding :: IORef Bool -prodding = unsafePerformIO $ do - r <- newIORef False - sharedCAF r getOrSetGHCConcProddingStore - -foreign import ccall unsafe "getOrSetGHCConcProddingStore" - getOrSetGHCConcProddingStore :: Ptr a -> IO (Ptr a) - -prodServiceThread :: IO () -prodServiceThread = do - -- NB. use atomicModifyIORef here, otherwise there are race - -- conditions in which prodding is left at True but the server is - -- blocked in select(). - was_set <- atomicModifyIORef prodding $ \b -> (True,b) - unless was_set wakeupIOManager - --- Machinery needed to ensure that we only have one copy of certain +-- Machinery needed to ensureb that we only have one copy of certain hunk ./GHC/Conc/Sync.lhs 630 -#ifdef mingw32_HOST_OS --- ---------------------------------------------------------------------------- --- Windows IO manager thread - -ioManager :: IO () -ioManager = do - wakeup <- c_getIOManagerEvent - service_loop wakeup [] - -service_loop :: HANDLE -- read end of pipe - -> [DelayReq] -- current delay requests - -> IO () - -service_loop wakeup old_delays = do - -- pick up new delay requests - new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) - let delays = foldr insertDelay old_delays new_delays - - now <- getUSecOfDay - (delays', timeout) <- getDelay now delays - - r <- c_WaitForSingleObject wakeup timeout - case r of - 0xffffffff -> do c_maperrno; throwErrno "service_loop" - 0 -> do - r2 <- c_readIOManagerEvent - exit <- - case r2 of - _ | r2 == io_MANAGER_WAKEUP -> return False - _ | r2 == io_MANAGER_DIE -> return True - 0 -> return False -- spurious wakeup - _ -> do start_console_handler (r2 `shiftR` 1); return False - unless exit $ service_cont wakeup delays' - - _other -> service_cont wakeup delays' -- probably timeout - -service_cont :: HANDLE -> [DelayReq] -> IO () -service_cont wakeup delays = do - r <- atomicModifyIORef prodding (\_ -> (False,False)) - r `seq` return () -- avoid space leak - service_loop wakeup delays - --- must agree with rts/win32/ThrIOManager.c -io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 -io_MANAGER_WAKEUP = 0xffffffff -io_MANAGER_DIE = 0xfffffffe - -data ConsoleEvent - = ControlC - | Break - | Close - -- these are sent to Services only. - | Logoff - | Shutdown - deriving (Eq, Ord, Enum, Show, Read, Typeable) - -start_console_handler :: Word32 -> IO () -start_console_handler r = - case toWin32ConsoleEvent r of - Just x -> withMVar win32ConsoleHandler $ \handler -> do - _ <- forkIO (handler x) - return () - Nothing -> return () - -toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent -toWin32ConsoleEvent ev = - case ev of - 0 {- CTRL_C_EVENT-} -> Just ControlC - 1 {- CTRL_BREAK_EVENT-} -> Just Break - 2 {- CTRL_CLOSE_EVENT-} -> Just Close - 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff - 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown - _ -> Nothing - -win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) -win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler")) - -wakeupIOManager :: IO () -wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP - --- Walk the queue of pending delays, waking up any that have passed --- and return the smallest delay to wait for. The queue of pending --- delays is kept ordered. -getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD) -getDelay _ [] = return ([], iNFINITE) -getDelay now all@(d : rest) - = case d of - Delay time m | now >= time -> do - putMVar m () - getDelay now rest - DelaySTM time t | now >= time -> do - atomically $ writeTVar t True - getDelay now rest - _otherwise -> - -- delay is in millisecs for WaitForSingleObject - let micro_seconds = delayTime d - now - milli_seconds = (micro_seconds + 999) `div` 1000 - in return (all, fromIntegral milli_seconds) - --- ToDo: this just duplicates part of System.Win32.Types, which isn't --- available yet. We should move some Win32 functionality down here, --- maybe as part of the grand reorganisation of the base package... -type HANDLE = Ptr () -type DWORD = Word32 - -iNFINITE :: DWORD -iNFINITE = 0xFFFFFFFF -- urgh - -foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_getIOManagerEvent :: IO HANDLE - -foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_readIOManagerEvent :: IO Word32 - -foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) - c_sendIOManagerEvent :: Word32 -> IO () - -foreign import ccall unsafe "maperrno" -- in Win32Utils.c - c_maperrno :: IO () - -foreign import stdcall "WaitForSingleObject" - c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD - -#else --- ---------------------------------------------------------------------------- --- Unix IO manager thread, using select() - -ioManager :: IO () -ioManager = do - allocaArray 2 $ \fds -> do - throwErrnoIfMinus1_ "startIOManagerThread" (c_pipe fds) - rd_end <- peekElemOff fds 0 - wr_end <- peekElemOff fds 1 - setNonBlockingFD wr_end True -- writes happen in a signal handler, we - -- don't want them to block. - setCloseOnExec rd_end - setCloseOnExec wr_end - c_setIOManagerPipe wr_end - allocaBytes sizeofFdSet $ \readfds -> do - allocaBytes sizeofFdSet $ \writefds -> do - allocaBytes sizeofTimeVal $ \timeval -> do - service_loop (fromIntegral rd_end) readfds writefds timeval [] [] - return () - -service_loop - :: Fd -- listen to this for wakeup calls - -> Ptr CFdSet - -> Ptr CFdSet - -> Ptr CTimeVal - -> [IOReq] - -> [DelayReq] - -> IO () -service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do - - -- reset prodding before we look at the new requests. If a new - -- client arrives after this point they will send a wakup which will - -- cause the server to loop around again, so we can be sure to not - -- miss any requests. - -- - -- NB. it's important to do this in the *first* iteration of - -- service_loop, rather than after calling select(), since a client - -- may have set prodding to True without sending a wakeup byte down - -- the pipe, because the pipe wasn't set up. - atomicModifyIORef prodding (\_ -> (False, ())) - - -- pick up new IO requests - new_reqs <- atomicModifyIORef pendingEvents (\a -> ([],a)) - let reqs = new_reqs ++ old_reqs - - -- pick up new delay requests - new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) - let delays0 = foldr insertDelay old_delays new_delays - - -- build the FDSets for select() - fdZero readfds - fdZero writefds - fdSet wakeup readfds - maxfd <- buildFdSets 0 readfds writefds reqs - - -- perform the select() - let do_select delays = do - -- check the current time and wake up any thread in - -- threadDelay whose timeout has expired. Also find the - -- timeout value for the select() call. - now <- getUSecOfDay - (delays', timeout) <- getDelay now ptimeval delays - - res <- c_select (fromIntegral ((max wakeup maxfd)+1)) readfds writefds - nullPtr timeout - if (res == -1) - then do - err <- getErrno - case err of - _ | err == eINTR -> do_select delays' - -- EINTR: just redo the select() - _ | err == eBADF -> return (True, delays) - -- EBADF: one of the file descriptors is closed or bad, - -- we don't know which one, so wake everyone up. - _ | otherwise -> throwErrno "select" - -- otherwise (ENOMEM or EINVAL) something has gone - -- wrong; report the error. - else - return (False,delays') - - (wakeup_all,delays') <- do_select delays0 - - exit <- - if wakeup_all then return False - else do - b <- fdIsSet wakeup readfds - if b == 0 - then return False - else alloca $ \p -> do - warnErrnoIfMinus1_ "service_loop" $ - c_read (fromIntegral wakeup) p 1 - s <- peek p - case s of - _ | s == io_MANAGER_WAKEUP -> return False - _ | s == io_MANAGER_DIE -> return True - _ | s == io_MANAGER_SYNC -> do - mvars <- readIORef sync - mapM_ (flip putMVar ()) mvars - return False - _ -> do - fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) - withForeignPtr fp $ \p_siginfo -> do - r <- c_read (fromIntegral wakeup) (castPtr p_siginfo) - sizeof_siginfo_t - when (r /= fromIntegral sizeof_siginfo_t) $ - error "failed to read siginfo_t" - runHandlers' fp (fromIntegral s) - return False - - unless exit $ do - - reqs' <- if wakeup_all then do wakeupAll reqs; return [] - else completeRequests reqs readfds writefds [] - - service_loop wakeup readfds writefds ptimeval reqs' delays' - -io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: Word8 -io_MANAGER_WAKEUP = 0xff -io_MANAGER_DIE = 0xfe -io_MANAGER_SYNC = 0xfd - -{-# NOINLINE sync #-} -sync :: IORef [MVar ()] -sync = unsafePerformIO (newIORef []) - --- waits for the IO manager to drain the pipe -syncIOManager :: IO () -syncIOManager = do - m <- newEmptyMVar - atomicModifyIORef sync (\old -> (m:old,())) - c_ioManagerSync - takeMVar m - -foreign import ccall unsafe "ioManagerSync" c_ioManagerSync :: IO () -foreign import ccall unsafe "ioManagerWakeup" wakeupIOManager :: IO () - --- For the non-threaded RTS -runHandlers :: Ptr Word8 -> Int -> IO () -runHandlers p_info sig = do - fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) - withForeignPtr fp $ \p -> do - copyBytes p p_info (fromIntegral sizeof_siginfo_t) - free p_info - runHandlers' fp (fromIntegral sig) - -runHandlers' :: ForeignPtr Word8 -> Signal -> IO () -runHandlers' p_info sig = do - let int = fromIntegral sig - withMVar signal_handlers $ \arr -> - if not (inRange (boundsIOArray arr) int) - then return () - else do handler <- unsafeReadIOArray arr int - case handler of - Nothing -> return () - Just (f,_) -> do _ <- forkIO (f p_info) - return () - -warnErrnoIfMinus1_ :: Num a => String -> IO a -> IO () -warnErrnoIfMinus1_ what io - = do r <- io - when (r == -1) $ do - errno <- getErrno - str <- strerror errno >>= peekCString - when (r == -1) $ - debugErrLn ("Warning: " ++ what ++ " failed: " ++ str) - -foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar) - -foreign import ccall "setIOManagerPipe" - c_setIOManagerPipe :: CInt -> IO () - -foreign import ccall "__hscore_sizeof_siginfo_t" - sizeof_siginfo_t :: CSize - -type Signal = CInt - -maxSig = 64 :: Int - -type HandlerFun = ForeignPtr Word8 -> IO () - --- Lock used to protect concurrent access to signal_handlers. Symptom of --- this race condition is #1922, although that bug was on Windows a similar --- bug also exists on Unix. -{-# NOINLINE signal_handlers #-} -signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic))) -signal_handlers = unsafePerformIO $ do - arr <- newIOArray (0,maxSig) Nothing - m <- newMVar arr - sharedCAF m getOrSetGHCConcSignalHandlerStore - -foreign import ccall unsafe "getOrSetGHCConcSignalHandlerStore" - getOrSetGHCConcSignalHandlerStore :: Ptr a -> IO (Ptr a) - -setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic)) -setHandler sig handler = do - let int = fromIntegral sig - withMVar signal_handlers $ \arr -> - if not (inRange (boundsIOArray arr) int) - then error "GHC.Conc.setHandler: signal out of range" - else do old <- unsafeReadIOArray arr int - unsafeWriteIOArray arr int handler - return old - --- ----------------------------------------------------------------------------- --- IO requests - -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 _ : 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 - if b /= 0 - then do putMVar m (); completeRequests reqs readfds writefds reqs' - else completeRequests reqs readfds writefds (Read fd m : reqs') -completeRequests (Write fd m : reqs) readfds writefds reqs' = do - b <- fdIsSet fd writefds - if b /= 0 - 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 _ m : reqs) = do putMVar m (); wakeupAll reqs -wakeupAll (Write _ m : reqs) = do putMVar m (); wakeupAll reqs - -waitForReadEvent :: Fd -> IO () -waitForReadEvent fd = do - m <- newEmptyMVar - atomicModifyIORef pendingEvents (\xs -> (Read fd m : xs, ())) - prodServiceThread - takeMVar m - -waitForWriteEvent :: Fd -> IO () -waitForWriteEvent fd = do - m <- newEmptyMVar - atomicModifyIORef pendingEvents (\xs -> (Write fd m : xs, ())) - prodServiceThread - takeMVar m - --- ----------------------------------------------------------------------------- --- Delays - --- Walk the queue of pending delays, waking up any that have passed --- 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 _ _ [] = return ([],nullPtr) -getDelay now ptimeval all@(d : rest) - = case d of - Delay time m | now >= time -> do - putMVar m () - getDelay now ptimeval rest - DelaySTM time t | now >= time -> do - atomically $ writeTVar t True - getDelay now ptimeval rest - _otherwise -> do - setTimevalTicks ptimeval (delayTime d - now) - return (all,ptimeval) - -data CTimeVal - -foreign import ccall unsafe "sizeofTimeVal" - sizeofTimeVal :: Int - -foreign import ccall unsafe "setTimevalTicks" - setTimevalTicks :: Ptr CTimeVal -> USecs -> IO () - -{- - On Win32 we're going to have a single Pipe, and a - waitForSingleObject with the delay time. For signals, we send a - byte down the pipe just like on Unix. --} - --- ---------------------------------------------------------------------------- --- select() interface - --- ToDo: move to System.Posix.Internals? - -data CFdSet - -foreign import ccall safe "__hscore_select" - c_select :: CInt -> Ptr CFdSet -> Ptr CFdSet -> Ptr CFdSet -> Ptr CTimeVal - -> IO CInt - -foreign import ccall unsafe "hsFD_SETSIZE" - c_fD_SETSIZE :: CInt - -fD_SETSIZE :: Fd -fD_SETSIZE = fromIntegral c_fD_SETSIZE - -foreign import ccall unsafe "hsFD_ISSET" - c_fdIsSet :: CInt -> Ptr CFdSet -> IO CInt - -fdIsSet :: Fd -> Ptr CFdSet -> IO CInt -fdIsSet (Fd fd) fdset = c_fdIsSet fd fdset - -foreign import ccall unsafe "hsFD_SET" - c_fdSet :: CInt -> Ptr CFdSet -> IO () - -fdSet :: Fd -> Ptr CFdSet -> IO () -fdSet (Fd fd) fdset = c_fdSet fd fdset - -foreign import ccall unsafe "hsFD_ZERO" - fdZero :: Ptr CFdSet -> IO () - -foreign import ccall unsafe "sizeof_fd_set" - sizeofFdSet :: Int - -#endif - addfile ./GHC/Conc/Windows.hs hunk ./GHC/Conc/Windows.hs 1 +{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_HADDOCK not-home #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Conc.Windows +-- Copyright : (c) The University of Glasgow, 1994-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Windows I/O manager +-- +----------------------------------------------------------------------------- + +-- #not-home +module GHC.Conc.Windows + ( ensureIOManagerIsRunning + + -- * Waiting + , threadDelay + , registerDelay + + -- * Miscellaneous + , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) + , asyncDoProc -- :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int + + , asyncReadBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + , asyncWriteBA -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int) + + , ConsoleEvent(..) + , win32ConsoleHandler + , toWin32ConsoleEvent + ) where + +import Control.Monad +import Data.Bits (shiftR) +import Data.Maybe (Maybe(..)) +import Data.Typeable +import Foreign.C.Error (throwErrno) +import GHC.Base +import GHC.Conc.Sync +import GHC.Enum (Enum) +import GHC.IO (unsafePerformIO) +import GHC.IORef +import GHC.MVar +import GHC.Num (Num(..)) +import GHC.Ptr +import GHC.Read (Read) +import GHC.Real (div, fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word32, Word64) + +-- ---------------------------------------------------------------------------- +-- Thread waiting + +-- Note: threadWaitRead and threadWaitWrite aren't really functional +-- on Win32, but left in there because lib code (still) uses them (the manner +-- in which they're used doesn't cause problems on a Win32 platform though.) + +asyncRead :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncRead (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncRead# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncWrite :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) +asyncWrite (I# fd) (I# isSock) (I# len) (Ptr buf) = + IO $ \s -> case asyncWrite# fd isSock len buf s of + (# s', len#, err# #) -> (# s', (I# len#, I# err#) #) + +asyncDoProc :: FunPtr (Ptr a -> IO Int) -> Ptr a -> IO Int +asyncDoProc (FunPtr proc) (Ptr param) = + -- the 'length' value is ignored; simplifies implementation of + -- the async*# primops to have them all return the same result. + IO $ \s -> case asyncDoProc# proc param s of + (# s', _len#, err# #) -> (# s', I# err# #) + +-- to aid the use of these primops by the IO Handle implementation, +-- provide the following convenience funs: + +-- this better be a pinned byte array! +asyncReadBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncReadBA fd isSock len off bufB = + asyncRead fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) + +asyncWriteBA :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int,Int) +asyncWriteBA fd isSock len off bufB = + asyncWrite fd isSock len ((Ptr (byteArrayContents# (unsafeCoerce# bufB))) `plusPtr` off) + +-- ---------------------------------------------------------------------------- +-- Threaded RTS implementation of threadDelay + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +-- +threadDelay :: Int -> IO () +threadDelay time + | threaded = waitForDelayEvent time + | otherwise = IO $ \s -> + case fromIntegral time of { I# time# -> + case delay# time# s of { s' -> (# s', () #) + }} + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs + | threaded = waitForDelayEventSTM usecs + | otherwise = error "registerDelay: requires -threaded" + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool + +waitForDelayEvent :: Int -> IO () +waitForDelayEvent usecs = do + m <- newEmptyMVar + target <- calculateTarget usecs + atomicModifyIORef pendingDelays (\xs -> (Delay target m : xs, ())) + prodServiceThread + takeMVar m + +-- Delays for use in STM +waitForDelayEventSTM :: Int -> IO (TVar Bool) +waitForDelayEventSTM usecs = do + t <- atomically $ newTVar False + target <- calculateTarget usecs + atomicModifyIORef pendingDelays (\xs -> (DelaySTM target t : xs, ())) + prodServiceThread + return t + +calculateTarget :: Int -> IO USecs +calculateTarget usecs = do + now <- getUSecOfDay + return $ now + (fromIntegral usecs) + +data DelayReq + = Delay {-# UNPACK #-} !USecs {-# UNPACK #-} !(MVar ()) + | DelaySTM {-# UNPACK #-} !USecs {-# UNPACK #-} !(TVar Bool) + +{-# NOINLINE pendingDelays #-} +pendingDelays :: IORef [DelayReq] +pendingDelays = unsafePerformIO $ do + m <- newIORef [] + sharedCAF m getOrSetGHCConcWindowsPendingDelaysStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsPendingDelaysStore" + getOrSetGHCConcWindowsPendingDelaysStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManagerThread #-} +ioManagerThread :: MVar (Maybe ThreadId) +ioManagerThread = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetGHCConcWindowsIOManagerThreadStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsIOManagerThreadStore" + getOrSetGHCConcWindowsIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | threaded = startIOManagerThread + | otherwise = return () + +startIOManagerThread :: IO () +startIOManagerThread = do + modifyMVar_ ioManagerThread $ \old -> do + let create = do t <- forkIO ioManager; return (Just t) + case old of + Nothing -> create + Just t -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> return (Just t) + +insertDelay :: DelayReq -> [DelayReq] -> [DelayReq] +insertDelay d [] = [d] +insertDelay d1 ds@(d2 : rest) + | delayTime d1 <= delayTime d2 = d1 : ds + | otherwise = d2 : insertDelay d1 rest + +delayTime :: DelayReq -> USecs +delayTime (Delay t _) = t +delayTime (DelaySTM t _) = t + +type USecs = Word64 + +foreign import ccall unsafe "getUSecOfDay" + getUSecOfDay :: IO USecs + +{-# NOINLINE prodding #-} +prodding :: IORef Bool +prodding = unsafePerformIO $ do + r <- newIORef False + sharedCAF r getOrSetGHCConcWindowsProddingStore + +foreign import ccall unsafe "getOrSetGHCConcWindowsProddingStore" + getOrSetGHCConcWindowsProddingStore :: Ptr a -> IO (Ptr a) + +prodServiceThread :: IO () +prodServiceThread = do + -- NB. use atomicModifyIORef here, otherwise there are race + -- conditions in which prodding is left at True but the server is + -- blocked in select(). + was_set <- atomicModifyIORef prodding $ \b -> (True,b) + unless was_set wakeupIOManager + +-- ---------------------------------------------------------------------------- +-- Windows IO manager thread + +ioManager :: IO () +ioManager = do + wakeup <- c_getIOManagerEvent + service_loop wakeup [] + +service_loop :: HANDLE -- read end of pipe + -> [DelayReq] -- current delay requests + -> IO () + +service_loop wakeup old_delays = do + -- pick up new delay requests + new_delays <- atomicModifyIORef pendingDelays (\a -> ([],a)) + let delays = foldr insertDelay old_delays new_delays + + now <- getUSecOfDay + (delays', timeout) <- getDelay now delays + + r <- c_WaitForSingleObject wakeup timeout + case r of + 0xffffffff -> do c_maperrno; throwErrno "service_loop" + 0 -> do + r2 <- c_readIOManagerEvent + exit <- + case r2 of + _ | r2 == io_MANAGER_WAKEUP -> return False + _ | r2 == io_MANAGER_DIE -> return True + 0 -> return False -- spurious wakeup + _ -> do start_console_handler (r2 `shiftR` 1); return False + unless exit $ service_cont wakeup delays' + + _other -> service_cont wakeup delays' -- probably timeout + +service_cont :: HANDLE -> [DelayReq] -> IO () +service_cont wakeup delays = do + r <- atomicModifyIORef prodding (\_ -> (False,False)) + r `seq` return () -- avoid space leak + service_loop wakeup delays + +-- must agree with rts/win32/ThrIOManager.c +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word32 +io_MANAGER_WAKEUP = 0xffffffff +io_MANAGER_DIE = 0xfffffffe + +data ConsoleEvent + = ControlC + | Break + | Close + -- these are sent to Services only. + | Logoff + | Shutdown + deriving (Eq, Ord, Enum, Show, Read, Typeable) + +start_console_handler :: Word32 -> IO () +start_console_handler r = + case toWin32ConsoleEvent r of + Just x -> withMVar win32ConsoleHandler $ \handler -> do + _ <- forkIO (handler x) + return () + Nothing -> return () + +toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent +toWin32ConsoleEvent ev = + case ev of + 0 {- CTRL_C_EVENT-} -> Just ControlC + 1 {- CTRL_BREAK_EVENT-} -> Just Break + 2 {- CTRL_CLOSE_EVENT-} -> Just Close + 5 {- CTRL_LOGOFF_EVENT-} -> Just Logoff + 6 {- CTRL_SHUTDOWN_EVENT-} -> Just Shutdown + _ -> Nothing + +win32ConsoleHandler :: MVar (ConsoleEvent -> IO ()) +win32ConsoleHandler = unsafePerformIO (newMVar (error "win32ConsoleHandler")) + +wakeupIOManager :: IO () +wakeupIOManager = c_sendIOManagerEvent io_MANAGER_WAKEUP + +-- Walk the queue of pending delays, waking up any that have passed +-- and return the smallest delay to wait for. The queue of pending +-- delays is kept ordered. +getDelay :: USecs -> [DelayReq] -> IO ([DelayReq], DWORD) +getDelay _ [] = return ([], iNFINITE) +getDelay now all@(d : rest) + = case d of + Delay time m | now >= time -> do + putMVar m () + getDelay now rest + DelaySTM time t | now >= time -> do + atomically $ writeTVar t True + getDelay now rest + _otherwise -> + -- delay is in millisecs for WaitForSingleObject + let micro_seconds = delayTime d - now + milli_seconds = (micro_seconds + 999) `div` 1000 + in return (all, fromIntegral milli_seconds) + +-- ToDo: this just duplicates part of System.Win32.Types, which isn't +-- available yet. We should move some Win32 functionality down here, +-- maybe as part of the grand reorganisation of the base package... +type HANDLE = Ptr () +type DWORD = Word32 + +iNFINITE :: DWORD +iNFINITE = 0xFFFFFFFF -- urgh + +foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_getIOManagerEvent :: IO HANDLE + +foreign import ccall unsafe "readIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_readIOManagerEvent :: IO Word32 + +foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) + c_sendIOManagerEvent :: Word32 -> IO () + +foreign import ccall unsafe "maperrno" -- in Win32Utils.c + c_maperrno :: IO () + +foreign import stdcall "WaitForSingleObject" + c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD hunk ./GHC/IO/FD.hs 40 -import GHC.Conc +import GHC.Conc.IO hunk ./GHC/IO/Handle/Internals.hs 62 -import GHC.Conc +import GHC.Conc.Sync addfile ./System/Event.hs hunk ./System/Event.hs 1 +module System.Event + ( -- * Types + EventManager + + -- * Creation + , new + + -- * Running + , loop + + -- ** Stepwise running + , step + , shutdown + + -- * Registering interest in I/O events + , Event + , evtRead + , evtWrite + , IOCallback + , FdKey(keyFd) + , registerFd + , registerFd_ + , unregisterFd + , unregisterFd_ + , fdWasClosed + + -- * Registering interest in timeout events + , TimeoutCallback + , TimeoutKey + , registerTimeout + , updateTimeout + , unregisterTimeout + ) where + +import System.Event.Manager addfile ./System/Event/Array.hs hunk ./System/Event/Array.hs 1 +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, NoImplicitPrelude #-} + +module System.Event.Array + ( + Array + , capacity + , clear + , concat + , copy + , duplicate + , empty + , ensureCapacity + , findIndex + , forM_ + , length + , loop + , new + , removeAt + , snoc + , unsafeLoad + , unsafeRead + , unsafeWrite + , useAsPtr + ) where + +import Control.Monad hiding (forM_) +import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef) +import Data.Maybe +import Foreign.C.Types (CSize) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Err (undefined) +import GHC.Float (logBase) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_) +import GHC.Num (Num(..)) +import GHC.Real ((^), ceiling, fromIntegral, realToFrac) +import GHC.Show (show) + +#define BOUNDS_CHECKING 1 + +#if defined(BOUNDS_CHECKING) +-- This fugly hack is brought by GHC's apparent reluctance to deal +-- with MagicHash and UnboxedTuples when inferring types. Eek! +#define CHECK_BOUNDS(_func_,_len_,_k_) \ +if (_k_) < 0 || (_k_) >= (_len_) then error ("System.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else +#else +#define CHECK_BOUNDS(_func_,_len_,_k_) +#endif + +-- Invariant: size <= capacity +newtype Array a = Array (IORef (AC a)) + +-- The actual array content. +data AC a = AC + !(ForeignPtr a) -- Elements + !Int -- Number of elements (length) + !Int -- Maximum number of elements (capacity) + +empty :: IO (Array a) +empty = do + p <- newForeignPtr_ nullPtr + Array `fmap` newIORef (AC p 0 0) + +allocArray :: Storable a => Int -> IO (ForeignPtr a) +allocArray n = allocHack undefined + where + allocHack :: Storable a => a -> IO (ForeignPtr a) + allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy) + +reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a) +reallocArray p newSize oldSize = reallocHack undefined p + where + reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a) + reallocHack dummy src = do + let size = sizeOf dummy + dst <- mallocPlainForeignPtrBytes (newSize * size) + withForeignPtr src $ \s -> + when (s /= nullPtr && oldSize > 0) . + withForeignPtr dst $ \d -> do + _ <- memcpy d s (fromIntegral (oldSize * size)) + return () + return dst + +new :: Storable a => Int -> IO (Array a) +new c = do + es <- allocArray cap + fmap Array (newIORef (AC es 0 cap)) + where + cap = firstPowerOf2 c + +duplicate :: Storable a => Array a -> IO (Array a) +duplicate a = dupHack undefined a + where + dupHack :: Storable b => b -> Array b -> IO (Array b) + dupHack dummy (Array ref) = do + AC es len cap <- readIORef ref + ary <- allocArray cap + withForeignPtr ary $ \dest -> + withForeignPtr es $ \src -> do + _ <- memcpy dest src (fromIntegral (len * sizeOf dummy)) + return () + Array `fmap` newIORef (AC ary len cap) + +length :: Array a -> IO Int +length (Array ref) = do + AC _ len _ <- readIORef ref + return len + +capacity :: Array a -> IO Int +capacity (Array ref) = do + AC _ _ cap <- readIORef ref + return cap + +unsafeRead :: Storable a => Array a -> Int -> IO a +unsafeRead (Array ref) ix = do + AC es _ cap <- readIORef ref + CHECK_BOUNDS("unsafeRead",cap,ix) + withForeignPtr es $ \p -> + peekElemOff p ix + +unsafeWrite :: Storable a => Array a -> Int -> a -> IO () +unsafeWrite (Array ref) ix a = do + ac <- readIORef ref + unsafeWrite' ac ix a + +unsafeWrite' :: Storable a => AC a -> Int -> a -> IO () +unsafeWrite' (AC es _ cap) ix a = do + CHECK_BOUNDS("unsafeWrite'",cap,ix) + withForeignPtr es $ \p -> + pokeElemOff p ix a + +unsafeLoad :: Storable a => Array a -> (Ptr a -> Int -> IO Int) -> IO Int +unsafeLoad (Array ref) load = do + AC es _ cap <- readIORef ref + len' <- withForeignPtr es $ \p -> load p cap + writeIORef ref (AC es len' cap) + return len' + +ensureCapacity :: Storable a => Array a -> Int -> IO () +ensureCapacity (Array ref) c = do + ac@(AC _ _ cap) <- readIORef ref + ac'@(AC _ _ cap') <- ensureCapacity' ac c + when (cap' /= cap) $ + writeIORef ref ac' + +ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a) +ensureCapacity' ac@(AC es len cap) c = do + if c > cap + then do + es' <- reallocArray es cap' cap + return (AC es' len cap') + else + return ac + where + cap' = firstPowerOf2 c + +useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b +useAsPtr (Array ref) f = do + AC es len _ <- readIORef ref + withForeignPtr es $ \p -> f p len + +snoc :: Storable a => Array a -> a -> IO () +snoc (Array ref) e = do + ac@(AC _ len _) <- readIORef ref + let len' = len + 1 + ac'@(AC es _ cap) <- ensureCapacity' ac len' + unsafeWrite' ac' len e + writeIORef ref (AC es len' cap) + +clear :: Storable a => Array a -> IO () +clear (Array ref) = do + !_ <- atomicModifyIORef ref $ \(AC es _ cap) -> + let e = AC es 0 cap in (e, e) + return () + +forM_ :: Storable a => Array a -> (a -> IO ()) -> IO () +forM_ ary g = forHack ary g undefined + where + forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO () + forHack (Array ref) f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n | n >= offset = return () + | otherwise = do + f =<< peek (p `plusPtr` n) + go (n + size) + go 0 + +loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO () +loop ary z g = loopHack ary z g undefined + where + loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b + -> IO () + loopHack (Array ref) y f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n k + | n >= offset = return () + | otherwise = do + (k',cont) <- f k =<< peek (p `plusPtr` n) + when cont $ go (n + size) k' + go 0 y + +findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a)) +findIndex = findHack undefined + where + findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b)) + findHack dummy p (Array ref) = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \ptr -> + let go !n !i + | n >= offset = return Nothing + | otherwise = do + val <- peek (ptr `plusPtr` n) + if p val + then return $ Just (i, val) + else go (n + size) (i + 1) + in go 0 0 + +concat :: Storable a => Array a -> Array a -> IO () +concat (Array d) (Array s) = do + da@(AC _ dlen _) <- readIORef d + sa@(AC _ slen _) <- readIORef s + writeIORef d =<< copy' da dlen sa 0 slen + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO () +copy (Array d) dstart (Array s) sstart maxCount = do + da <- readIORef d + sa <- readIORef s + writeIORef d =<< copy' da dstart sa sstart maxCount + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a) +copy' d dstart s sstart maxCount = copyHack d s undefined + where + copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) + copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do + when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || + sstart > slen) $ error "copy: bad offsets or lengths" + let size = sizeOf dummy + count = min maxCount (slen - sstart) + if count == 0 + then return dac + else do + AC dst dlen dcap <- ensureCapacity' dac (dstart + count) + withForeignPtr dst $ \dptr -> + withForeignPtr src $ \sptr -> do + _ <- memcpy (dptr `plusPtr` (dstart * size)) + (sptr `plusPtr` (sstart * size)) + (fromIntegral (count * size)) + return $ AC dst (max dlen (dstart + count)) dcap + +removeAt :: Storable a => Array a -> Int -> IO () +removeAt a i = removeHack a undefined + where + removeHack :: Storable b => Array b -> b -> IO () + removeHack (Array ary) dummy = do + AC fp oldLen cap <- readIORef ary + when (i < 0 || i >= oldLen) $ error "removeAt: invalid index" + let size = sizeOf dummy + newLen = oldLen - 1 + when (newLen > 0 && i < newLen) . + withForeignPtr fp $ \ptr -> do + _ <- memmove (ptr `plusPtr` (size * i)) + (ptr `plusPtr` (size * (i+1))) + (fromIntegral (size * (newLen-i))) + return () + writeIORef ary (AC fp newLen cap) + +firstPowerOf2 :: Int -> Int +firstPowerOf2 n + | n <= 0 = 0 + | otherwise = 2^p + where p = (ceiling . logBase (2 :: Double) . realToFrac) n :: Int + +foreign import ccall unsafe "string.h memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) + +foreign import ccall unsafe "string.h memmove" + memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) addfile ./System/Event/Clock.hsc hunk ./System/Event/Clock.hsc 1 +{-# LANGUAGE ForeignFunctionInterface #-} + +module System.Event.Clock (getCurrentTime) where + +#include + +import Foreign (Ptr, Storable(..), nullPtr, with) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt, CLong) +import GHC.Base +import GHC.Err +import GHC.Num +import GHC.Real + +-- TODO: Implement this for Windows. + +-- | Return the current time, in seconds since Jan. 1, 1970. +getCurrentTime :: IO Double +getCurrentTime = do + tv <- with (CTimeval 0 0) $ \tvptr -> do + throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr) + peek tvptr + let !t = fromIntegral (sec tv) + fromIntegral (usec tv) / 1000000.0 + return t + +------------------------------------------------------------------------ +-- FFI binding + +data CTimeval = CTimeval + { sec :: {-# UNPACK #-} !CLong + , usec :: {-# UNPACK #-} !CLong + } + +instance Storable CTimeval where + sizeOf _ = #size struct timeval + alignment _ = alignment (undefined :: CLong) + + peek ptr = do + sec' <- #{peek struct timeval, tv_sec} ptr + usec' <- #{peek struct timeval, tv_usec} ptr + return $ CTimeval sec' usec' + + poke ptr tv = do + #{poke struct timeval, tv_sec} ptr (sec tv) + #{poke struct timeval, tv_usec} ptr (usec tv) + +foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday + :: Ptr CTimeval -> Ptr () -> IO CInt addfile ./System/Event/Control.hs hunk ./System/Event/Control.hs 1 +{-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude, + ScopedTypeVariables #-} + +module System.Event.Control + ( + -- * Managing the IO manager + Signal + , ControlMessage(..) + , Control + , newControl + , closeControl + -- ** Control message reception + , readControlMessage + -- *** File descriptors + , controlReadFd + , wakeupReadFd + -- ** Control message sending + , sendWakeup + , sendDie + -- * Utilities + , setNonBlockingFD + ) where + +#include "EventConfig.h" + +import Control.Monad (when) +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Base +import GHC.Conc.Signal (Signal) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word8) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt, CSize) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.Posix.Internals (c_close, c_pipe, c_read, c_write, + setCloseOnExec, setNonBlockingFD) +import System.Posix.Types (Fd) + +#if defined(HAVE_EVENTFD) +import Data.Word (Word64) +import Foreign.C.Error (throwErrnoIfMinus1) +#else +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) +#endif + +data ControlMessage = CMsgWakeup + | CMsgDie + | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Signal + deriving (Eq, Show) + +-- | The structure used to tell the IO manager thread what to do. +data Control = W { + controlReadFd :: {-# UNPACK #-} !Fd + , controlWriteFd :: {-# UNPACK #-} !Fd +#if defined(HAVE_EVENTFD) + , controlEventFd :: {-# UNPACK #-} !Fd +#else + , wakeupReadFd :: {-# UNPACK #-} !Fd + , wakeupWriteFd :: {-# UNPACK #-} !Fd +#endif + } deriving (Show) + +#if defined(HAVE_EVENTFD) +wakeupReadFd :: Control -> Fd +wakeupReadFd = controlEventFd +{-# INLINE wakeupReadFd #-} +#endif + +setNonBlock :: CInt -> IO () +setNonBlock fd = +#if __GLASGOW_HASKELL__ >= 611 + setNonBlockingFD fd True +#else + setNonBlockingFD fd +#endif + +-- | Create the structure (usually a pipe) used for waking up the IO +-- manager thread from another thread. +newControl :: IO Control +newControl = allocaArray 2 $ \fds -> do + let createPipe = do + throwErrnoIfMinus1_ "pipe" $ c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + -- The write end must be non-blocking, since we may need to + -- poke the event manager from a signal handler. + setNonBlock wr + setCloseOnExec rd + setCloseOnExec wr + return (rd, wr) + (ctrl_rd, ctrl_wr) <- createPipe + c_setIOManagerControlFd ctrl_wr +#if defined(HAVE_EVENTFD) + ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 + setNonBlock ev + setCloseOnExec ev + c_setIOManagerWakeupFd ev +#else + (wake_rd, wake_wr) <- createPipe + c_setIOManagerWakeupFd wake_wr +#endif + return W { controlReadFd = fromIntegral ctrl_rd + , controlWriteFd = fromIntegral ctrl_wr +#if defined(HAVE_EVENTFD) + , controlEventFd = fromIntegral ev +#else + , wakeupReadFd = fromIntegral wake_rd + , wakeupWriteFd = fromIntegral wake_wr +#endif + } + +-- | Close the control structure used by the IO manager thread. +closeControl :: Control -> IO () +closeControl w = do + _ <- c_close . fromIntegral . controlReadFd $ w + _ <- c_close . fromIntegral . controlWriteFd $ w +#if defined(HAVE_EVENTFD) + _ <- c_close . fromIntegral . controlEventFd $ w +#else + _ <- c_close . fromIntegral . wakeupReadFd $ w + _ <- c_close . fromIntegral . wakeupWriteFd $ w +#endif + return () + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 +io_MANAGER_WAKEUP = 0xff +io_MANAGER_DIE = 0xfe + +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +readControlMessage :: Control -> Fd -> IO ControlMessage +readControlMessage ctrl fd + | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do + throwErrnoIfMinus1_ "readWakeupMessage" $ + c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) + return CMsgWakeup + | otherwise = + alloca $ \p -> do + throwErrnoIfMinus1_ "readControlMessage" $ + c_read (fromIntegral fd) p 1 + s <- peek p + case s of + -- Wakeup messages shouldn't be sent on the control + -- file descriptor but we handle them anyway. + _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup + _ | s == io_MANAGER_DIE -> return CMsgDie + _ -> do -- Signal + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral fd) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + error "failed to read siginfo_t" + let !s' = fromIntegral s + return $ CMsgSignal fp s' + + where wakeupBufferSize = +#if defined(HAVE_EVENTFD) + 8 +#else + 4096 +#endif + +sendWakeup :: Control -> IO () +#if defined(HAVE_EVENTFD) +sendWakeup c = alloca $ \p -> do + poke p (1 :: Word64) + throwErrnoIfMinus1_ "sendWakeup" $ + c_write (fromIntegral (controlEventFd c)) (castPtr p) 8 +#else +sendWakeup c = do + n <- sendMessage (wakeupWriteFd c) CMsgWakeup + case n of + _ | n /= -1 -> return () + | otherwise -> do + errno <- getErrno + when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ + throwErrno "sendWakeup" +#endif + +sendDie :: Control -> IO () +sendDie c = throwErrnoIfMinus1_ "sendDie" $ + sendMessage (controlWriteFd c) CMsgDie + +sendMessage :: Fd -> ControlMessage -> IO Int +sendMessage fd msg = alloca $ \p -> do + case msg of + CMsgWakeup -> poke p io_MANAGER_WAKEUP + CMsgDie -> poke p io_MANAGER_DIE + CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + fromIntegral `fmap` c_write (fromIntegral fd) p 1 + +#if defined(HAVE_EVENTFD) +foreign import ccall unsafe "sys/eventfd.h eventfd" + c_eventfd :: CInt -> CInt -> IO CInt +#endif + +-- Used to tell the RTS how it can send messages to the I/O manager. +foreign import ccall "setIOManagerControlFd" + c_setIOManagerControlFd :: CInt -> IO () + +foreign import ccall "setIOManagerWakeupFd" + c_setIOManagerWakeupFd :: CInt -> IO () addfile ./System/Event/EPoll.hsc hunk ./System/Event/EPoll.hsc 1 +{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, + NoImplicitPrelude #-} + +-- +-- | A binding to the epoll I/O event notification facility +-- +-- epoll is a variant of poll that can be used either as an edge-triggered or +-- a level-triggered interface and scales well to large numbers of watched file +-- descriptors. +-- +-- epoll decouples monitor an fd from the process of registering it. +-- +module System.Event.EPoll + ( + new + , available + ) where + +import qualified System.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_EPOLL) +import GHC.Base + +new :: IO E.Backend +new = error "EPoll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +#include + +import Control.Monad (when) +import Data.Bits (Bits, (.|.), (.&.)) +import Data.Monoid (Monoid(..)) +import Data.Word (Word32) +import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_) +import Foreign.C.Types (CInt) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Internals (c_close) +#if !defined(HAVE_EPOLL_CREATE1) +import System.Posix.Internals (setCloseOnExec) +#endif +import System.Posix.Types (Fd(..)) + +import qualified System.Event.Array as A +import System.Event.Internal (Timeout(..)) + +available :: Bool +available = True +{-# INLINE available #-} + +data EPoll = EPoll { + epollFd :: {-# UNPACK #-} !EPollFd + , epollEvents :: {-# UNPACK #-} !(A.Array Event) + } + +-- | Create a new epoll backend. +new :: IO E.Backend +new = do + epfd <- epollCreate + evts <- A.new 64 + let !be = E.backend poll modifyFd delete (EPoll epfd evts) + return be + +delete :: EPoll -> IO () +delete be = do + _ <- c_close . fromEPollFd . epollFd $ be + return () + +-- | Change the set of events we are interested in for a given file +-- descriptor. +modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO () +modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $ + epollControl (epollFd ep) op fd + where op | oevt == mempty = controlOpAdd + | nevt == mempty = controlOpDelete + | otherwise = controlOpModify + +-- | Select a set of file descriptors which are ready for I/O +-- operations and call @f@ for all ready file descriptors, passing the +-- events that are ready. +poll :: EPoll -- ^ state + -> Timeout -- ^ timeout in milliseconds + -> (Fd -> E.Event -> IO ()) -- ^ I/O callback + -> IO () +poll ep timeout f = do + let events = epollEvents ep + + -- Will return zero if the system call was interupted, in which case + -- we just return (and try again later.) + n <- A.unsafeLoad events $ \es cap -> + epollWait (epollFd ep) es cap $ fromTimeout timeout + + when (n > 0) $ do + A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e)) + cap <- A.capacity events + when (cap == n) $ A.ensureCapacity events (2 * cap) + +newtype EPollFd = EPollFd { + fromEPollFd :: CInt + } deriving (Eq, Show) + +data Event = Event { + eventTypes :: EventType + , eventFd :: Fd + } deriving (Show) + +instance Storable Event where + sizeOf _ = #size struct epoll_event + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ets <- #{peek struct epoll_event, events} ptr + ed <- #{peek struct epoll_event, data.fd} ptr + let !ev = Event (EventType ets) ed + return ev + + poke ptr e = do + #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e) + #{poke struct epoll_event, data.fd} ptr (eventFd e) + +newtype ControlOp = ControlOp CInt + +#{enum ControlOp, ControlOp + , controlOpAdd = EPOLL_CTL_ADD + , controlOpModify = EPOLL_CTL_MOD + , controlOpDelete = EPOLL_CTL_DEL + } + +newtype EventType = EventType { + unEventType :: Word32 + } deriving (Show, Eq, Num, Bits) + +#{enum EventType, EventType + , epollIn = EPOLLIN + , epollOut = EPOLLOUT + , epollErr = EPOLLERR + , epollHup = EPOLLHUP + } + +-- | Create a new epoll context, returning a file descriptor associated with the context. +-- The fd may be used for subsequent calls to this epoll context. +-- +-- The size parameter to epoll_create is a hint about the expected number of handles. +-- +-- The file descriptor returned from epoll_create() should be destroyed via +-- a call to close() after polling is finished +-- +epollCreate :: IO EPollFd +epollCreate = do + fd <- throwErrnoIfMinus1 "epollCreate" $ +#if defined(HAVE_EPOLL_CREATE1) + c_epoll_create1 (#const EPOLL_CLOEXEC) +#else + c_epoll_create 256 -- argument is ignored + setCloseOnExec fd +#endif + let !epollFd' = EPollFd fd + return epollFd' + +epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO () +epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event = + throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event + +epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int +epollWait (EPollFd epfd) events numEvents timeout = + fmap fromIntegral . + E.throwErrnoIfMinus1NoRetry "epollWait" $ + c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout) + +fromEvent :: E.Event -> EventType +fromEvent e = remap E.evtRead epollIn .|. + remap E.evtWrite epollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: EventType -> E.Event +toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend` + remap (epollOut .|. epollErr .|. epollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +fromTimeout :: Timeout -> Int +fromTimeout Forever = -1 +fromTimeout (Timeout s) = ceiling $ 1000 * s + +#if defined(HAVE_EPOLL_CREATE1) +foreign import ccall unsafe "sys/epoll.h epoll_create1" + c_epoll_create1 :: CInt -> IO CInt +#else +foreign import ccall unsafe "sys/epoll.h epoll_create" + c_epoll_create :: CInt -> IO CInt +#endif + +foreign import ccall unsafe "sys/epoll.h epoll_ctl" + c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt + +foreign import ccall safe "sys/epoll.h epoll_wait" + c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt + +#endif /* defined(HAVE_EPOLL) */ addfile ./System/Event/IntMap.hs hunk ./System/Event/IntMap.hs 1 +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Event.IntMap +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- An efficient implementation of maps from integer keys to values. +-- +-- Since many function names (but not the type name) clash with +-- "Prelude" names, this module is usually imported @qualified@, e.g. +-- +-- > import Data.IntMap (IntMap) +-- > import qualified Data.IntMap as IntMap +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' +-- and 'intersection'. However, my benchmarks show that it is also +-- (much) faster on insertions and deletions when compared to a generic +-- size-balanced map implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve +-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), +-- October 1968, pages 514-534. +-- +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). +----------------------------------------------------------------------------- + +module System.Event.IntMap + ( + -- * Map type + IntMap + , Key + + -- * Query + , lookup + , member + + -- * Construction + , empty + + -- * Insertion + , insertWith + + -- * Delete\/Update + , delete + , updateWith + + -- * Traversal + -- ** Fold + , foldWithKey + + -- * Conversion + , keys + ) where + +import Data.Bits + +import Data.Maybe (Maybe(..)) +import GHC.Base hiding (foldr) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (Show(showsPrec), showParen, shows, showString) + +#if __GLASGOW_HASKELL__ +import GHC.Word (Word(..)) +#else +import Data.Word +#endif + +-- | A @Nat@ is a natural machine word (an unsigned Int) +type Nat = Word + +natFromInt :: Key -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Key +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Key -> Nat +#if __GLASGOW_HASKELL__ +-- GHC: use unboxing to get @shiftRL@ inlined. +shiftRL (W# x) (I# i) = W# (shiftRL# x i) +#else +shiftRL x i = shiftR x i +#endif + +------------------------------------------------------------------------ +-- Types + +-- | A map of integers to values @a@. +data IntMap a = Nil + | Tip {-# UNPACK #-} !Key !a + | Bin {-# UNPACK #-} !Prefix + {-# UNPACK #-} !Mask + !(IntMap a) + !(IntMap a) + +type Prefix = Int +type Mask = Int +type Key = Int + +------------------------------------------------------------------------ +-- Query + +-- | /O(min(n,W))/ Lookup the value at a key in the map. See also +-- 'Data.Map.lookup'. +lookup :: Key -> IntMap a -> Maybe a +lookup k t = let nk = natFromInt k in seq nk (lookupN nk t) + +lookupN :: Nat -> IntMap a -> Maybe a +lookupN k t + = case t of + Bin _ m l r + | zeroN k (natFromInt m) -> lookupN k l + | otherwise -> lookupN k r + Tip kx x + | (k == natFromInt kx) -> Just x + | otherwise -> Nothing + Nil -> Nothing + +-- | /O(min(n,W))/. Is the key a member of the map? +-- +-- > member 5 (fromList [(5,'a'), (3,'b')]) == True +-- > member 1 (fromList [(5,'a'), (3,'b')]) == False + +member :: Key -> IntMap a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just _ -> True + +------------------------------------------------------------------------ +-- Construction + +-- | /O(1)/ The empty map. +-- +-- > empty == fromList [] +-- > size empty == 0 +empty :: IntMap a +empty = Nil + +------------------------------------------------------------------------ +-- Insert + +-- | /O(min(n,W))/ Insert with a function, combining new value and old +-- value. @insertWith f key value mp@ will insert the pair (key, +-- value) into @mp@ if key does not exist in the map. If the key does +-- exist, the function will insert the pair (key, f new_value +-- old_value). The result is a pair where the first element is the +-- old value, if one was present, and the second is the modified map. +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertWith f k x t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, join k (Tip k x) p t) + | zero k m -> let (found, l') = insertWith f k x l + in (found, Bin p m l' r) + | otherwise -> let (found, r') = insertWith f k x r + in (found, Bin p m l r') + Tip ky y + | k == ky -> (Just y, Tip k (f x y)) + | otherwise -> (Nothing, join k (Tip k x) ky t) + Nil -> (Nothing, Tip k x) + + +------------------------------------------------------------------------ +-- Delete/Update + +-- | /O(min(n,W))/. Delete a key and its value from the map. When the +-- key is not a member of the map, the original map is returned. The +-- result is a pair where the first element is the value associated +-- with the deleted key, if one existed, and the second element is the +-- modified map. +delete :: Key -> IntMap a -> (Maybe a, IntMap a) +delete k t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, t) + | zero k m -> let (found, l') = delete k l + in (found, bin p m l' r) + | otherwise -> let (found, r') = delete k r + in (found, bin p m l r') + Tip ky y + | k == ky -> (Just y, Nil) + | otherwise -> (Nothing, t) + Nil -> (Nothing, Nil) + +updateWith :: (a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) +updateWith f k t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, t) + | zero k m -> let (found, l') = updateWith f k l + in (found, bin p m l' r) + | otherwise -> let (found, r') = updateWith f k r + in (found, bin p m l r') + Tip ky y + | k == ky -> case (f y) of + Just y' -> (Just y, Tip ky y') + Nothing -> (Just y, Nil) + | otherwise -> (Nothing, t) + Nil -> (Nothing, Nil) +-- | /O(n)/. Fold the keys and values in the map, such that +-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- For example, +-- +-- > keys map = foldWithKey (\k x ks -> k:ks) [] map +-- +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" + +foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey f z t + = foldr f z t + +-- | /O(n)/. Convert the map to a list of key\/value pairs. +-- +-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +-- > toList empty == [] + +toList :: IntMap a -> [(Key,a)] +toList t + = foldWithKey (\k x xs -> (k,x):xs) [] t + +foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldr f z t + = case t of + Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before. + Bin _ _ _ _ -> foldr' f z t + Tip k x -> f k x z + Nil -> z + +foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldr' f z t + = case t of + Bin _ _ l r -> foldr' f (foldr' f z r) l + Tip k x -> f k x z + Nil -> z + +-- | /O(n)/. Return all keys of the map in ascending order. +-- +-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] +-- > keys empty == [] + +keys :: IntMap a -> [Key] +keys m + = foldWithKey (\k _ ks -> k:ks) [] m + +------------------------------------------------------------------------ +-- Eq + +instance Eq a => Eq (IntMap a) where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Eq a => IntMap a -> IntMap a -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y) + = (kx == ky) && (x==y) +equal Nil Nil = True +equal _ _ = False + +nequal :: Eq a => IntMap a -> IntMap a -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y) + = (kx /= ky) || (x/=y) +nequal Nil Nil = False +nequal _ _ = True + +instance Show a => Show (IntMap a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +------------------------------------------------------------------------ +-- Utility functions + +join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +-- | @bin@ assures that we never have empty trees within a tree. +bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a +bin _ _ l Nil = l +bin _ _ Nil r = r +bin p m l r = Bin p m l r + +------------------------------------------------------------------------ +-- Endian independent bit twiddling + +zero :: Key -> Mask -> Bool +zero i m = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch :: Key -> Prefix -> Mask -> Bool +nomatch i p m = (mask i m) /= p + +mask :: Key -> Mask -> Prefix +mask i m = maskW (natFromInt i) (natFromInt m) + +zeroN :: Nat -> Nat -> Bool +zeroN i m = (i .&. m) == 0 + +------------------------------------------------------------------------ +-- Big endian operations + +maskW :: Nat -> Nat -> Prefix +maskW i m = intFromNat (i .&. (complement (m-1) `xor` m)) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{- +Finding the highest bit mask in a word [x] can be done efficiently in +three ways: + +* convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + +* use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + +* use processor specific assembler instruction (asm). + +The most portable way would be [bit], but is it efficient enough? +I have measured the cycle counts of the different methods on an AMD +Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + +highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + +Wow, the bit twiddling is on today's RISC like machines even faster +than a single CISC instruction (BSR)! +-} + +-- | @highestBitMask@ returns a word where only the highest bit is +-- set. It is found by first setting all bits in lower positions than +-- the highest bit and than taking an exclusive or with the original +-- value. Allthough the function may look expensive, GHC compiles +-- this into excellent C code that subsequently compiled into highly +-- efficient machine code. The algorithm is derived from Jorg Arndt's +-- FXT library. +highestBitMask :: Nat -> Nat +highestBitMask x0 + = case (x0 .|. shiftRL x0 1) of + x1 -> case (x1 .|. shiftRL x1 2) of + x2 -> case (x2 .|. shiftRL x2 4) of + x3 -> case (x3 .|. shiftRL x3 8) of + x4 -> case (x4 .|. shiftRL x4 16) of + x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms + x6 -> (x6 `xor` (shiftRL x6 1)) addfile ./System/Event/Internal.hs hunk ./System/Event/Internal.hs 1 +{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-} + +module System.Event.Internal + ( + -- * Event back end + Backend + , backend + , delete + , poll + , modifyFd + -- * Event type + , Event + , evtRead + , evtWrite + , eventIs + -- * Timeout type + , Timeout(..) + -- * Helpers + , throwErrnoIfMinus1NoRetry + ) where + +import Data.Bits ((.|.), (.&.)) +import Data.List (foldl', intercalate) +import Data.Monoid (Monoid(..)) +import Foreign.C.Error (eINTR, getErrno, throwErrno) +import System.Posix.Types (Fd) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) +import GHC.List (filter, null) + +-- | An I/O event. +newtype Event = Event Int + deriving (Eq) + +evtNothing :: Event +evtNothing = Event 0 +{-# INLINE evtNothing #-} + +evtRead :: Event +evtRead = Event 1 +{-# INLINE evtRead #-} + +evtWrite :: Event +evtWrite = Event 2 +{-# INLINE evtWrite #-} + +eventIs :: Event -> Event -> Bool +eventIs (Event a) (Event b) = a .&. b /= 0 + +instance Show Event where + show e = '[' : (intercalate "," . filter (not . null) $ + [evtRead `so` "evtRead", evtWrite `so` "evtWrite"]) ++ "]" + where ev `so` disp | e `eventIs` ev = disp + | otherwise = "" + +instance Monoid Event where + mempty = evtNothing + mappend = evtCombine + mconcat = evtConcat + +evtCombine :: Event -> Event -> Event +evtCombine (Event a) (Event b) = Event (a .|. b) +{-# INLINE evtCombine #-} + +evtConcat :: [Event] -> Event +evtConcat = foldl' evtCombine evtNothing +{-# INLINE evtConcat #-} + +-- | A type alias for timeouts, specified in seconds. +data Timeout = Timeout {-# UNPACK #-} !Double + | Forever + deriving (Show) + +-- | Event notification backend. +data Backend = forall a. Backend { + _beState :: !a + + -- | Poll backend for new events. The provided callback is called + -- once per file descriptor with new events. + , _bePoll :: a -- backend state + -> Timeout -- timeout in milliseconds + -> (Fd -> Event -> IO ()) -- I/O callback + -> IO () + + -- | Register, modify, or unregister interest in the given events + -- on the given file descriptor. + , _beModifyFd :: a + -> Fd -- file descriptor + -> Event -- old events to watch for ('mempty' for new) + -> Event -- new events to watch for ('mempty' to delete) + -> IO () + + , _beDelete :: a -> IO () + } + +backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ()) + -> (a -> Fd -> Event -> Event -> IO ()) + -> (a -> IO ()) + -> a + -> Backend +backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete +{-# INLINE backend #-} + +poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO () +poll (Backend bState bPoll _ _) = bPoll bState +{-# INLINE poll #-} + +modifyFd :: Backend -> Fd -> Event -> Event -> IO () +modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState +{-# INLINE modifyFd #-} + +delete :: Backend -> IO () +delete (Backend bState _ _ bDelete) = bDelete bState +{-# INLINE delete #-} + +-- | Throw an 'IOError' corresponding to the current value of +-- 'getErrno' if the result value of the 'IO' action is -1 and +-- 'getErrno' is not 'eINTR'. If the result value is -1 and +-- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result +-- value is returned. +throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1NoRetry loc f = do + res <- f + if res == -1 + then do + err <- getErrno + if err == eINTR then return 0 else throwErrno loc + else return res addfile ./System/Event/KQueue.hsc hunk ./System/Event/KQueue.hsc 1 +{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, + NoImplicitPrelude, RecordWildCards #-} + +module System.Event.KQueue + ( + new + , available + ) where + +import qualified System.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_KQUEUE) +import GHC.Base + +new :: IO E.Backend +new = error "KQueue back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar) +import Control.Monad (when, unless) +import Data.Bits (Bits(..)) +import Data.Word (Word16, Word32) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CInt, CIntPtr, CLong, CTime, CUIntPtr) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Enum (toEnum) +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, floor, fromIntegral) +import GHC.Show (Show(show)) +import System.Event.Internal (Timeout(..)) +import System.Posix.Internals (c_close) +import System.Posix.Types (Fd(..)) +import qualified System.Event.Array as A + +#if defined(HAVE_KEVENT64) +import Data.Int (Int64) +import Data.Word (Word64) +import Foreign.C.Types (CUInt) +#endif + +#include +#include +#include + +-- Handle brokenness on some BSD variants, notably OS X up to at least +-- 10.6. If NOTE_EOF isn't available, we have no way to receive a +-- notification from the kernel when we reach EOF on a plain file. +#ifndef NOTE_EOF +# define NOTE_EOF 0 +#endif + +available :: Bool +available = True +{-# INLINE available #-} + +------------------------------------------------------------------------ +-- Exported interface + +data EventQueue = EventQueue { + eqFd :: {-# UNPACK #-} !QueueFd + , eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event)) + , eqEvents :: {-# UNPACK #-} !(A.Array Event) + } + +new :: IO E.Backend +new = do + qfd <- kqueue + changesArr <- A.empty + changes <- newMVar changesArr + events <- A.new 64 + let !be = E.backend poll modifyFd delete (EventQueue qfd changes events) + return be + +delete :: EventQueue -> IO () +delete q = do + _ <- c_close . fromQueueFd . eqFd $ q + return () + +modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO () +modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do + let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF + when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete + when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete + when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd + when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd + +poll :: EventQueue + -> Timeout + -> (Fd -> E.Event -> IO ()) + -> IO () +poll EventQueue{..} tout f = do + changesArr <- A.empty + changes <- swapMVar eqChanges changesArr + changesLen <- A.length changes + len <- A.length eqEvents + when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen) + n <- A.useAsPtr changes $ \changesPtr chLen -> + A.unsafeLoad eqEvents $ \evPtr evCap -> + withTimeSpec (fromTimeout tout) $ + kevent eqFd changesPtr chLen evPtr evCap + + unless (n == 0) $ do + cap <- A.capacity eqEvents + when (n == cap) $ A.ensureCapacity eqEvents (2 * cap) + A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e)) + +------------------------------------------------------------------------ +-- FFI binding + +newtype QueueFd = QueueFd { + fromQueueFd :: CInt + } deriving (Eq, Show) + +#if defined(HAVE_KEVENT64) +data Event = KEvent64 { + ident :: {-# UNPACK #-} !Word64 + , filter :: {-# UNPACK #-} !Filter + , flags :: {-# UNPACK #-} !Flag + , fflags :: {-# UNPACK #-} !FFlag + , data_ :: {-# UNPACK #-} !Int64 + , udata :: {-# UNPACK #-} !Word64 + , ext0 :: {-# UNPACK #-} !Word64 + , ext1 :: {-# UNPACK #-} !Word64 + } deriving Show + +event :: Fd -> Filter -> Flag -> FFlag -> Event +event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0 + +instance Storable Event where + sizeOf _ = #size struct kevent64_s + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ident' <- #{peek struct kevent64_s, ident} ptr + filter' <- #{peek struct kevent64_s, filter} ptr + flags' <- #{peek struct kevent64_s, flags} ptr + fflags' <- #{peek struct kevent64_s, fflags} ptr + data' <- #{peek struct kevent64_s, data} ptr + udata' <- #{peek struct kevent64_s, udata} ptr + ext0' <- #{peek struct kevent64_s, ext[0]} ptr + ext1' <- #{peek struct kevent64_s, ext[1]} ptr + let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data' + udata' ext0' ext1' + return ev + + poke ptr ev = do + #{poke struct kevent64_s, ident} ptr (ident ev) + #{poke struct kevent64_s, filter} ptr (filter ev) + #{poke struct kevent64_s, flags} ptr (flags ev) + #{poke struct kevent64_s, fflags} ptr (fflags ev) + #{poke struct kevent64_s, data} ptr (data_ ev) + #{poke struct kevent64_s, udata} ptr (udata ev) + #{poke struct kevent64_s, ext[0]} ptr (ext0 ev) + #{poke struct kevent64_s, ext[1]} ptr (ext1 ev) +#else +data Event = KEvent { + ident :: {-# UNPACK #-} !CUIntPtr + , filter :: {-# UNPACK #-} !Filter + , flags :: {-# UNPACK #-} !Flag + , fflags :: {-# UNPACK #-} !FFlag + , data_ :: {-# UNPACK #-} !CIntPtr + , udata :: {-# UNPACK #-} !(Ptr ()) + } deriving Show + +event :: Fd -> Filter -> Flag -> FFlag -> Event +event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr + +instance Storable Event where + sizeOf _ = #size struct kevent + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ident' <- #{peek struct kevent, ident} ptr + filter' <- #{peek struct kevent, filter} ptr + flags' <- #{peek struct kevent, flags} ptr + fflags' <- #{peek struct kevent, fflags} ptr + data' <- #{peek struct kevent, data} ptr + udata' <- #{peek struct kevent, udata} ptr + let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data' + udata' + return ev + + poke ptr ev = do + #{poke struct kevent, ident} ptr (ident ev) + #{poke struct kevent, filter} ptr (filter ev) + #{poke struct kevent, flags} ptr (flags ev) + #{poke struct kevent, fflags} ptr (fflags ev) + #{poke struct kevent, data} ptr (data_ ev) + #{poke struct kevent, udata} ptr (udata ev) +#endif + +newtype FFlag = FFlag Word32 + deriving (Eq, Show, Storable) + +#{enum FFlag, FFlag + , noteEOF = NOTE_EOF + } + +newtype Flag = Flag Word16 + deriving (Eq, Show, Storable) + +#{enum Flag, Flag + , flagAdd = EV_ADD + , flagDelete = EV_DELETE + } + +newtype Filter = Filter Word16 + deriving (Bits, Eq, Num, Show, Storable) + +#{enum Filter, Filter + , filterRead = EVFILT_READ + , filterWrite = EVFILT_WRITE + } + +data TimeSpec = TimeSpec { + tv_sec :: {-# UNPACK #-} !CTime + , tv_nsec :: {-# UNPACK #-} !CLong + } + +instance Storable TimeSpec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + tv_sec' <- #{peek struct timespec, tv_sec} ptr + tv_nsec' <- #{peek struct timespec, tv_nsec} ptr + let !ts = TimeSpec tv_sec' tv_nsec' + return ts + + poke ptr ts = do + #{poke struct timespec, tv_sec} ptr (tv_sec ts) + #{poke struct timespec, tv_nsec} ptr (tv_nsec ts) + +kqueue :: IO QueueFd +kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue + +-- TODO: We cannot retry on EINTR as the timeout would be wrong. +-- Perhaps we should just return without calling any callbacks. +kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec + -> IO Int +kevent k chs chlen evs evlen ts + = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $ +#if defined(HAVE_KEVENT64) + c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts +#else + c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts +#endif + +withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a +withTimeSpec ts f = + if tv_sec ts < 0 then + f nullPtr + else + alloca $ \ptr -> poke ptr ts >> f ptr + +fromTimeout :: Timeout -> TimeSpec +fromTimeout Forever = TimeSpec (-1) (-1) +fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec) + where + sec :: Int + sec = floor s + + nanosec :: Int + nanosec = ceiling $ (s - fromIntegral sec) * 1000000000 + +toEvent :: Filter -> E.Event +toEvent (Filter f) + | f == (#const EVFILT_READ) = E.evtRead + | f == (#const EVFILT_WRITE) = E.evtWrite + | otherwise = error $ "toEvent: unknonwn filter " ++ show f + +foreign import ccall unsafe "kqueue" + c_kqueue :: IO CInt + +#if defined(HAVE_KEVENT64) +foreign import ccall safe "kevent64" + c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt + -> Ptr TimeSpec -> IO CInt +#elif defined(HAVE_KEVENT) +foreign import ccall safe "kevent" + c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt + -> Ptr TimeSpec -> IO CInt +#else +#error no kevent system call available!? +#endif + +#endif /* defined(HAVE_KQUEUE) */ addfile ./System/Event/Manager.hs hunk ./System/Event/Manager.hs 1 +{-# LANGUAGE BangPatterns, CPP, ExistentialQuantification, NoImplicitPrelude, + RecordWildCards, TypeSynonymInstances #-} +module System.Event.Manager + ( -- * Types + EventManager + + -- * Creation + , new + , newWith + , newDefaultBackend + + -- * Running + , finished + , loop + , step + , shutdown + , wakeManager + + -- * Registering interest in I/O events + , Event + , evtRead + , evtWrite + , IOCallback + , FdKey(keyFd) + , registerFd_ + , registerFd + , unregisterFd_ + , unregisterFd + , fdWasClosed + + -- * Registering interest in timeout events + , TimeoutCallback + , TimeoutKey + , registerTimeout + , updateTimeout + , unregisterTimeout + ) where + +#include "EventConfig.h" + +------------------------------------------------------------------------ +-- Imports + +import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, + readMVar) +import Control.Exception (finally) +import Control.Monad ((=<<), forM_, liftM, sequence_, when) +import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef, + writeIORef) +import Data.Maybe (Maybe(..)) +import Data.Monoid (mconcat, mempty) +import GHC.Base +import GHC.Conc.Signal (runHandlers) +import GHC.List (filter) +import GHC.Num (Num(..)) +import GHC.Real ((/), fromIntegral, fromRational) +import GHC.Show (Show(..)) +import System.Event.Clock (getCurrentTime) +import System.Event.Control +import System.Event.Internal (Backend, Event, evtRead, evtWrite, Timeout(..)) +import System.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import System.Posix.Types (Fd) + +import qualified System.Event.IntMap as IM +import qualified System.Event.Internal as I +import qualified System.Event.PSQ as Q + +#if defined(HAVE_KQUEUE) +import qualified System.Event.KQueue as KQueue +#elif defined(HAVE_EPOLL) +import qualified System.Event.EPoll as EPoll +#elif defined(HAVE_POLL) +import qualified System.Event.Poll as Poll +#else +# error not implemented for this operating system +#endif + +------------------------------------------------------------------------ +-- Types + +data FdData = FdData { + fdKey :: {-# UNPACK #-} !FdKey + , fdEvents :: {-# UNPACK #-} !Event + , _fdCallback :: !IOCallback + } deriving (Show) + +-- | A file descriptor registration cookie. +data FdKey = FdKey { + keyFd :: {-# UNPACK #-} !Fd + , keyUnique :: {-# UNPACK #-} !Unique + } deriving (Eq, Show) + +-- | Callback invoked on I/O events. +type IOCallback = FdKey -> Event -> IO () + +instance Show IOCallback where + show _ = "IOCallback" + +newtype TimeoutKey = TK Unique + deriving (Eq) + +-- | Callback invoked on timeout events. +type TimeoutCallback = IO () + +data State = Created + | Running + | Dying + | Finished + deriving (Eq, Show) + +-- | A priority search queue, with timeouts as priorities. +type TimeoutQueue = Q.PSQ TimeoutCallback + +{- +Instead of directly modifying the 'TimeoutQueue' in +e.g. 'registerTimeout' we keep a list of edits to perform, in the form +of a chain of function closures, and have the I/O manager thread +perform the edits later. This exist to address the following GC +problem: + +Since e.g. 'registerTimeout' doesn't force the evaluation of the +thunks inside the 'emTimeouts' IORef a number of thunks build up +inside the IORef. If the I/O manager thread doesn't evaluate these +thunks soon enough they'll get promoted to the old generation and +become roots for all subsequent minor GCs. + +When the thunks eventually get evaluated they will each create a new +intermediate 'TimeoutQueue' that immediately becomes garbage. Since +the thunks serve as roots until the next major GC these intermediate +'TimeoutQueue's will get copied unnecesarily in the next minor GC, +increasing GC time. This problem is known as "floating garbage". + +Keeping a list of edits doesn't stop this from happening but makes the +amount of data that gets copied smaller. + +TODO: Evaluate the content of the IORef to WHNF on each insert once +this bug is resolved: http://hackage.haskell.org/trac/ghc/ticket/3838 +-} + +-- | An edit to apply to a 'TimeoutQueue'. +type TimeoutEdit = TimeoutQueue -> TimeoutQueue + +-- | The event manager state. +data EventManager = EventManager + { emBackend :: !Backend + , emFds :: {-# UNPACK #-} !(MVar (IM.IntMap [FdData])) + , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit) + , emState :: {-# UNPACK #-} !(IORef State) + , emUniqueSource :: {-# UNPACK #-} !UniqueSource + , emControl :: {-# UNPACK #-} !Control + } + +------------------------------------------------------------------------ +-- Creation + +handleControlEvent :: EventManager -> FdKey -> Event -> IO () +handleControlEvent mgr reg _evt = do + msg <- readControlMessage (emControl mgr) (keyFd reg) + case msg of + CMsgWakeup -> return () + CMsgDie -> writeIORef (emState mgr) Finished + CMsgSignal fp s -> runHandlers fp s + +newDefaultBackend :: IO Backend +#if defined(HAVE_KQUEUE) +newDefaultBackend = KQueue.new +#elif defined(HAVE_EPOLL) +newDefaultBackend = EPoll.new +#elif defined(HAVE_POLL) +newDefaultBackend = Poll.new +#else +newDefaultBackend = error "no back end for this platform" +#endif + +-- | Create a new event manager. +new :: IO EventManager +new = newWith =<< newDefaultBackend + +newWith :: Backend -> IO EventManager +newWith be = do + iofds <- newMVar IM.empty + timeouts <- newIORef id + ctrl <- newControl + state <- newIORef Created + us <- newSource + _ <- mkWeakIORef state $ do + st <- atomicModifyIORef state $ \s -> (Finished, s) + when (st /= Finished) $ do + I.delete be + closeControl ctrl + let mgr = EventManager { emBackend = be + , emFds = iofds + , emTimeouts = timeouts + , emState = state + , emUniqueSource = us + , emControl = ctrl + } + _ <- registerFd_ mgr (handleControlEvent mgr) (controlReadFd ctrl) evtRead + _ <- registerFd_ mgr (handleControlEvent mgr) (wakeupReadFd ctrl) evtRead + return mgr + +-- | Asynchronously shuts down the event manager, if running. +shutdown :: EventManager -> IO () +shutdown mgr = do + state <- atomicModifyIORef (emState mgr) $ \s -> (Dying, s) + when (state == Running) $ sendDie (emControl mgr) + +finished :: EventManager -> IO Bool +finished mgr = (== Finished) `liftM` readIORef (emState mgr) + +cleanup :: EventManager -> IO () +cleanup EventManager{..} = do + writeIORef emState Finished + I.delete emBackend + closeControl emControl + +------------------------------------------------------------------------ +-- Event loop + +-- | Start handling events. This function loops until told to stop. +-- +-- /Note/: This loop can only be run once per 'EventManager', as it +-- closes all of its control resources when it finishes. +loop :: EventManager -> IO () +loop mgr@EventManager{..} = do + state <- atomicModifyIORef emState $ \s -> case s of + Created -> (Running, s) + _ -> (s, s) + case state of + Created -> go Q.empty `finally` cleanup mgr + Dying -> cleanup mgr + _ -> do cleanup mgr + error $ "System.Event.Manager.loop: state is already " ++ + show state + where + go q = do (running, q') <- step mgr q + when running $ go q' + +step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue) +step mgr@EventManager{..} tq = do + (timeout, q') <- mkTimeout tq + I.poll emBackend timeout (onFdEvent mgr) + state <- readIORef emState + state `seq` return (state == Running, q') + where + + -- | Call all expired timer callbacks and return the time to the + -- next timeout. + mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue) + mkTimeout q = do + now <- getCurrentTime + applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f) + let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q' + sequence_ $ map Q.value expired + let timeout = case Q.minView q'' of + Nothing -> Forever + Just (Q.E _ t _, _) -> + -- This value will always be positive since the call + -- to 'atMost' above removed any timeouts <= 'now' + let t' = t - now in t' `seq` Timeout t' + return (timeout, q'') + +------------------------------------------------------------------------ +-- Registering interest in I/O events + +-- | Register interest in the given events, without waking the event +-- manager thread. The 'Bool' return value indicates whether the +-- event manager ought to be woken. +registerFd_ :: EventManager -> IOCallback -> Fd -> Event + -> IO (FdKey, Bool) +registerFd_ EventManager{..} cb fd evs = do + u <- newUnique emUniqueSource + modifyMVar emFds $ \oldMap -> do + let fd' = fromIntegral fd + reg = FdKey fd u + !fdd = FdData reg evs cb + (!newMap, (oldEvs, newEvs)) = + case IM.insertWith (++) fd' [fdd] oldMap of + (Nothing, n) -> (n, (mempty, evs)) + (Just prev, n) -> (n, pairEvents prev newMap fd') + modify = oldEvs /= newEvs + when modify $ I.modifyFd emBackend fd oldEvs newEvs + return (newMap, (reg, modify)) +{-# INLINE registerFd_ #-} + +-- | @registerFd mgr cb fd evs@ registers interest in the events @evs@ +-- on the file descriptor @fd@. @cb@ is called for each event that +-- occurs. Returns a cookie that can be handed to 'unregisterFd'. +registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO FdKey +registerFd mgr cb fd evs = do + (r, wake) <- registerFd_ mgr cb fd evs + when wake $ wakeManager mgr + return r +{-# INLINE registerFd #-} + +-- | Wake up the event manager. +wakeManager :: EventManager -> IO () +wakeManager mgr = sendWakeup (emControl mgr) + +eventsOf :: [FdData] -> Event +eventsOf = mconcat . map fdEvents + +pairEvents :: [FdData] -> IM.IntMap [FdData] -> Int -> (Event, Event) +pairEvents prev m fd = let l = eventsOf prev + r = case IM.lookup fd m of + Nothing -> mempty + Just fds -> eventsOf fds + in (l, r) + +-- | Drop a previous file descriptor registration, without waking the +-- event manager thread. The return value indicates whether the event +-- manager ought to be woken. +unregisterFd_ :: EventManager -> FdKey -> IO Bool +unregisterFd_ EventManager{..} (FdKey fd u) = + modifyMVar emFds $ \oldMap -> do + let dropReg cbs = case filter ((/= u) . keyUnique . fdKey) cbs of + [] -> Nothing + cbs' -> Just cbs' + fd' = fromIntegral fd + (!newMap, (oldEvs, newEvs)) = + case IM.updateWith dropReg fd' oldMap of + (Nothing, _) -> (oldMap, (mempty, mempty)) + (Just prev, newm) -> (newm, pairEvents prev newm fd') + modify = oldEvs /= newEvs + when modify $ I.modifyFd emBackend fd oldEvs newEvs + return (newMap, modify) + +-- | Drop a previous file descriptor registration. +unregisterFd :: EventManager -> FdKey -> IO () +unregisterFd mgr reg = do + wake <- unregisterFd_ mgr reg + when wake $ wakeManager mgr + +-- | Notify the event manager that a file descriptor has been closed. +fdWasClosed :: EventManager -> Fd -> IO () +fdWasClosed mgr fd = + modifyMVar_ (emFds mgr) $ \oldMap -> + case IM.delete (fromIntegral fd) oldMap of + (Nothing, _) -> return oldMap + (Just fds, !newMap) -> do + when (eventsOf fds /= mempty) $ wakeManager mgr + return newMap + +------------------------------------------------------------------------ +-- Registering interest in timeout events + +-- | Register a timeout in the given number of milliseconds. +registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey +registerTimeout mgr ms cb = do + !key <- newUnique (emUniqueSource mgr) + if ms <= 0 then cb + else do + now <- getCurrentTime + let expTime = fromIntegral ms / 1000.0 + now + + -- We intentionally do not evaluate the modified map to WHNF here. + -- Instead, we leave a thunk inside the IORef and defer its + -- evaluation until mkTimeout in the event loop. This is a + -- workaround for a nasty IORef contention problem that causes the + -- thread-delay benchmark to take 20 seconds instead of 0.2. + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.insert key expTime cb) . f in (f', ()) + wakeManager mgr + return $ TK key + +unregisterTimeout :: EventManager -> TimeoutKey -> IO () +unregisterTimeout mgr (TK key) = do + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.delete key) . f in (f', ()) + wakeManager mgr + +updateTimeout :: EventManager -> TimeoutKey -> Int -> IO () +updateTimeout mgr (TK key) ms = do + now <- getCurrentTime + let expTime = fromIntegral ms / 1000.0 + now + + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.adjust (const expTime) key) . f in (f', ()) + wakeManager mgr + +------------------------------------------------------------------------ +-- Utilities + +-- | Call the callbacks corresponding to the given file descriptor. +onFdEvent :: EventManager -> Fd -> Event -> IO () +onFdEvent mgr fd evs = do + fds <- readMVar (emFds mgr) + case IM.lookup (fromIntegral fd) fds of + Just cbs -> forM_ cbs $ \(FdData reg ev cb) -> + when (evs `I.eventIs` ev) $ cb reg evs + Nothing -> return () addfile ./System/Event/PSQ.hs hunk ./System/Event/PSQ.hs 1 +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +-- Copyright (c) 2008, Ralf Hinze +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- * Redistributions of source code must retain the above +-- copyright notice, this list of conditions and the following +-- disclaimer. +-- +-- * Redistributions in binary form must reproduce the above +-- copyright notice, this list of conditions and the following +-- disclaimer in the documentation and/or other materials +-- provided with the distribution. +-- +-- * The names of the contributors may not be used to endorse or +-- promote products derived from this software without specific +-- prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +-- OF THE POSSIBILITY OF SUCH DAMAGE. + +-- | A /priority search queue/ (henceforth /queue/) efficiently +-- supports the operations of both a search tree and a priority queue. +-- An 'Elem'ent is a product of a key, a priority, and a +-- value. Elements can be inserted, deleted, modified and queried in +-- logarithmic time, and the element with the least priority can be +-- retrieved in constant time. A queue can be built from a list of +-- elements, sorted by keys, in linear time. +-- +-- This implementation is due to Ralf Hinze with some modifications by +-- Scott Dillard and Johan Tibell. +-- +-- * Hinze, R., /A Simple Implementation Technique for Priority Search +-- Queues/, ICFP 2001, pp. 110-121 +-- +-- +module System.Event.PSQ + ( + -- * Binding Type + Elem(..) + , Key + , Prio + + -- * Priority Search Queue Type + , PSQ + + -- * Query + , size + , null + , lookup + + -- * Construction + , empty + , singleton + + -- * Insertion + , insert + + -- * Delete/Update + , delete + , adjust + + -- * Conversion + , toList + , toAscList + , toDescList + , fromList + + -- * Min + , findMin + , deleteMin + , minView + , atMost + ) where + +import Data.Maybe (Maybe(..)) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Show (Show(showsPrec)) +import System.Event.Unique (Unique) + +-- | @E k p@ binds the key @k@ with the priority @p@. +data Elem a = E + { key :: {-# UNPACK #-} !Key + , prio :: {-# UNPACK #-} !Prio + , value :: a + } deriving (Eq, Show) + +------------------------------------------------------------------------ +-- | A mapping from keys @k@ to priorites @p@. + +type Prio = Double +type Key = Unique + +data PSQ a = Void + | Winner {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- max key + deriving (Eq, Show) + +-- | /O(1)/ The number of elements in a queue. +size :: PSQ a -> Int +size Void = 0 +size (Winner _ lt _) = 1 + size' lt + +-- | /O(1)/ True if the queue is empty. +null :: PSQ a -> Bool +null Void = True +null (Winner _ _ _) = False + +-- | /O(log n)/ The priority and value of a given key, or Nothing if +-- the key is not bound. +lookup :: Key -> PSQ a -> Maybe (Prio, a) +lookup k q = case tourView q of + Null -> Nothing + Single (E k' p v) + | k == k' -> Just (p, v) + | otherwise -> Nothing + tl `Play` tr + | k <= maxKey tl -> lookup k tl + | otherwise -> lookup k tr + +------------------------------------------------------------------------ +-- Construction + +empty :: PSQ a +empty = Void + +-- | /O(1)/ Build a queue with one element. +singleton :: Key -> Prio -> a -> PSQ a +singleton k p v = Winner (E k p v) Start k + +------------------------------------------------------------------------ +-- Insertion + +-- | /O(log n)/ Insert a new key, priority and value in the queue. If +-- the key is already present in the queue, the associated priority +-- and value are replaced with the supplied priority and value. +insert :: Key -> Prio -> a -> PSQ a -> PSQ a +insert k p v q = case q of + Void -> singleton k p v + Winner (E k' p' v') Start _ -> case compare k k' of + LT -> singleton k p v `play` singleton k' p' v' + EQ -> singleton k p v + GT -> singleton k' p' v' `play` singleton k p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m') + +------------------------------------------------------------------------ +-- Delete/Update + +-- | /O(log n)/ Delete a key and its priority and value from the +-- queue. When the key is not a member of the queue, the original +-- queue is returned. +delete :: Key -> PSQ a -> PSQ a +delete k q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> empty + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m') + +-- | /O(log n)/ Update a priority at a specific key with the result +-- of the provided function. When the key is not a member of the +-- queue, the original queue is returned. +adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a +adjust f k q0 = go q0 + where + go q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> singleton k' (f p) v + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> go (Winner e tl m) `unsafePlay` (Winner e' tr m') + | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> go (Winner e' tl m) `unsafePlay` (Winner e tr m') + | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m') +{-# INLINE adjust #-} + +------------------------------------------------------------------------ +-- Conversion + +-- | /O(n*log n)/ Build a queue from a list of key/priority/value +-- tuples. If the list contains more than one priority and value for +-- the same key, the last priority and value for the key is retained. +fromList :: [Elem a] -> PSQ a +fromList = foldr (\(E k p v) q -> insert k p v q) empty + +-- | /O(n)/ Convert to a list of key/priority/value tuples. +toList :: PSQ a -> [Elem a] +toList = toAscList + +-- | /O(n)/ Convert to an ascending list. +toAscList :: PSQ a -> [Elem a] +toAscList q = seqToList (toAscLists q) + +toAscLists :: PSQ a -> Sequ (Elem a) +toAscLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toAscLists tl <> toAscLists tr + +-- | /O(n)/ Convert to a descending list. +toDescList :: PSQ a -> [ Elem a ] +toDescList q = seqToList (toDescLists q) + +toDescLists :: PSQ a -> Sequ (Elem a) +toDescLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toDescLists tr <> toDescLists tl + +------------------------------------------------------------------------ +-- Min + +-- | /O(1)/ The element with the lowest priority. +findMin :: PSQ a -> Maybe (Elem a) +findMin Void = Nothing +findMin (Winner e _ _) = Just e + +-- | /O(log n)/ Delete the element with the lowest priority. Returns +-- an empty queue if the queue is empty. +deleteMin :: PSQ a -> PSQ a +deleteMin Void = Void +deleteMin (Winner _ t m) = secondBest t m + +-- | /O(log n)/ Retrieve the binding with the least priority, and the +-- rest of the queue stripped of that binding. +minView :: PSQ a -> Maybe (Elem a, PSQ a) +minView Void = Nothing +minView (Winner e t m) = Just (e, secondBest t m) + +secondBest :: LTree a -> Key -> PSQ a +secondBest Start _ = Void +secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' +secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' + +-- | /O(r*(log n - log r))/ Return a list of elements ordered by +-- key whose priorities are at most @pt@. +atMost :: Prio -> PSQ a -> ([Elem a], PSQ a) +atMost pt q = let (sequ, q') = atMosts pt q + in (seqToList sequ, q') + +atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a) +atMosts !pt q = case q of + (Winner e _ _) + | prio e > pt -> (emptySequ, q) + Void -> (emptySequ, Void) + Winner e Start _ -> (singleSequ e, Void) + Winner e (RLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e tl m) + (sequ', q'') = atMosts pt (Winner e' tr m') + in (sequ <> sequ', q' `play` q'') + Winner e (LLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e' tl m) + (sequ', q'') = atMosts pt (Winner e tr m') + in (sequ <> sequ', q' `play` q'') + +------------------------------------------------------------------------ +-- Loser tree + +type Size = Int + +data LTree a = Start + | LLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + | RLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + deriving (Eq, Show) + +size' :: LTree a -> Size +size' Start = 0 +size' (LLoser s _ _ _ _) = s +size' (RLoser s _ _ _ _) = s + +left, right :: LTree a -> LTree a + +left Start = moduleError "left" "empty loser tree" +left (LLoser _ _ tl _ _ ) = tl +left (RLoser _ _ tl _ _ ) = tl + +right Start = moduleError "right" "empty loser tree" +right (LLoser _ _ _ _ tr) = tr +right (RLoser _ _ _ _ tr) = tr + +maxKey :: PSQ a -> Key +maxKey Void = moduleError "maxKey" "empty queue" +maxKey (Winner _ _ m) = m + +lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr +rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr + +------------------------------------------------------------------------ +-- Balancing + +-- | Balance factor +omega :: Int +omega = 4 + +lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a + +lbalance k p v l m r + | size' l + size' r < 2 = lloser k p v l m r + | size' r > omega * size' l = lbalanceLeft k p v l m r + | size' l > omega * size' r = lbalanceRight k p v l m r + | otherwise = lloser k p v l m r + +rbalance k p v l m r + | size' l + size' r < 2 = rloser k p v l m r + | size' r > omega * size' l = rbalanceLeft k p v l m r + | size' l > omega * size' r = rbalanceRight k p v l m r + | otherwise = rloser k p v l m r + +lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceLeft k p v l m r + | size' (left r) < size' (right r) = lsingleLeft k p v l m r + | otherwise = ldoubleLeft k p v l m r + +lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceRight k p v l m r + | size' (left l) > size' (right l) = lsingleRight k p v l m r + | otherwise = ldoubleRight k p v l m r + +rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceLeft k p v l m r + | size' (left r) < size' (right r) = rsingleLeft k p v l m r + | otherwise = rdoubleLeft k p v l m r + +rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceRight k p v l m r + | size' (left l) > size' (right l) = rsingleRight k p v l m r + | otherwise = rdoubleRight k p v l m r + +lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) + | p1 <= p2 = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 + | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" + +rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 +rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3 +rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree" + +lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3) +lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) +lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" + +rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 + | p1 <= p2 = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) + | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" + +ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" + +ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" + +rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" + +rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree" + +-- | Take two pennants and returns a new pennant that is the union of +-- the two with the precondition that the keys in the first tree are +-- strictly smaller than the keys in the second tree. +play :: PSQ a -> PSQ a -> PSQ a +Void `play` t' = t' +t `play` Void = t +Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rbalance k' p' v' t m t') m' + | otherwise = Winner e' (lbalance k p v t m t') m' +{-# INLINE play #-} + +-- | A version of 'play' that can be used if the shape of the tree has +-- not changed or if the tree is known to be balanced. +unsafePlay :: PSQ a -> PSQ a -> PSQ a +Void `unsafePlay` t' = t' +t `unsafePlay` Void = t +Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rloser k' p' v' t m t') m' + | otherwise = Winner e' (lloser k p v t m t') m' +{-# INLINE unsafePlay #-} + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) + +tourView :: PSQ a -> TourView a +tourView Void = Null +tourView (Winner e Start _) = Single e +tourView (Winner e (RLoser _ e' tl m tr) m') = + Winner e tl m `Play` Winner e' tr m' +tourView (Winner e (LLoser _ e' tl m tr) m') = + Winner e' tl m `Play` Winner e tr m' + +------------------------------------------------------------------------ +-- Utility functions + +moduleError :: String -> String -> a +moduleError fun msg = error ("System.Event.PSQ." ++ fun ++ ':' : ' ' : msg) +{-# NOINLINE moduleError #-} + +------------------------------------------------------------------------ +-- Hughes's efficient sequence type + +newtype Sequ a = Sequ ([a] -> [a]) + +emptySequ :: Sequ a +emptySequ = Sequ (\as -> as) + +singleSequ :: a -> Sequ a +singleSequ a = Sequ (\as -> a : as) + +(<>) :: Sequ a -> Sequ a -> Sequ a +Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as)) +infixr 5 <> + +seqToList :: Sequ a -> [a] +seqToList (Sequ x) = x [] + +instance Show a => Show (Sequ a) where + showsPrec d a = showsPrec d (seqToList a) addfile ./System/Event/Poll.hsc hunk ./System/Event/Poll.hsc 1 +{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, + NoImplicitPrelude #-} + +module System.Event.Poll + ( + new + , available + ) where + +#include "EventConfig.h" + +#if !defined(HAVE_POLL_H) +import GHC.Base + +new :: IO E.Backend +new = error "Poll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else +#include + +import Control.Concurrent.MVar (MVar, newMVar, swapMVar) +import Control.Monad ((=<<), liftM, liftM2, unless) +import Data.Bits (Bits, (.|.), (.&.)) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Foreign.C.Types (CInt, CShort, CULong) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Conc.Sync (withMVar) +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Types (Fd(..)) + +import qualified System.Event.Array as A +import qualified System.Event.Internal as E + +available :: Bool +available = True +{-# INLINE available #-} + +data Poll = Poll { + pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd)) + , pollFd :: {-# UNPACK #-} !(A.Array PollFd) + } + +new :: IO E.Backend +new = E.backend poll modifyFd (\_ -> return ()) `liftM` + liftM2 Poll (newMVar =<< A.empty) A.empty + +modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO () +modifyFd p fd oevt nevt = + withMVar (pollChanges p) $ \ary -> + A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt) + +reworkFd :: Poll -> PollFd -> IO () +reworkFd p (PollFd fd npevt opevt) = do + let ary = pollFd p + if opevt == 0 + then A.snoc ary $ PollFd fd npevt 0 + else do + found <- A.findIndex ((== fd) . pfdFd) ary + case found of + Nothing -> error "reworkFd: event not found" + Just (i,_) + | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 + | otherwise -> A.removeAt ary i + +poll :: Poll + -> E.Timeout + -> (Fd -> E.Event -> IO ()) + -> IO () +poll p tout f = do + let a = pollFd p + mods <- swapMVar (pollChanges p) =<< A.empty + A.forM_ mods (reworkFd p) + n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $ + c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout)) + unless (n == 0) $ do + A.loop a 0 $ \i e -> do + let r = pfdRevents e + if r /= 0 + then do f (pfdFd e) (toEvent r) + let i' = i + 1 + return (i', i' == n) + else return (i, True) + +fromTimeout :: E.Timeout -> Int +fromTimeout E.Forever = -1 +fromTimeout (E.Timeout s) = ceiling $ 1000 * s + +data PollFd = PollFd { + pfdFd :: {-# UNPACK #-} !Fd + , pfdEvents :: {-# UNPACK #-} !Event + , pfdRevents :: {-# UNPACK #-} !Event + } deriving (Show) + +newtype Event = Event CShort + deriving (Eq, Show, Num, Storable, Bits) + +#{enum Event, Event + , pollIn = POLLIN + , pollOut = POLLOUT +#ifdef POLLRDHUP + , pollRdHup = POLLRDHUP +#endif + , pollErr = POLLERR + , pollHup = POLLHUP + } + +fromEvent :: E.Event -> Event +fromEvent e = remap E.evtRead pollIn .|. + remap E.evtWrite pollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: Event -> E.Event +toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend` + remap (pollOut .|. pollErr .|. pollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +instance Storable PollFd where + sizeOf _ = #size struct pollfd + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + fd <- #{peek struct pollfd, fd} ptr + events <- #{peek struct pollfd, events} ptr + revents <- #{peek struct pollfd, revents} ptr + let !pollFd' = PollFd fd events revents + return pollFd' + + poke ptr p = do + #{poke struct pollfd, fd} ptr (pfdFd p) + #{poke struct pollfd, events} ptr (pfdEvents p) + #{poke struct pollfd, revents} ptr (pfdRevents p) + +foreign import ccall safe "poll.h poll" + c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt + +#endif /* defined(HAVE_POLL_H) */ addfile ./System/Event/Thread.hs hunk ./System/Event/Thread.hs 1 +{-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-} + +module System.Event.Thread + ( + ensureIOManagerIsRunning + , threadWaitRead + , threadWaitWrite + , threadDelay + , registerDelay + ) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (Maybe(..)) +import Foreign.Ptr (Ptr) +import GHC.Base +import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, + labelThread, modifyMVar_, newTVar, sharedCAF, + threadStatus, writeTVar) +import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) +import GHC.Num (fromInteger) +import GHC.Real (div) +import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop, + new, registerFd, unregisterFd_, registerTimeout) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (Fd) + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +threadDelay :: Int -> IO () +threadDelay usecs = do + Just mgr <- readIORef eventManager + m <- newEmptyMVar + _ <- registerTimeout mgr (usecs `div` 1000) (putMVar m ()) + takeMVar m + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs = do + t <- atomically $ newTVar False + Just mgr <- readIORef eventManager + _ <- registerTimeout mgr (usecs `div` 1000) . atomically $ writeTVar t True + return t + +-- | Block the current thread until data is available to read from the +-- given file descriptor. +threadWaitRead :: Fd -> IO () +threadWaitRead = threadWait evtRead +{-# INLINE threadWaitRead #-} + +-- | Block the current thread until the given file descriptor can +-- accept data to write. +threadWaitWrite :: Fd -> IO () +threadWaitWrite = threadWait evtWrite +{-# INLINE threadWaitWrite #-} + +threadWait :: Event -> Fd -> IO () +threadWait evt fd = do + m <- newEmptyMVar + Just mgr <- readIORef eventManager + _ <- registerFd mgr (\reg _ -> unregisterFd_ mgr reg >> putMVar m ()) fd evt + takeMVar m + +foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" + getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a) + +eventManager :: IORef (Maybe EventManager) +eventManager = unsafePerformIO $ do + em <- newIORef Nothing + sharedCAF em getOrSetSystemEventThreadEventManagerStore +{-# NOINLINE eventManager #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore" + getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManager #-} +ioManager :: MVar (Maybe ThreadId) +ioManager = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | not threaded = return () + | otherwise = modifyMVar_ ioManager $ \old -> do + let create = do + !mgr <- new + writeIORef eventManager $ Just mgr + !t <- forkIO $ loop mgr + labelThread t "IOManager" + return $ Just t + case old of + Nothing -> create + st@(Just t) -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> create + _other -> return st + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool addfile ./System/Event/Unique.hs hunk ./System/Event/Unique.hs 1 +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-} +module System.Event.Unique + ( + UniqueSource + , Unique(..) + , newSource + , newUnique + ) where + +import Data.Int (Int64) +import GHC.Base +import GHC.Conc.Sync (TVar, atomically, newTVarIO, readTVar, writeTVar) +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) + +-- We used to use IORefs here, but Simon switched us to STM when we +-- found that our use of atomicModifyIORef was subject to a severe RTS +-- performance problem when used in a tight loop from multiple +-- threads: http://hackage.haskell.org/trac/ghc/ticket/3838 +-- +-- There seems to be no performance cost to using a TVar instead. + +newtype UniqueSource = US (TVar Int64) + +newtype Unique = Unique { asInt64 :: Int64 } + deriving (Eq, Ord, Num) + +instance Show Unique where + show = show . asInt64 + +newSource :: IO UniqueSource +newSource = US `fmap` newTVarIO 0 + +newUnique :: UniqueSource -> IO Unique +newUnique (US ref) = atomically $ do + u <- readTVar ref + let !u' = u+1 + writeTVar ref u' + return $ Unique u' +{-# INLINE newUnique #-} hunk ./base.cabal 16 - include/HsBaseConfig.h + include/HsBaseConfig.h include/EventConfig.h hunk ./base.cabal 43 + GHC.Conc.IO, + GHC.Conc.Signal, + GHC.Conc.Sync, hunk ./base.cabal 101 + GHC.Conc.Windows hunk ./base.cabal 109 - if impl(ghc < 6.10) + if impl(ghc < 6.10) hunk ./base.cabal 213 - install-includes: HsBase.h HsBaseConfig.h WCsubst.h consUtils.h Typeable.h + install-includes: HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h hunk ./base.cabal 217 + if !os(windows) { + exposed-modules: + System.Event + other-modules: + System.Event.Array + System.Event.Clock + System.Event.Control + System.Event.EPoll + System.Event.IntMap + System.Event.Internal + System.Event.KQueue + System.Event.Manager + System.Event.PSQ + System.Event.Poll + System.Event.Thread + System.Event.Unique + } hunk ./configure.ac 6 -AC_CONFIG_HEADERS([include/HsBaseConfig.h]) +AC_CONFIG_HEADERS([include/HsBaseConfig.h include/EventConfig.h]) hunk ./configure.ac 20 -AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h]) +AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h poll.h sys/epoll.h sys/event.h sys/eventfd.h]) hunk ./configure.ac 35 +AC_CHECK_FUNCS([epoll_create1 epoll_ctl eventfd kevent kevent64 kqueue poll]) + +# event-related fun + +if test "$ac_cv_header_sys_epoll_h" = yes -a "$ac_cv_func_epoll_ctl" = yes; then + AC_DEFINE([HAVE_EPOLL], [1], [Define if you have epoll support.]) +fi + +if test "$ac_cv_header_sys_event_h" = yes -a "$ac_cv_func_kqueue" = yes; then + AC_DEFINE([HAVE_KQUEUE], [1], [Define if you have kqueue support.]) +fi + +if test "$ac_cv_header_poll_h" = yes -a "$ac_cv_func_poll" = yes; then + AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.]) +fi + addfile ./include/EventConfig.h.in hunk ./include/EventConfig.h.in 1 +/* include/EventConfig.h.in. Generated from configure.ac by autoheader. */ + +/* Define if you have epoll support. */ +#undef HAVE_EPOLL + +/* Define to 1 if you have the `epoll_create1' function. */ +#undef HAVE_EPOLL_CREATE1 + +/* Define to 1 if you have the `epoll_ctl' function. */ +#undef HAVE_EPOLL_CTL + +/* Define to 1 if you have the `eventfd' function. */ +#undef HAVE_EVENTFD + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the `kevent' function. */ +#undef HAVE_KEVENT + +/* Define to 1 if you have the `kevent64' function. */ +#undef HAVE_KEVENT64 + +/* Define if you have kqueue support. */ +#undef HAVE_KQUEUE + +/* Define to 1 if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define if you have poll support. */ +#undef HAVE_POLL + +/* Define to 1 if you have the header file. */ +#undef HAVE_POLL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SIGNAL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_EPOLL_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_EVENTFD_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_EVENT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION + +/* Define to 1 if you have the ANSI C header files. */ +#undef STDC_HEADERS addfile ./include/HsEvent.h hunk ./include/HsEvent.h 1 +#ifndef __HS_EVENT_H__ +#define __HS_EVENT_H__ + +#include "EventConfig.h" + +#include +#include + +#if !defined(INLINE) +# if defined(_MSC_VER) +# define INLINE extern __inline +# else +# define INLINE inline +# endif +#endif + +INLINE int __hsevent_num_signals(void) +{ +#if defined(_NSIG) + return _NSIG; +#else + return 128; /* best guess */ +#endif +} + +INLINE void __hsevent_thread_self(pthread_t *tid) +{ + *tid = pthread_self(); +} + +INLINE int __hsevent_kill_thread(pthread_t *tid, int sig) +{ + return pthread_kill(*tid, sig); +} + +#endif /* __HS_EVENT_H__ */ +/* + * Local Variables: + * c-file-style: "stroustrup" + * End: + */ hunk ./Data/Data.hs 454 -fromConstrM :: (Monad m, Data a) +fromConstrM :: forall m a. (Monad m, Data a) hunk ./Data/Data.hs 460 + k :: (forall b r. Data b => m (b -> r) -> m r) hunk ./Data/Data.hs 462 + + z :: forall r. r -> m r hunk ./Control/Arrow.hs 77 - where swap ~(x,y) = (y,x) + where swap :: (x,y) -> (y,x) + swap ~(x,y) = (y,x) hunk ./Control/Arrow.hs 186 - where mirror (Left x) = Right x + where mirror :: Either x y -> Either y x + mirror (Left x) = Right x hunk ./Data/Data.hs 313 + k :: Data d => ID (d->b) -> d -> ID b hunk ./Data/Data.hs 318 - gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r hunk ./Data/Data.hs 321 + k :: Data d => CONST r (d->b) -> d -> CONST r b hunk ./Data/Data.hs 323 + z :: g -> CONST r g hunk ./Data/Data.hs 327 - gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r + gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r hunk ./Data/Data.hs 330 + k :: Data d => Qr r (d->b) -> d -> Qr r b hunk ./Data/Data.hs 342 - gmapQi :: Int -> (forall d. Data d => d -> u) -> a -> u + gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> a -> u hunk ./Data/Data.hs 345 + k :: Data d => Qi u (d -> b) -> d -> Qi u b hunk ./Data/Data.hs 347 + z :: g -> Qi q g hunk ./Data/Data.hs 356 - gmapM :: Monad m => (forall d. Data d => d -> m d) -> a -> m a + gmapM :: forall m. Monad m => (forall d. Data d => d -> m d) -> a -> m a hunk ./Data/Data.hs 364 + k :: Data d => m (d -> b) -> d -> m b hunk ./Data/Data.hs 371 - gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + gmapMp :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a hunk ./Data/Data.hs 384 + z :: g -> Mp m g hunk ./Data/Data.hs 386 + k :: Data d => Mp m (d -> b) -> d -> Mp m b hunk ./Data/Data.hs 394 - gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + gmapMo :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a hunk ./Data/Data.hs 409 + z :: g -> Mp m g hunk ./Data/Data.hs 411 + k :: Data d => Mp m (d -> b) -> d -> Mp m b hunk ./Data/Data.hs 460 + k :: forall b r. Data b => ID (b -> r) -> ID r hunk ./Data/Data.hs 462 + + z :: forall r. r -> ID r hunk ./Data/Data.hs 474 - k :: (forall b r. Data b => m (b -> r) -> m r) + k :: forall b r. Data b => m (b -> r) -> m r hunk ./System/IO/Error.hs 422 + mplus :: Maybe a -> Maybe a -> Maybe a hunk ./Text/ParserCombinators/ReadP.hs 258 -gather (R m) = - R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) +gather (R m) + = R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) hunk ./Text/ParserCombinators/ReadP.hs 261 + gath :: (String -> String) -> P (String -> P b) -> P b hunk ./Control/Concurrent/Chan.hs 109 +{-# DEPRECATED unGetChan "if you need this operation, use Control.Concurrent.STM.TChan instead. See http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-} hunk ./Control/Concurrent/Chan.hs 118 +{-# DEPRECATED isEmptyChan "if you need this operation, use Control.Concurrent.STM.TChan instead. See http://hackage.haskell.org/trac/ghc/ticket/4154 for details" #-} hunk ./Foreign/Marshal/Alloc.hs 43 + allocaBytesAligned, -- :: Int -> Int -> (Ptr a -> IO b) -> IO b hunk ./Foreign/Marshal/Array.hs 66 -import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff)) -import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes) +import Foreign.Storable (Storable(alignment,sizeOf,peekElemOff,pokeElemOff)) +import Foreign.Marshal.Alloc (mallocBytes, allocaBytesAligned, reallocBytes) hunk ./Foreign/Marshal/Array.hs 104 - doAlloca dummy size = allocaBytes (size * sizeOf dummy) + doAlloca dummy size = allocaBytesAligned (size * sizeOf dummy) + (alignment dummy) hunk ./System/Event/Manager.hs 347 --- | Register a timeout in the given number of milliseconds. +-- | Register a timeout in the given number of microseconds. hunk ./System/Event/Manager.hs 349 -registerTimeout mgr ms cb = do +registerTimeout mgr us cb = do hunk ./System/Event/Manager.hs 351 - if ms <= 0 then cb + if us <= 0 then cb hunk ./System/Event/Manager.hs 354 - let expTime = fromIntegral ms / 1000.0 + now + let expTime = fromIntegral us / 1000000.0 + now hunk ./System/Event/Manager.hs 373 -updateTimeout mgr (TK key) ms = do +updateTimeout mgr (TK key) us = do hunk ./System/Event/Manager.hs 375 - let expTime = fromIntegral ms / 1000.0 + now + let expTime = fromIntegral us / 1000000.0 + now hunk ./System/Event/Thread.hs 20 -import GHC.Num (fromInteger) -import GHC.Real (div) hunk ./System/Event/Thread.hs 35 - _ <- registerTimeout mgr (usecs `div` 1000) (putMVar m ()) + _ <- registerTimeout mgr usecs (putMVar m ()) hunk ./System/Event/Thread.hs 45 - _ <- registerTimeout mgr (usecs `div` 1000) . atomically $ writeTVar t True + _ <- registerTimeout mgr usecs . atomically $ writeTVar t True hunk ./GHC/IO/Encoding/UTF16.hs 51 +import GHC.Ptr hunk ./GHC/IO/Encoding/UTF16.hs 55 - c_write 1 p (fromIntegral len) + c_write 1 (castPtr p) (fromIntegral len) hunk ./aclocal.m4 182 -[AS_VAR_PUSHDEF([ac_Search], [ac_cv_search_$3])dnl +[AS_VAR_PUSHDEF([ac_Search], [ac_cv_search_$1])dnl hunk ./System/Event/KQueue.hsc 29 -import Foreign.C.Types (CInt, CIntPtr, CLong, CTime, CUIntPtr) +import Foreign.C.Types (CInt, CLong, CTime) hunk ./System/Event/KQueue.hsc 48 +#else +import Foreign.C.Types (CIntPtr, CUIntPtr)