Repository : http://darcs.haskell.org/ghc.git/
On branch : ghc-lwc2 https://github.com/ghc/ghc/commit/e80c0c817fcd8b4b3fcdc6462519683fb8fb1fc2 >--------------------------------------------------------------- commit e80c0c817fcd8b4b3fcdc6462519683fb8fb1fc2 Author: KC Sivaramakrishnan <[email protected]> Date: Mon May 13 16:25:04 2013 -0400 FairShare scheduling can either be on concrete time or counts >--------------------------------------------------------------- rts/PrimOps.cmm | 1 + rts/Schedule.c | 6 ++++++ tests/Benchmarks/ChameneosRedux/FairShare.hs | 18 +++++++++++++++++- tests/Benchmarks/ChameneosRedux/Makefile | 2 +- tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs | 4 ++-- 5 files changed, 27 insertions(+), 4 deletions(-) diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4ebb79a..fbfa669 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -881,6 +881,7 @@ stg_newSContzh ( gcptr closure ) RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr"); StgTSO_why_blocked (threadid) = Yielded::I16; + Capability_context_switch(MyCapability()) = 1 :: CInt; return (threadid); } diff --git a/rts/Schedule.c b/rts/Schedule.c index eb57408..8bb1c7f 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -339,6 +339,12 @@ more_upcalls: */ if (!emptyUpcallQueue(cap)) { t = prepareUpcallThread (cap, t); + //If there are other runnable threads, append the upcall thread to + //the scheduler. + if (!emptyRunQueue (cap)) { + appendToRunQueue (cap, t); + continue; + } } else { t = restoreCurrentThreadIfNecessary (cap, t); diff --git a/tests/Benchmarks/ChameneosRedux/FairShare.hs b/tests/Benchmarks/ChameneosRedux/FairShare.hs index bf47555..2863f6f 100644 --- a/tests/Benchmarks/ChameneosRedux/FairShare.hs +++ b/tests/Benchmarks/ChameneosRedux/FairShare.hs @@ -43,6 +43,7 @@ import qualified Data.PQueue.Min as PQ #include "profile.h" + newtype State = State (PVar Int, PVar ClockTime, PVar Int) deriving (Typeable) @@ -50,6 +51,12 @@ newtype State = State (PVar Int, PVar ClockTime, PVar Int) -- SCont Accounting ------------------------------------------------------------------------------- +#define ACCOUNT_COUNT + +#ifdef ACCOUNT_COUNT +#undef ACCOUNT_TIME +#endif + -- |Returns the time difference in microseconds (potentially returning maxBound -- <= the real difference) timeDiffToMicroSec :: TimeDiff -> Int @@ -64,20 +71,29 @@ timeDiffToMicroSec (TimeDiff _ _ _ _ _ sec picosec) = _INL_(startClock) startClock :: SCont -> PTM () startClock sc = do +#ifdef ACCOUNT_TIME sls <- getSLS sc let State (_,st,_) = fromJust $ fromDynamic sls time <- unsafeIOToPTM $ getClockTime writePVar st $ time +#else + return () +#endif _INL_(stopClock) stopClock :: SCont -> PTM () stopClock sc = do sls <- getSLS sc let State (_,st,acc) = fromJust $ fromDynamic sls +#ifdef ACCOUNT_TIME startTime <- readPVar st endTime <- unsafeIOToPTM $ getClockTime + let diff = timeDiffToMicroSec (diffClockTimes endTime startTime) +#else + let diff = 1 +#endif sum <- readPVar acc - let newSum = sum + timeDiffToMicroSec (diffClockTimes endTime startTime) + let newSum = sum + diff writePVar acc newSum where diff --git a/tests/Benchmarks/ChameneosRedux/Makefile b/tests/Benchmarks/ChameneosRedux/Makefile index 29d8ca2..0fd7851 100644 --- a/tests/Benchmarks/ChameneosRedux/Makefile +++ b/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 -O2 -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 diff --git a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs index 6c3792d..7bcf25d 100644 --- a/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs +++ b/tests/Benchmarks/ChameneosRedux/chameneos-redux-lwc.hs @@ -15,9 +15,9 @@ -} import LwConc.Substrate --- import FairShare +import FairShare -- import LwConc.RunQueue -import ConcurrentList +-- import ConcurrentList import MVarList import Control.Monad import Data.Char _______________________________________________ ghc-commits mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-commits
