Added ConcurrentList specialized for chameneos redux

tests/Benchmarks/ChameneosRedux/ConcurrentList.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  LwConc.Schedulers.ConcurrentList
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (concurrency)
+--
+-- A concurrent round-robin scheduler.
+--
+-----------------------------------------------------------------------------
+
+
+module ConcurrentList
+(
+  Sched
+, SCont
+
+, newSched           -- IO (Sched)
+, newCapability      -- IO ()
+, forkIO             -- IO () -> IO SCont
+, forkOS             -- IO () -> IO SCont
+, forkOn             -- Int -> IO () -> IO SCont
+, yield              -- IO ()
+
+, throwTo            -- Exception e => SCont -> e -> IO ()
+, BlockedIndefinitelyOnConcDS(..)
+, blockedIndefinitelyOnConcDS
+) where
+
+import LwConc.Substrate
+import Data.Array.IArray
+import Data.Dynamic
+
+#include "profile.h"
+
+-- The scheduler data structure has one (PVar [SCont], PVar [SCont]) for every
+-- capability.
+newtype Sched = Sched (Array Int (PVar [SCont], PVar [SCont]))
+
+_INL_(yieldControlAction)
+yieldControlAction :: Sched -> SCont -> PTM ()
+yieldControlAction !(Sched pa) !sc = do
+  stat <- getSContStatus sc
+  -- Fetch current capability's scheduler
+  cc <- getCurrentCapability
+  let !(frontRef, backRef)= pa ! cc
+  front <- readPVar frontRef
+  case front of
+    [] -> do
+      back <- readPVar backRef
+      case reverse back of
+        [] -> sleepCapability
+        x:tl -> do
+          writePVar frontRef tl
+          writePVar backRef []
+          switchTo x
+    x:tl -> do
+      writePVar frontRef $ tl
+      switchTo x
+
+_INL_(scheduleSContAction)
+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
+  case stat of
+    SContSwitched (BlockedInHaskell _) -> do
+      !front <- readPVar frontRef
+      writePVar frontRef $! sc:front
+    _ -> do
+      !back <- readPVar backRef
+      writePVar backRef $! sc:back
+
+_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)
+  -- Save the token in the Thread-local State (TLS)
+  s <- getSContIO
+  setSLS s $ toDyn token
+  -- Create the scheduler data structure
+  nc <- getNumCapabilities
+  rl <- createPVarList nc []
+  let sched = Sched (listArray (0, nc-1) rl)
+  -- Initialize scheduler actions
+  atomically $ do {
+  setYieldControlAction s $ yieldControlAction sched;
+  setScheduleSContAction s $ scheduleSContAction sched
+  }
+  -- return scheduler
+  return sched
+  where
+    createPVarList 0 l = return l
+    createPVarList n l = do {
+      frontRef <- newPVarIO [];
+      backRef <- newPVarIO [];
+      createPVarList (n-1) $ (frontRef,backRef):l
+    }
+
+_INL_(newCapability)
+newCapability :: IO ()
+newCapability = do
+ -- Initial task body
+ let initTask = atomically $ do {
+  s <- getSCont;
+  yca <- getYieldControlAction;
+  setSContSwitchReason s Completed;
+  yca
+ }
+ -- Create and initialize new task
+ s <- newSCont initTask
+ atomically $ do
+   mySC <- getSCont
+   yca <- getYieldControlActionSCont mySC
+   setYieldControlAction s yca
+   ssa <- getScheduleSContActionSCont mySC
+   setScheduleSContAction s ssa
+ scheduleSContOnFreeCap s
+
+data SContKind = Bound | Unbound
+
+_INL_(fork)
+fork :: IO () -> Maybe Int -> SContKind -> IO SCont
+fork task on kind = do
+  currentSC <- getSContIO
+  nc <- getNumCapabilities
+  -- epilogue: Switch to next thread after completion
+  let epilogue = atomically $ do {
+    sc <- getSCont;
+    setSContSwitchReason sc Completed;
+    switchToNext <- getYieldControlAction;
+    switchToNext
+  }
+  let makeSCont = case kind of
+                    Bound -> newBoundSCont
+                    Unbound -> newSCont
+  newSC <- makeSCont (task >> epilogue)
+  -- Initialize TLS
+  tls <- atomically $ getSLS currentSC
+  setSLS newSC $ tls
+  let token::PVar Int = case fromDynamic tls of
+                          Nothing -> error "TLS"
+                          Just x -> x
+  t <- atomically $ do
+    mySC <- getSCont
+    -- Initialize scheduler actions
+    yca <- getYieldControlActionSCont mySC
+    setYieldControlAction newSC yca
+    ssa <- getScheduleSContActionSCont mySC
+    setScheduleSContAction newSC ssa
+    t <- readPVar token
+    writePVar token $ (t+1) `mod` nc
+    return t
+  -- Set SCont Affinity
+  case on of
+    Nothing -> setSContCapability newSC t
+    Just t' -> setSContCapability newSC $ t' `mod` nc
+  -- Schedule new Scont
+  atomically $ do
+    ssa <- getScheduleSContActionSCont newSC
+    ssa newSC
+  return newSC
+
+_INL_(forkIO)
+forkIO :: IO () -> IO SCont
+forkIO task = fork task Nothing Unbound
+
+_INL_(forkOS)
+forkOS :: IO () -> IO SCont
+forkOS task = fork task Nothing Bound
+
+_INL_(forkOn)
+forkOn :: Int -> IO () -> IO SCont
+forkOn on task = fork task (Just on) Unbound
+
+
+_INL_(yield)
+yield :: IO ()
+yield = atomically $ do
+  -- Update SCont status to Yielded
+  s <- getSCont
+  setSContSwitchReason s Yielded
+  -- Append current SCont to scheduler
+  append <- getScheduleSContAction
+  append
+  -- Switch to next SCont from Scheduler
+  switchToNext <- getYieldControlAction
+  switchToNext

