import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield,
threadDelay, forkIO, childHandler )
import qualified GHC.Conc
-import GHC.TopHandler ( reportStackOverflow, reportError )
import GHC.IOBase ( IO(..) )
import GHC.IOBase ( unsafeInterleaveIO )
import GHC.IOBase ( newIORef, readIORef, writeIORef )
foreign import ccall "forkOS_entry" forkOS_entry_reimported
:: StablePtr (IO ()) -> IO ()
+forkOS_entry :: StablePtr (IO ()) -> IO ()
forkOS_entry stableAction = do
action <- deRefStablePtr stableAction
action
foreign import ccall forkOS_createThread
:: StablePtr (IO ()) -> IO CInt
+failNonThreaded :: IO a
failNonThreaded = fail $ "RTS doesn't support multiple OS threads "
++"(use ghc -threaded when linking)"
then do
mv <- newEmptyMVar
forkIO (Exception.try action >>= putMVar mv)
- takeMVar mv >>= \either -> case either of
+ takeMVar mv >>= \ei -> case ei of
Left exception -> Exception.throw (exception :: SomeException)
Right result -> return result
else action
newChan :: IO (Chan a)
newChan = do
hole <- newEmptyMVar
- read <- newMVar hole
- write <- newMVar hole
- return (Chan read write)
+ readVar <- newMVar hole
+ writeVar <- newMVar hole
+ return (Chan readVar writeVar)
-- To put an element on a channel, a new hole at the write end is created.
-- What was previously the empty @MVar@ at the back of the channel is then
-- |Write a value to a 'Chan'.
writeChan :: Chan a -> a -> IO ()
-writeChan (Chan _read write) val = do
+writeChan (Chan _ writeVar) val = do
new_hole <- newEmptyMVar
- modifyMVar_ write $ \old_hole -> do
+ modifyMVar_ writeVar $ \old_hole -> do
putMVar old_hole (ChItem val new_hole)
return new_hole
-- |Read the next value from the 'Chan'.
readChan :: Chan a -> IO a
-readChan (Chan read _write) = do
- modifyMVar read $ \read_end -> do
+readChan (Chan readVar _) = do
+ modifyMVar readVar $ \read_end -> do
(ChItem val new_read_end) <- readMVar read_end
-- Use readMVar here, not takeMVar,
-- else dupChan doesn't work
-- a kind of broadcast channel, where data written by anyone is seen by
-- everyone else.
dupChan :: Chan a -> IO (Chan a)
-dupChan (Chan _read write) = do
- hole <- readMVar write
- new_read <- newMVar hole
- return (Chan new_read write)
+dupChan (Chan _ writeVar) = do
+ hole <- readMVar writeVar
+ newReadVar <- newMVar hole
+ return (Chan newReadVar writeVar)
-- |Put a data item back onto a channel, where it will be the next item read.
unGetChan :: Chan a -> a -> IO ()
-unGetChan (Chan read _write) val = do
+unGetChan (Chan readVar _) val = do
new_read_end <- newEmptyMVar
- modifyMVar_ read $ \read_end -> do
+ modifyMVar_ readVar $ \read_end -> do
putMVar new_read_end (ChItem val read_end)
return new_read_end
-- |Returns 'True' if the supplied 'Chan' is empty.
isEmptyChan :: Chan a -> IO Bool
-isEmptyChan (Chan read write) = do
- withMVar read $ \r -> do
- w <- readMVar write
+isEmptyChan (Chan readVar writeVar) = do
+ withMVar readVar $ \r -> do
+ w <- readMVar writeVar
let eq = r == w
eq `seq` return eq
-- |Build a new 'QSem'
newQSem :: Int -> IO QSem
-newQSem init = do
- sem <- newMVar (init,[])
+newQSem initial = do
+ sem <- newMVar (initial, [])
return (QSem sem)
-- |Wait for a unit to become available
-- |Build a new 'QSemN' with a supplied initial quantity.
newQSemN :: Int -> IO QSemN
-newQSemN init = do
- sem <- newMVar (init,[])
+newQSemN initial = do
+ sem <- newMVar (initial, [])
return (QSemN sem)
-- |Wait for the specified quantity to become available
--
isEmptySampleVar :: SampleVar a -> IO Bool
isEmptySampleVar svar = do
- (readers,val) <- readMVar svar
+ (readers, _) <- readMVar svar
return (readers == 0)
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Control.Monad.ST
#ifdef __NHC__
catchDyn m k = m -- can't catch dyn exceptions in nhc98
#else
-catchDyn m k = New.catch m handle
- where handle ex = case ex of
+catchDyn m k = New.catch m handler
+ where handler ex = case ex of
(DynException dyn) ->
case fromDynamic dyn of
Just exception -> k exception
-- record update in the source program.
INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
-nonTermination :: SomeException
-nonTermination = New.toException NonTermination
-
-- helper type for simplifying the type casting logic below
data Caster = forall e . ExceptionBase.Exception e => Caster (e -> Exception)
-- We need to collect all the sorts of exceptions that used to be
-- bundled up into the Exception type, and rebundle them for
-- legacy handlers.
- fromException (SomeException exc) = foldr tryCast Nothing casters where
- tryCast (Caster f) e = case cast exc of
+ fromException (SomeException exc0) = foldr tryCast Nothing casters where
+ tryCast (Caster f) e = case cast exc0 of
Just exc -> Just (f exc)
_ -> e
casters =
-- instances for Prelude types
instance Foldable Maybe where
- foldr f z Nothing = z
+ foldr _ z Nothing = z
foldr f z (Just x) = f x z
- foldl f z Nothing = z
+ foldl _ z Nothing = z
foldl f z (Just x) = f z x
instance Foldable [] where
-- | Fold over the elements of a structure,
-- associating to the right, but strictly.
foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b
-foldr' f z xs = foldl f' id xs z
+foldr' f z0 xs = foldl f' id xs z0
where f' k x z = k $! f x z
-- | Monadic fold over the elements of a structure,
-- associating to the right, i.e. from right to left.
foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
-foldrM f z xs = foldl f' return xs z
+foldrM f z0 xs = foldl f' return xs z0
where f' k x z = f x z >>= k
-- | Fold over the elements of a structure,
-- associating to the left, but strictly.
foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a
-foldl' f z xs = foldr f' id xs z
+foldl' f z0 xs = foldr f' id xs z0
where f' x k z = k $! f z x
-- | Monadic fold over the elements of a structure,
-- associating to the left, i.e. from left to right.
foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a
-foldlM f z xs = foldr f' return xs z
+foldlM f z0 xs = foldr f' return xs z0
where f' x k z = f z x >>= k
-- | Map each element of a structure to an action, evaluate
-- instances for Prelude types
instance Traversable Maybe where
- traverse f Nothing = pure Nothing
+ traverse _ Nothing = pure Nothing
traverse f (Just x) = Just <$> f x
instance Traversable [] where
hFlush stdout `catchAny` \_ -> return ()
hFlush stderr `catchAny` \_ -> return ()
-cleanUpAndExit :: Int -> IO a
-cleanUpAndExit r = do cleanUp; safeExit r
-
-- we have to use unsafeCoerce# to get the 'IO a' result type, since the
-- compiler doesn't let us declare that as the result type of a foreign export.
safeExit :: Int -> IO a
import Prelude
#ifdef __GLASGOW_HASKELL__
-import GHC.Exception
import GHC.IOBase
#endif
-- | The version of 'compilerName' with which the program was compiled
-- or is being interpreted.
compilerVersion :: Version
-compilerVersion = Version {versionBranch=[maj,min], versionTags=[]}
- where (maj,min) = compilerVersionRaw `divMod` 100
+compilerVersion = Version {versionBranch=[major, minor], versionTags=[]}
+ where (major, minor) = compilerVersionRaw `divMod` 100
-- | The operating system on which the program is running.
os :: String
import Prelude
-import Data.Typeable
-
#ifdef __HUGS__
import Hugs.Weak
#endif
#ifdef __GLASGOW_HASKELL__
import Prelude (Show(show), IO, Ord((<)), Eq((==)), Int,
- (.), otherwise, fmap)
+ otherwise, fmap)
import Data.Maybe (Maybe(..))
-import Control.Monad (Monad(..), guard)
+import Control.Monad (Monad(..))
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import Control.Exception (Exception, handleJust, throwTo, bracket)
-import Data.Dynamic (Typeable, fromDynamic)
import Data.Typeable
import Data.Unique (Unique, newUnique)
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Text.Show.Functions
projects / ghc-base.git / commitdiff