module Control.Monad.Par.Meta.Resources.SMP (
mkResource
, mkResourceOn
, defaultStartup
, defaultWorkSearch
, startupForCaps
, wsForCaps
) where
import Control.Monad
import Data.Concurrent.Deque.Reference as R
import Data.List (nub)
import qualified Data.Vector as V
import qualified Data.ByteString.Char8 as BS
import System.Environment (getEnvironment)
import System.IO.Unsafe
import System.Random.MWC
import Text.Printf
import Control.Monad.Par.Meta
import Control.Monad.Par.Meta.HotVar.IORef
import Control.Monad.Par.Meta.Resources.Debugging (dbgTaggedMsg)
#if __GLASGOW_HASKELL__ >= 702
import Control.Concurrent (getNumCapabilities)
#else
import GHC.Conc (numCapabilities)
getNumCapabilities = return numCapabilities
#endif
mkResource :: Int
-> Resource
mkResource tries = Resource defaultStartup (defaultWorkSearch tries)
mkResourceOn :: [Int]
-> Int
-> Resource
mkResourceOn caps tries = Resource (startupForCaps caps) (wsForCaps caps tries)
getCaps :: [Int]
getCaps = unsafePerformIO $ do
env <- getEnvironment
case lookup "SMP_CAPS" env of
Just cs -> do
dbgTaggedMsg 2 $ BS.pack $ printf "[SMP] initialized with capability list %s\n"
(show ((read cs) :: [Int]))
return $ read cs
Nothing -> do
n <- getNumCapabilities
dbgTaggedMsg 2 $ BS.pack $ printf "[SMP] initialized with capability list %s\n"
(show ([0..n1] :: [Int]))
return [0..n1]
defaultStartup :: Startup
defaultStartup = startupForCaps getCaps
startupForCaps :: [Int] -> Startup
startupForCaps caps = St st
where st ws _ = do
dbgTaggedMsg 2 $ BS.pack $ printf "spawning worker threads for shared memory on caps:\n"
dbgTaggedMsg 2 $ BS.pack $ printf "\t%s\n" (show caps)
let caps' = nub caps
forM_ caps' $ \n ->
spawnWorkerOnCPU ws n >> return ()
randModN :: Int -> HotVar GenIO -> IO Int
randModN caps rngRef = uniformR (0, caps1) =<< readHotVar rngRef
defaultWorkSearch :: Int -> WorkSearch
defaultWorkSearch = wsForCaps getCaps
wsForCaps :: [Int] -> Int -> WorkSearch
wsForCaps caps triesPerCap = WS ws
where
numCaps = length caps
numTries = numCaps * triesPerCap
capVec = V.fromList caps
ws Sched { no, rng } schedsRef = do
scheds <- readHotVar schedsRef
let
getNext :: IO Int
getNext = randModN numCaps rng
loop :: Int -> Int -> IO (Maybe (Par ()))
loop 0 _ = return Nothing
loop n i | capVec V.! i == no = loop (n1) =<< getNext
| otherwise =
let target = capVec V.! i in
case scheds V.! target of
Nothing -> do
dbgTaggedMsg 2 $ BS.pack $
printf "WARNING: no Sched for cap %d during steal\n" target
loop (n1) =<< getNext
Just Sched { workpool = stealee } -> do
mtask <- R.tryPopR stealee
case mtask of
Nothing -> loop (n1) =<< getNext
jtask -> return jtask
loop numTries =<< getNext