From 5a6f8c43bd89097459a05b36b53b69707a3658e9 Mon Sep 17 00:00:00 2001 From: Ryan Newton Date: Thu, 27 Jun 2013 16:08:16 -0400 Subject: [PATCH] Change the name of the Direct.hs debug flag to make it more unique. Add a cabal flag for ChaseLev deques that is off by default --- HSBenchScaling | 2 +- Makefile | 2 +- monad-par/Control/Monad/Par/Scheds/Direct.hs | 30 ++++++++++++------- .../Monad/Par/Scheds/DirectInternal.hs | 14 +++++---- monad-par/monad-par.cabal | 8 +++++ monad-par/tests/ParTests.hs | 5 ++++ 6 files changed, 43 insertions(+), 18 deletions(-) diff --git a/HSBenchScaling b/HSBenchScaling index 3882808e..94539741 160000 --- a/HSBenchScaling +++ b/HSBenchScaling @@ -1 +1 @@ -Subproject commit 3882808e45075a19fa0a3d63fcd9375139f289de +Subproject commit 9453974172ee10f1a6ae9d77bb885adfae609c7d diff --git a/Makefile b/Makefile index a75bbbda..57e057eb 100644 --- a/Makefile +++ b/Makefile @@ -99,7 +99,7 @@ check-submodules: # For Jenkins testing of old GHC versions we are only interested in meta-par and monad-par: jenkins-all-versions: - ${CABAL_INSTALL} ${OUR_PKGS} Deques/AbstractDeque/ + ${CABAL_INSTALL} ${OUR_PKGS} uninstall: ghc-pkg unregister network-transport-pipes --force || echo diff --git a/monad-par/Control/Monad/Par/Scheds/Direct.hs b/monad-par/Control/Monad/Par/Scheds/Direct.hs index 010406a6..28c5e090 100644 --- a/monad-par/Control/Monad/Par/Scheds/Direct.hs +++ b/monad-par/Control/Monad/Par/Scheds/Direct.hs @@ -50,10 +50,17 @@ import Control.DeepSeq import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe (catMaybes) +import Data.Word (Word64) + import Data.Concurrent.Deque.Class (WSDeque) +#ifdef USE_CHASELEV +#warning "Note: using Chase-Lev lockfree workstealing deques..." +import Data.Concurrent.Deque.ChaseLev.DequeInstance +import Data.Concurrent.Deque.ChaseLev as R +#else import Data.Concurrent.Deque.Reference.DequeInstance import Data.Concurrent.Deque.Reference as R -import Data.Word (Word64) +#endif import qualified Control.Exception as E @@ -69,7 +76,6 @@ forkOn = forkOnIO -- Configuration Toggles -------------------------------------------------------------------------------- --- #define DEBUG -- [2012.08.30] This shows a 10X improvement on nested parfib: -- #define NESTED_SCHEDS #define PARPUTS @@ -86,7 +92,8 @@ forkOn = forkOnIO -- conditionals and trust dead-code-elimination. -------------------------------------------------------------------- -#ifdef DEBUG +#ifdef DEBUG_DIRECT +#warning "DEBUG: Activating debugging for Direct.hs" import Debug.Trace (trace) import System.Environment (getEnvironment) theEnv = unsafePerformIO $ getEnvironment @@ -381,7 +388,7 @@ runParIO userComp = do -- GHC is expensive like a forkOS thread. ---------------------------------------- -- DEBUGGING -- -#ifdef DEBUG +#ifdef DEBUG_DIRECT busyTakeMVar (" The global wait "++ show tidorig) mfin -- Final value. -- dbgTakeMVar "global waiting thread" mfin -- Final value. #else @@ -444,7 +451,7 @@ get (IVar vr) = do Full a -> return a _ -> do sch <- RD.ask -# ifdef DEBUG +# ifdef DEBUG_DIRECT sn <- io$ makeStableName vr -- Should probably do the MutVar inside... let resched = trace (" ["++ show (no sch) ++ "] - Rescheduling on unavailable ivar "++show (hashStableName sn)++"!") #else @@ -481,7 +488,7 @@ put_ (IVar vr) !content = do Empty -> (Full content, []) Full _ -> error "multiple put" Blocked ks -> (Full content, ks) -#ifdef DEBUG +#ifdef DEBUG_DIRECT when (dbglvl >= 3) $ do sn <- makeStableName vr printf " [%d] Put value %s into IVar %d. Waking up %d continuations.\n" @@ -503,7 +510,7 @@ unsafeTryPut (IVar vr) !content = do Empty -> (Full content, ([], content)) Full x -> (Full x, ([], x)) Blocked ks -> (Full content, (ks, content)) -#ifdef DEBUG +#ifdef DEBUG_DIRECT sn <- makeStableName vr printf " [%d] unsafeTryPut: value %s in IVar %d. Waking up %d continuations.\n" (no sched) (show content) (hashStableName sn) (length (fst pr)) @@ -712,7 +719,7 @@ errK = error "Error cont: this closure shouldn't be used" trivialCont :: String -> a -> ROnly () trivialCont str _ = do -#ifdef DEBUG +#ifdef DEBUG_DIRECT -- trace (str ++" trivialCont evaluated!") liftIO$ printf " !! trivialCont evaluated, msg: %s\n" str #endif @@ -729,7 +736,7 @@ trivialCont str _ = do {-# INLINE spawn1_ #-} -- Spawn a one argument function instead of a thunk. This is good for debugging if the value supports "Show". spawn1_ f x = -#ifdef DEBUG +#ifdef DEBUG_DIRECT do sn <- io$ makeStableName f sch <- RD.ask; when dbg$ io$ printf " [%d] spawning fn %d with arg %s\n" (no sch) (hashStableName sn) (show x) #endif @@ -750,7 +757,7 @@ spawn_ p = do r <- new; fork (p >>= put_ r); return r spawnP a = spawn (return a) -- In Debug mode we require that IVar contents be Show-able: -#ifdef DEBUG +#ifdef DEBUG_DIRECT put :: (Show a, NFData a) => IVar a -> a -> Par () spawn :: (Show a, NFData a) => Par a -> Par (IVar a) spawn_ :: Show a => Par a -> Par (IVar a) @@ -840,6 +847,7 @@ dbgTakeMVar msg mv = -- | For debugging purposes. This can help us figure out (but an ugly -- process of elimination) which MVar reads are leading to a "Thread -- blocked indefinitely" exception. +{- busyTakeMVar :: String -> MVar a -> IO a busyTakeMVar msg mv = try (10 * 1000 * 1000) where @@ -854,7 +862,7 @@ busyTakeMVar msg mv = try (10 * 1000 * 1000) case x of Just y -> return y Nothing -> do yield; try (n-1) - +-} -- | Fork a thread but ALSO set up an error handler that suppresses -- MVar exceptions. diff --git a/monad-par/Control/Monad/Par/Scheds/DirectInternal.hs b/monad-par/Control/Monad/Par/Scheds/DirectInternal.hs index 2c296f8c..4545b2de 100644 --- a/monad-par/Control/Monad/Par/Scheds/DirectInternal.hs +++ b/monad-par/Control/Monad/Par/Scheds/DirectInternal.hs @@ -17,14 +17,18 @@ import qualified System.Random.MWC as Random import Control.Concurrent hiding (yield) import GHC.Conc import Data.IORef +import qualified Data.Set as S +import Data.Word (Word64) import Data.Concurrent.Deque.Class (WSDeque) --- import Data.Concurrent.Deque.Reference.DequeInstance --- import Data.Concurrent.Deque.Reference as R -import Data.Concurrent.Deque.Class (WSDeque) + +#ifdef USE_CHASELEV +#warning "Note: using Chase-Lev lockfree workstealing deques..." +import Data.Concurrent.Deque.ChaseLev.DequeInstance +import Data.Concurrent.Deque.ChaseLev as R +#else import Data.Concurrent.Deque.Reference.DequeInstance import Data.Concurrent.Deque.Reference as R -import qualified Data.Set as S -import Data.Word (Word64) +#endif -- Our monad stack looks like this: -- --------- diff --git a/monad-par/monad-par.cabal b/monad-par/monad-par.cabal index 884605e2..4ab7d0e7 100644 --- a/monad-par/monad-par.cabal +++ b/monad-par/monad-par.cabal @@ -71,6 +71,10 @@ extra-source-files: tests/hs_cassandra_microbench.hs tests/hs_cassandra_microbench2.hs +Flag chaselev + Description: Use Chase-Lev Deques for higher-perf work-stealing. + Default: False + Library Source-repository head type: git @@ -106,6 +110,10 @@ Library , parallel >= 3.1 , mtl >= 2.0.1.0 + if flag(chaselev) + cpp-options: -DUSE_CHASELEV + build-depends: chaselev-deque + ghc-options: -O2 Other-modules: ------------------------------------------------------------ diff --git a/monad-par/tests/ParTests.hs b/monad-par/tests/ParTests.hs index 3c32ab08..af046903 100644 --- a/monad-par/tests/ParTests.hs +++ b/monad-par/tests/ParTests.hs @@ -98,7 +98,12 @@ disabled_case_multiput = assertException ["multiple put"] $ -- both :: Par a -> Par a -> Par a -- both a b = Par $ \c -> Fork (runCont a c) (runCont b c) + +-- | A reduction test. case_test_pmrr1 :: Assertion +-- Saw a failure here using Direct: +-- http://tester-lin.soic.indiana.edu:8080/job/HackageReleased_monad-par/GHC_VERS=7.0.4,label=tank.cs.indiana.edu/40/console +-- Exception inside child thread "(worker 0 of originator ThreadId 5)", ThreadId 10: thread blocked indefinitely in an MVar operation case_test_pmrr1 = par 5050 $ parMapReduceRangeThresh 1 (InclusiveRange 1 100) (return) (return `bincomp` (+)) 0