X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc%2FSync.lhs;h=370bfd91352bba9e88a65c177fbe93a2eb659be9;hb=6685444335fe57d5d86b61965989e45f34fddf0e;hp=9b7415da2c85fc8b6935351f01ccada8291b084a;hpb=4cd3a6475de0ef9a9d1bd0b6e8cf3fb336b80a43;p=ghc-base.git diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs index 9b7415d..370bfd9 100644 --- a/GHC/Conc/Sync.lhs +++ b/GHC/Conc/Sync.lhs @@ -1,7 +1,16 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , MagicHash + , UnboxedTuples + , UnliftedFFITypes + , ForeignFunctionInterface + , DeriveDataTypeable + #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc.Sync @@ -33,6 +42,7 @@ module GHC.Conc.Sync , forkOnIO -- :: Int -> IO a -> IO ThreadId , forkOnIOUnmasked , numCapabilities -- :: Int + , getNumCapabilities -- :: IO Int , numSparks -- :: IO Int , childHandler -- :: Exception -> IO () , myThreadId -- :: IO ThreadId @@ -46,13 +56,15 @@ module GHC.Conc.Sync , ThreadStatus(..), BlockReason(..) , threadStatus -- :: ThreadId -> IO ThreadStatus + , threadCapability -- * 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 + , throwSTM -- :: Exception e => e -> STM a + , catchSTM -- :: Exception e => STM a -> (e -> STM a) -> STM a , alwaysSucceeds -- :: STM a -> STM () , always -- :: STM Bool -> STM () , TVar(..) @@ -96,7 +108,6 @@ import GHC.IO.Exception import GHC.Exception import GHC.IORef import GHC.MVar -import GHC.Num ( Num(..) ) import GHC.Real ( fromIntegral ) import GHC.Pack ( packCString# ) import GHC.Show ( Show(..), showString ) @@ -198,9 +209,7 @@ can migrate between CPUs according to the scheduling policy). know in advance how best to distribute the threads. The `Int` argument specifies the CPU number; it is interpreted modulo -'numCapabilities' (note that it actually specifies a capability number -rather than a CPU number, but to a first approximation the two are -equivalent). +the value returned by 'getNumCapabilities'. -} forkOnIO :: Int -> IO () -> IO ThreadId forkOnIO (I# cpu) action = IO $ \ s -> @@ -217,10 +226,35 @@ forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io) -- Haskell threads that can run truly simultaneously at any given -- time, and is typically set to the number of physical CPU cores on -- the machine. +-- +-- Strictly speaking it is better to use 'getNumCapabilities', because +-- the number of capabilities might vary at runtime. +-- numCapabilities :: Int -numCapabilities = unsafePerformIO $ do - n <- peek n_capabilities - return (fromIntegral n) +numCapabilities = unsafePerformIO $ getNumCapabilities + +{- | +Returns the number of Haskell threads that can run truly +simultaneously (on separate physical processors) at any given time. +The CPU number passed to `forkOnIO` is interpreted modulo this +value. + +An implementation in which Haskell threads are mapped directly to +OS threads might return the number of physical processor cores in +the machine, and 'forkOnIO' would be implemented using the OS's +affinity facilities. An implementation that schedules Haskell +threads onto a smaller number of OS threads (like GHC) would return +the number of such OS threads that can be running simultaneously. + +GHC notes: this returns the number passed as the argument to the +@+RTS -N@ flag. In current implementations, the value is fixed +when the program starts and never changes, but it is possible that +in the future the number of capabilities might vary at runtime. +-} +getNumCapabilities :: IO Int +getNumCapabilities = do + n <- peek n_capabilities + return (fromIntegral n) -- | Returns the number of sparks currently in the local spark pool numSparks :: IO Int @@ -393,19 +427,28 @@ data ThreadStatus threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ \s -> case threadStatus# t s of - (# s', stat #) -> (# s', mk_stat (I# stat) #) + (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #) where -- NB. keep these in sync with includes/Constants.h mk_stat 0 = ThreadRunning mk_stat 1 = ThreadBlocked BlockedOnMVar mk_stat 2 = ThreadBlocked BlockedOnBlackHole - mk_stat 3 = ThreadBlocked BlockedOnException - mk_stat 7 = ThreadBlocked BlockedOnSTM + mk_stat 6 = ThreadBlocked BlockedOnSTM + mk_stat 10 = ThreadBlocked BlockedOnForeignCall mk_stat 11 = ThreadBlocked BlockedOnForeignCall - mk_stat 12 = ThreadBlocked BlockedOnForeignCall + mk_stat 12 = ThreadBlocked BlockedOnException mk_stat 16 = ThreadFinished mk_stat 17 = ThreadDied mk_stat _ = ThreadBlocked BlockedOnOther + +-- | returns the number of the capability on which the thread is currently +-- running, and a boolean indicating whether the thread is locked to +-- that capability or not. A thread is locked to a capability if it +-- was created with @forkOnIO@. +threadCapability :: ThreadId -> IO (Int, Bool) +threadCapability (ThreadId t) = IO $ \s -> + case threadStatus# t s of + (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #) \end{code} @@ -509,9 +552,34 @@ retry = STM $ \s# -> retry# s# orElse :: STM a -> STM a -> STM a orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s +-- | A variant of 'throw' that can only be used within the 'STM' monad. +-- +-- Throwing an exception in @STM@ aborts the transaction and propagates the +-- exception. +-- +-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwSTM e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwSTM' will only cause +-- an exception to be raised when it is used within the 'STM' monad. +-- The 'throwSTM' variant should be used in preference to 'throw' to +-- raise an exception within the 'STM' monad because it guarantees +-- ordering with respect to other 'STM' operations, whereas 'throw' +-- does not. +throwSTM :: Exception e => e -> STM a +throwSTM e = STM $ raiseIO# (toException e) + -- |Exception handling within STM actions. -catchSTM :: STM a -> (SomeException -> STM a) -> STM a -catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s +catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a +catchSTM (STM m) handler = STM $ catchSTM# m handler' + where + handler' e = case fromException e of + Just e' -> unSTM (handler e') + Nothing -> raiseIO# e -- | Low-level primitive on which always and alwaysSucceeds are built. -- checkInv differs form these in that (i) the invariant is not