Simplifying Chameneos redux

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

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,70 +84,68 @@ 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
       Empty ts -> 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

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)

tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs

@@ -41,30 +41,31 @@ 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
                     c' <- peek ch'
                     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