tests/Benchmarks/ChameneosRedux/FairShare.hs

@@ -11,7 +11,7 @@
 -- Stability   :  experimental
 -- Portability :  non-portable (concurrency)
 --
--- A concurrent round-robin scheduler.
+-- A Fair-share scheduler.
 --
 -----------------------------------------------------------------------------
 
@@ -122,8 +122,6 @@ enque !(Sched pa) !sc = do
       let State (_,_,acc) = fromJust $ fromDynamic sls
       readPVar acc
 
-
-
 -------------------------------------------------------------------------------
 -- Scheduler Activations
 -------------------------------------------------------------------------------

tests/Benchmarks/ChameneosRedux/Makefile

@@ -4,7 +4,7 @@ include ../../config.mk
 
 TOP := ../../../
 EXTRA_LIBS=/scratch/chandras/install
-GHC_OPTS_EXTRA=-threaded -XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -debug
+GHC_OPTS_EXTRA=-threaded -XDeriveDataTypeable -XBangPatterns -XCPP -XGeneralizedNewtypeDeriving -funbox-strict-fields -ipqueue-1.2.1 -O2
 
 PROFILE_FLAGS := -DPROFILE_ENABLED -prof -fprof-auto -auto -auto-all
 

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

@@ -5,18 +5,19 @@
    Modified by Péter Diviánszky, 19 May 2010
    Modified by Louis Wasserman, 14 June 2010
 
-	 Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS
-	 -N<number of cores>.
+   Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS
+   -N<number of cores>.
 
-	 XXX KC: The user of withArrayLen is unsafe. We obtain pointers to
-	 addresses inside the array but not the byte array itself. This is a
-	 recipie for disaster. See
-	 http://hackage.haskell.org/trac/ghc/ticket/7012. Solution?
+   XXX KC: The user of withArrayLen is unsafe. We obtain pointers to
+   addresses inside the array but not the byte array itself. This is a
+   recipie for disaster. See
+   http://hackage.haskell.org/trac/ghc/ticket/7012. Solution?
    -}
 
 import LwConc.Substrate
 import FairShare
 -- import LwConc.RunQueue
+-- import ConcurrentList
 import MVarList
 import Control.Monad
 import Data.Char