diff --git a/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs b/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs index d67c74b6945d..a717e415eff9 100644 --- a/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs +++ b/tests/Benchmarks/ChameneosRedux/ConcurrentList.hs @@ -21,7 +21,6 @@ module ConcurrentList , SCont , newSched -- IO (Sched) -, newSchedFastUserLevelWakeup -- IO (Sched) , newCapability -- IO () , forkIO -- IO () -> IO SCont , forkOS -- IO () -> IO SCont @@ -48,7 +47,7 @@ yieldControlAction :: Sched -> PTM () yieldControlAction (Sched pa) = do -- Fetch current capability's scheduler cc <- getCurrentCapability - let (frontRef, backRef) = pa ! cc + let !(frontRef, backRef) = pa ! cc front <- readPVar frontRef case front of [] -> do @@ -64,14 +63,14 @@ yieldControlAction (Sched pa) = do switchTo x _INL_(scheduleSContAction) -scheduleSContAction :: Sched -> Bool -> SCont -> PTM () -scheduleSContAction (Sched pa) fastWakeup sc = do +scheduleSContAction :: Sched -> SCont -> PTM () +scheduleSContAction (Sched pa) sc = do stat <- getSContStatus sc -- Since we are making the given scont runnable, update its status to Yielded. setSContSwitchReason sc Yielded -- Fetch the given SCont's scheduler. cap <- getSContCapability sc - let (frontRef,backRef) = pa ! cap + let !(frontRef,backRef) = pa ! cap case stat of SContSwitched (BlockedInHaskell _) -> do front <- readPVar frontRef @@ -81,9 +80,9 @@ scheduleSContAction (Sched pa) fastWakeup sc = do writePVar backRef $ sc:back -_INL_(newSchedInternal) -newSchedInternal :: Bool -> IO (Sched) -newSchedInternal kind = do +_INL_(newSched) +newSched:: IO (Sched) +newSched = do -- This token will be used to spawn in a round-robin fashion on different -- capabilities. token <- newPVarIO (0::Int) @@ -93,11 +92,11 @@ newSchedInternal kind = do -- Create the scheduler data structure nc <- getNumCapabilities rl <- createPVarList nc [] - let sched = Sched (listArray (0, nc-1) rl) + let !sched = Sched (listArray (0, nc-1) rl) -- Initialize scheduler actions atomically $ do { setYieldControlAction s $ yieldControlAction sched; - setScheduleSContAction s $ scheduleSContAction sched kind + setScheduleSContAction s $ scheduleSContAction sched } -- return scheduler return sched @@ -109,21 +108,11 @@ newSchedInternal kind = do createPVarList (n-1) $ (frontRef,backRef):l } -_INL_(newSched) -newSched :: IO (Sched) -newSched = do - newSchedInternal False - -_INL_(newSchedFastUserLevelWakeup) -newSchedFastUserLevelWakeup :: IO (Sched) -newSchedFastUserLevelWakeup = do - newSchedInternal True - _INL_(newCapability) newCapability :: IO () newCapability = do -- Initial task body - let initTask = atomically $ do { + let !initTask = atomically $ do { s <- getSCont; yca <- getYieldControlAction; setSContSwitchReason s Completed; @@ -147,13 +136,13 @@ fork task on kind = do currentSC <- getSContIO nc <- getNumCapabilities -- epilogue: Switch to next thread after completion - let epilogue = atomically $ do { + let !epilogue = atomically $ do { sc <- getSCont; setSContSwitchReason sc Completed; switchToNext <- getYieldControlAction; switchToNext } - let makeSCont = case kind of + let !makeSCont = case kind of Bound -> newBoundSCont Unbound -> newSCont newSC <- makeSCont (task >> epilogue) @@ -203,7 +192,7 @@ yield = atomically $ do s <- getSCont -- Append current SCont to scheduler ssa <- getScheduleSContAction - let append = ssa s + let !append = ssa s append -- Switch to next SCont from Scheduler switchToNext <- getYieldControlAction diff --git a/tests/Benchmarks/ChameneosRedux/MVarList.hs b/tests/Benchmarks/ChameneosRedux/MVarList.hs index a1166c04aa08..94909496492a 100644 --- a/tests/Benchmarks/ChameneosRedux/MVarList.hs +++ b/tests/Benchmarks/ChameneosRedux/MVarList.hs @@ -39,38 +39,40 @@ import GHC.IORef #define _INL_(x) {-# INLINE x #-} -data Queue a = Queue ![a] +data Queue a = Queue ![a] ![a] _INL_(emptyQueue) emptyQueue :: Queue a -emptyQueue = Queue [] +emptyQueue = Queue [] [] _INL_(enque) enque :: Queue a -> a -> Queue a -enque (Queue front) e = Queue $ e:front +enque (Queue front back) e = Queue front $ e:back _INL_(deque) deque :: Queue a -> (Queue a, Maybe a) -deque (Queue front) = +deque (Queue front back) = case front of - [] -> (emptyQueue, Nothing) - x:tl -> (Queue tl, Just x) + [] -> (case reverse back of + [] -> (emptyQueue, Nothing) + x:tl -> (Queue tl [], Just x)) + x:tl -> (Queue tl back, Just x) newtype MVar a = MVar (PVar (MVPState a)) deriving (Eq) -data MVPState a = Full a (Queue (a, PTM())) +data MVPState a = Full !a (Queue (a, PTM())) | Empty (Queue (IORef a, PTM())) _INL_(newMVar) newMVar :: a -> IO (MVar a) newMVar x = do - ref <- newPVarIO $ Full x emptyQueue + ref <- newPVarIO $! Full x emptyQueue return $ MVar ref _INL_(newEmptyMVar) newEmptyMVar :: IO (MVar a) newEmptyMVar = do - ref <- newPVarIO $ Empty emptyQueue + ref <- newPVarIO $! Empty emptyQueue return $ MVar ref @@ -82,45 +84,44 @@ asyncPutMVar (MVar ref) x = do Empty ts -> case deque ts of (_, Nothing) -> do - writePVar ref $ Full x emptyQueue + writePVar ref $! Full x emptyQueue (ts', Just (hole, wakeup)) -> do - unsafeIOToPTM $ writeIORef hole x - writePVar ref $ Empty ts' + unsafeIOToPTM $! writeIORef hole x + writePVar ref $! Empty ts' wakeup Full x' ts -> do writePVar ref $ Full x' $ enque ts (x, return ()) _INL_(putMVarPTM) -putMVarPTM :: MVar a -> a -> PTM () -putMVarPTM (MVar ref) x = do +putMVarPTM :: MVar a -> a -> ResumeToken -> PTM () +putMVarPTM (MVar ref) x token = do st <- readPVar ref case st of Empty ts -> do case deque ts of (_, Nothing) -> do - writePVar ref $ Full x emptyQueue + writePVar ref $! Full x emptyQueue (ts', Just (hole, wakeup)) -> do - unsafeIOToPTM $ writeIORef hole x - writePVar ref $ Empty ts' + unsafeIOToPTM $! writeIORef hole x + writePVar ref $! Empty ts' wakeup Full x' ts -> do blockAct <- getYieldControlAction sc <- getSCont unblockAct <- getScheduleSContAction - token <- newResumeToken - let wakeup = unblockAct sc - writePVar ref $ Full x' $ enque ts (x, wakeup) - setSContSwitchReason sc $ BlockedInHaskell token + let !wakeup = unblockAct sc + writePVar ref $! Full x' $! enque ts (x, wakeup) + setSContSwitchReason sc $! BlockedInHaskell token blockAct _INL_(putMVar) -putMVar :: MVar a -> a -> IO () -putMVar mv x = atomically $ putMVarPTM mv x +putMVar :: MVar a -> a -> ResumeToken -> IO () +putMVar mv x token = atomically $ putMVarPTM mv x token _INL_(takeMVarWithHole) -takeMVarWithHole :: MVar a -> IORef a -> IO a -takeMVarWithHole (MVar ref) hole = do +takeMVarWithHole :: MVar a -> IORef a -> ResumeToken -> IO a +takeMVarWithHole (MVar ref) hole token = do atomically $ do st <- readPVar ref case st of @@ -128,24 +129,23 @@ takeMVarWithHole (MVar ref) hole = do blockAct <- getYieldControlAction sc <- getSCont unblockAct <- getScheduleSContAction - token <- newResumeToken - let wakeup = unblockAct sc - writePVar ref $ Empty $ enque ts (hole, wakeup) - setSContSwitchReason sc $ BlockedInHaskell token + let !wakeup = unblockAct sc + writePVar ref $! Empty $! enque ts (hole, wakeup) + setSContSwitchReason sc $! BlockedInHaskell token blockAct Full x ts -> do case deque ts of (_, Nothing) -> do - writePVar ref $ Empty emptyQueue - unsafeIOToPTM $ writeIORef hole x + writePVar ref $! Empty emptyQueue + unsafeIOToPTM $! writeIORef hole x (ts', Just (x', wakeup)) -> do - writePVar ref $ Full x' ts' - unsafeIOToPTM $ writeIORef hole x + writePVar ref $! Full x' ts' + unsafeIOToPTM $! writeIORef hole x wakeup readIORef hole _INL_(takeMVar) -takeMVar :: MVar a -> IO a -takeMVar m = do +takeMVar :: MVar a -> ResumeToken -> IO a +takeMVar m token = do hole <- newIORef undefined - takeMVarWithHole m hole + takeMVarWithHole m hole token diff --git a/tests/Benchmarks/ChameneosRedux/Makefile b/tests/Benchmarks/ChameneosRedux/Makefile index e1c18ed4bed6..624f6cd8f9b1 100644 --- a/tests/Benchmarks/ChameneosRedux/Makefile +++ b/tests/Benchmarks/ChameneosRedux/Makefile @@ -3,6 +3,6 @@ TARGET := chameneos-redux-vanilla.bin chameneos-redux-lwc.bin include ../../config.mk TOP := ../../../ -GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields +GHC_OPTS_EXTRA=-O2 -threaded -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -optc-O3 all: $(TARGET) diff --git a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs index ff06c5d30345..64338974e223 100644 --- a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs +++ b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs @@ -41,20 +41,21 @@ data MP = Nobody !Int | Somebody !Int !Chameneous !(MVar Chameneous) arrive :: MVar MP -> MVar (Int, Int) -> Chameneous -> IO () arrive !mpv !finish !ch = do - waker <- newEmptyMVar - hole1 <- newIORef undefined - hole2 <- newIORef undefined + !waker <- newEmptyMVar + !hole1 <- newIORef undefined + !hole2 <- newIORef undefined + !tk <- atomically $ newResumeToken let inc x = (fromEnum (ch == x) +) go !t !b = do - w <- takeMVarWithHole mpv hole1 + w <- takeMVarWithHole mpv hole1 tk case w of Nobody 0 -> do - putMVar mpv w - putMVar finish (t, b) + putMVar mpv w tk + putMVar finish (t, b) tk Nobody q -> do - putMVar mpv $ Somebody q ch waker - ch' <- takeMVarWithHole waker hole2 + putMVar mpv (Somebody q ch waker) tk + ch' <- takeMVarWithHole waker hole2 tk go (t+1) $ inc ch' b Somebody q ch' waker' -> do c <- peek ch @@ -62,9 +63,9 @@ arrive !mpv !finish !ch = do let !c'' = complement c c' poke ch c'' poke ch' c'' - putMVar waker' ch let !q' = q-1 - putMVar mpv $ Nobody q' + putMVar waker' ch tk + putMVar mpv (Nobody q') tk go (t+1) $ inc ch' b go 0 0 @@ -77,17 +78,18 @@ run n cpu cs = do fs <- replicateM (length cs) newEmptyMVar mpv <- newMVar (Nobody n) hole <- newIORef undefined + tk <- atomically $ newResumeToken withArrayLen cs $ \ n cols -> do zipWithM_ ((forkOn cpu .) . arrive mpv) fs (take n (iterate (`advancePtr` 1) cols)) return $ do putStrLn . map toLower . unwords . ([]:) . map show $ cs - ns <- mapM (\m -> takeMVarWithHole m hole) fs + ns <- mapM (\m -> takeMVarWithHole m hole tk) fs putStr . map toLower . unlines $ [unwords [show n, showN b] | (n, b) <- ns] putStrLn . (" "++) . showN . sum . map fst $ ns putStrLn "" initSched = do - newSchedFastUserLevelWakeup + newSched n <- getNumCapabilities replicateM_ (n-1) newCapability