Created a ConcurrentList scheduler that adds a thread woken up with s…

…tatus BlockedInHaskell to the front of the scheduler queue. Chameneos uses this scheduler kind.

libraries/lwconc/LwConc/ConcurrentList.hs

@@ -21,6 +21,7 @@ module LwConc.ConcurrentList
 , SCont
 
 , newSched           -- IO (Sched)
+, newSchedFastUserLevelWakeup -- IO (Sched)
 , newCapability      -- IO ()
 , forkIO             -- IO () -> IO SCont
 , forkOS             -- IO () -> IO SCont
@@ -40,7 +41,7 @@ import Data.Dynamic
 
 -- The scheduler data structure has one (PVar [SCont], PVar [SCont]) for every
 -- capability.
-newtype Sched = Sched (Array Int (PVar [SCont], PVar [SCont]))
+newtype Sched = Sched (Array Int(PVar [SCont], PVar [SCont]))
 
 _INL_(yieldControlAction)
 yieldControlAction :: Sched -> PTM ()
@@ -63,25 +64,31 @@ yieldControlAction (Sched pa) = do
       switchTo x
 
 _INL_(scheduleSContAction)
-scheduleSContAction :: Sched -> SCont -> PTM ()
-scheduleSContAction (Sched pa) sc = do
+scheduleSContAction :: Sched -> Bool -> SCont -> PTM ()
+scheduleSContAction (Sched pa) fastWakeup 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 (_,backRef) = pa ! cap
-  back <- readPVar backRef
-  -- Append the given task to the tail
-  writePVar backRef $ sc:back
-  -- let (frontRef,_) = pa ! cap
-  -- front <- readPVar frontRef
-  -- -- Append the given task to the head.
-  -- writePVar frontRef $ sc:front
+  let (frontRef,backRef) = pa ! cap
+  if fastWakeup
+    then do
+      case stat of
+        SContSwitched (BlockedInHaskell _) -> do
+          front <- readPVar frontRef
+          writePVar frontRef $ sc:front
+        _ -> do
+          back <- readPVar backRef
+          writePVar backRef $ sc:back
+    else do
+      back <- readPVar backRef
+      writePVar backRef $ sc:back
 
 
-_INL_(newSched)
-newSched :: IO (Sched)
-newSched = do
+_INL_(newSchedInternal)
+newSchedInternal :: Bool -> IO (Sched)
+newSchedInternal kind = do
   -- This token will be used to spawn in a round-robin fashion on different
   -- capabilities.
   token <- newPVarIO (0::Int)
@@ -95,7 +102,7 @@ newSched = do
   -- Initialize scheduler actions
   atomically $ do {
   setYieldControlAction s $ yieldControlAction sched;
-  setScheduleSContAction s $ scheduleSContAction sched
+  setScheduleSContAction s $ scheduleSContAction sched kind
   }
   -- return scheduler
   return sched
@@ -107,6 +114,16 @@ newSched = 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

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

@@ -50,10 +50,10 @@ arrive !mpv !finish !ch = do
             case w of
                 Nobody 0
                   -> do
-                      putMVar mpv w
-                      putMVar finish (t, b)
+                      atomically $ asyncPutMVar mpv w
+                      atomically $ asyncPutMVar finish (t, b)
                 Nobody q -> do
-                    putMVar mpv $ Somebody q ch waker
+                    atomically $ asyncPutMVar mpv $ Somebody q ch waker
                     ch' <- takeMVarWithHole waker hole2
                     go (t+1) $ inc ch' b
                 Somebody q ch' waker' -> do
@@ -63,8 +63,8 @@ arrive !mpv !finish !ch = do
                     poke ch  c''
                     poke ch' c''
                     let !q' = q-1
-                    putMVar waker' ch
-                    putMVar mpv $ Nobody q'
+                    atomically $ asyncPutMVar waker' ch
+                    atomically $ asyncPutMVar mpv $ Nobody q'
                     go (t+1) $ inc ch' b
     go 0 0
 
@@ -87,7 +87,7 @@ run n cpu cs = do
       putStrLn ""
 
 initSched = do
-  newSched
+  newSchedFastUserLevelWakeup
   n <- getNumCapabilities
   replicateM_ (n-1) newCapability