haskell-cnc 0.1.2 → 0.1.3

raw patch · 23 files changed

+558/−153 lines, 23 filesdep +HSHdep +MissingHdep −QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HSH, MissingH

Dependencies removed: QuickCheck

API changes (from Hackage documentation)

Files

• Intel/Cnc.Header.hs +108/−37
• Intel/Cnc.hs +3/−0
• Intel/Cnc3.hs +41/−2
• Intel/Cnc5.hs +4/−1
• Intel/Cnc6.hs +3/−0
• Intel/Cnc8.hs +12/−4
• Intel/CncPure.hs +12/−1
• Intel/CncUtil.hs +104/−49
• Intel/shared_5_6.hs +5/−6
• Makefile +10/−1
• default_opt_settings.sh +8/−2
• examples/embarrassingly_par.hs +1/−2
• examples/fib.hs +3/−4
• examples/mandel.hs +16/−14
• examples/mandel_opt.hs +110/−0
• examples/nbody.hs +0/−1
• haskell-cnc.cabal +16/−9
• haskell_cnc.h +1/−1
• ntimes +3/−1
• runAllTests.hs +15/−6
• run_all_examples.sh +33/−11
• runcnc +1/−1
• timeout.hs +49/−0

@@ -2,6 +2,9 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses   #-}@@ -35,18 +38,20 @@ {-|   This module implements the Intel Concurrent Collections (CnC) programming model.   The variations of this module ("Intel.Cnc3", "Intel.Cnc5", "Intel.Cnc6", and "Intel.Cnc8")-  each implement the same programming model using different schedulers.+  each implement the same programming model using different runtime schedulers.   All of them internally use the IO monad but expose a pure interface.   (The module "Intel.CncPure" is an alternative implementation that   exposes the same interface as this module but is internally pure.)     CnC is a data-flow like deterministic parallel programming model.-  To use it, one constructs a /CnC graph/ of computation steps. -  Edges in the graph are control and data relationships, which are +  To use it, one constructs a /CnC graph/ of computation steps.  +  Steps are arbitrary Haskell functions (which may themselves expose+  parallelism through 'GHC.Conc.par').+  Edges in the graph are control and data relationships,    implemented by  /tag/ and /item/ collections respectively. -  A brief introduction to CnC using this module can be found at <http://software.intel.com/foobar>.+  A brief introduction to CnC using this module can be found at <http://software.intel.com/en-us/blogs/2010/05/27/announcing-intel-concurrent-collections-for-haskell-01/>.   General documentation on the CnC model can be found at     <http://software.intel.com/en-us/articles/intel-concurrent-collections-for-cc/>. @@ -61,13 +66,16 @@                   -- running inside individual nodes of CnC graphs (in parallel).		       		  StepCode(..),  		  newItemCol, newTagCol, prescribe, -		  putt, put, get,+		  putt, put, get,  		  initialize, finalize,-                   runGraph, ++                  itemsToList, 		  stepPutStr, cncPutStr, cncVariant, +                  -- Undocumented experimental features:                   Item, newItem, readItem, putItem,+                  cncFor, cncFor2D,                    tests,  -- * Example Program@@ -86,7 +94,7 @@ cncGraph =    do tags  <- 'newTagCol'      items <- 'newItemCol'-     'prescribe' tags (mystep items)+     'prescribe' tags (myStep items)      'initialize' $         do 'put' items \"left\"  \"hello \"            'put' items \"right\" \"world \"@@ -119,9 +127,9 @@   undesirable, option.)   -} -import Data.Set as Set-import Data.HashTable as HT-import Data.Map as Map+import qualified Data.Set as Set+import qualified Data.HashTable as HT+import qualified Data.Map as Map import Data.Int import Data.IORef import Data.Word@@ -143,7 +151,12 @@  import Test.HUnit +-- Inline the utility library as well:+#ifndef INCLUDEMETHOD import Intel.CncUtil as GM hiding (tests)+#else+#include "CncUtil.hs"+#endif  ------------------------------------------------------------ -- Configuration Toggles:@@ -158,12 +171,14 @@  #ifdef HASHTABLE_TEST #define ITEMPREREQS (Eq tag, Ord tag, Hashable tag, Show tag)-#elif USE_GMAP+#else +#ifdef USE_GMAP -- #define ITEMPREREQS (Ord tag, Eq tag, GMapKey tag, Show tag) #define ITEMPREREQS (GMapKey tag) #else #define ITEMPREREQS (Eq tag, Ord tag, Show tag) #endif+#endif  ------------------------------------------------------------ -- Type signatures for the primary API operations:@@ -195,6 +210,11 @@ -- |Construct a new item collection. newItemCol :: ITEMPREREQS => GraphCode (ItemCol tag val) +-- |Convert an entire item collection into an association list.  In+-- general, this can only be done from the 'finalize' step and+-- requires selecting a runtime scheduler which supports /quiescence/, that is,+-- a scheduler that waits for all active steps to complete before executing 'finalize'.+-- (Currently, all schedulers but version 3 support quiescence.) itemsToList :: ITEMPREREQS => ItemCol tag b -> StepCode [(tag,b)]  -- |Steps are functions that take a single 'tag' as input and perform@@ -206,8 +226,6 @@ --                             Implementation                                 -- -------------------------------------------------------------------------------- -cncVariant="io/" ++ show (CNC_SCHEDULER :: Int)- -- These 'new' functions need an argument if we don't want to run in -- to the monomorphism restriction (-fno-monomorphism-restriction) #ifndef SUPPRESS_newItemCol@@ -251,12 +269,12 @@        steps <- STEPLIFT readIORef _steps --       if memoize  --        then +--        else  #ifdef MEMOIZE        if Set.member tag set         then return ()         else STEPLIFT writeIORef _set (Set.insert tag set) #else---        else         return () #endif        action steps tag@@ -280,7 +298,7 @@ initialize x = x #endif --- | Construct a CnC graph and execute it to completion.  Completion+-- |Construct a CnC graph and execute it to completion.  Completion --   is defined as the 'finalize' action having completed. runGraph :: GraphCode a -> a #ifndef SUPPRESS_runGraph@@ -299,8 +317,30 @@  -- |An informal identifier of the CnC version presently in use (for example, identifying a scheduler implementation). cncVariant :: String---cncVariant="io/" ++ show (CNC_SCHEDULER :: Int)+cncVariant ="io-based, scheduler " ++ show (CNC_SCHEDULER :: Int)  +#ifdef USE_GMAP+       ++ ", gmap enabled"+#else +       ++ ", gmap disabled"+#endif+#ifdef MEMOIZE+       ++ ", memoize enabled"+#else +       ++ ", memoize disabled"+#endif+#ifdef INCLUDEMETHOD+       ++ ", #include method"+#endif+#ifdef REPEAT_PUT_ALLOWED+       ++ ", repeated identical puts permitted"+#endif+#ifdef DEBUG_HASKELL_CNC+       ++ ", DEBUG enabled"+#endif +++ -------------------------------------------------------------------------------- --  Testing --------------------------------------------------------------------------------@@ -346,9 +386,10 @@ 	     c <- itemsToList d3 	     return (a,b,c) +#ifndef INCLUDEMETHOD tests :: Test tests = TestList [ smalltest ]-+#endif  -------------------------------------------------------------------------------- -- EXPERIMENTAL:@@ -366,34 +407,64 @@ putItem  = error "putItem not implemented under this scheduler" #endif --------------------------------------------------------------------------------- ----------------------------------------------------------------Version 1: Serial--- (This version has been disabled/removed.)+-- Internal function. We may allow extending the graph from within a+-- step.  I'm not sure what the best name for this is.  +graphInStep :: GraphCode a -> StepCode a+#ifndef SUPPRESS_graphInStep+-- Default is to assume the monads are the same:+graphInStep x = x+#endif --- Version 2: --- (This version has been disabled/removed.) --- Here we do the tail call optimization for the common case of a single prescribed step.+#ifndef SUPPRESS_cncFor+-- | \"@cncFor start end body@\" runs @body@ in parallel over the inclusive range @[start..end]@.+-- +-- Frequently, CnC graphs are serial within steps but parallel at the+-- level of the graph.  In contrast, 'cncFor' exposes parallelism+-- /within a step/.  Whether the body of the parallel for is doing+-- work, or just spawning work via 'putt', 'cncFor' can help+-- distribute the work more efficiently.+cncFor :: Int -> Int -> (Int -> StepCode ()) -> StepCode ()+-- Parallel for and tag-ranges can make things much more efficient for+-- a common case. +-- +-- It may be nice under some schedulers to use forkOnIO to explicitly+-- disseminate the ranges to processors.  This alas wouldn't work well+-- with nested cncFor loops.  But if we disencourage those and+-- explicitly provide cncFor2D etc...+-- +cncFor start end body = + do ts <- graphInStep newTagCol+    --stepPutStr$ "Performing cncFor on range " ++ show (start,end) ++ "\n"+    graphInStep$ prescribe ts$ \(x,y) -> +      do --stepPutStr$ "  Executing range segment: "++ show (x,y) ++ "\n"+         for_ x (y+1) body+    --stepPutStr$ "Desired segments "++ show (4*numCapabilities) ++ " putting first segment...\n"+    let range_segments = splitInclusiveRange (4*numCapabilities) (start,end)+    --stepPutStr$ "PUTTING RANGES "++ show (length range_segments) ++" "++ show range_segments ++"\n"+    forM_ range_segments (putt ts)+#endif +#ifndef SUPPRESS_cncFor2D+-- | A two dimensional loop.+{-# INLINE cncFor2D #-}+cncFor2D :: (Int,Int) -> (Int,Int) -> (Int -> Int -> StepCode ()) -> StepCode ()+-- In this version we don't do anything special for 2D loops:+cncFor2D (s1,s2) (e1,e2) body =+  cncFor s1 e1 $ \ i ->  +   cncFor s2 e2 (body i) ---------------------------------------------------------------- TODO  TODO TODO TODO TODO TODO TODO TODO TODO TODO  -- -------------------------------------------------------------+-- Stripe distribution -- only parallelize the outer loop.+-- (Tiles would be better but slightly more complex.)+-- Oddly... this doesn't do better in any scheduler on the current benchmark...+-- cncFor2D (s1,s2) (e1,e2) body =+--   cncFor s1 e1 $ \ i ->  +--    for_ s2 (e2+1) (body i)+#endif --- [2010.02.11] I need to look at unecessary control-flow--- back-and-forth.  Currently, because of this "depth-first"--- optimization, I will call down to a child and then probably return--- (unless GHC manages to turn it into a tail call, maybe it does).  I--- could help out GHC by just queueing a list of spawned downstream--- tasks as I go through a step.  When the step is done, the list can--- be spawned.  At that point if there is only one downstream it can--- definitely be a tail call.  ----------------------------------------------------------------------------------   -- <eof> *** This file will be included into the per-scheduler implementations. *** 

@@ -2,6 +2,9 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses   #-}

@@ -2,6 +2,9 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses   #-}@@ -13,9 +16,11 @@ #define CNC_SCHEDULER 3 #define STEPLIFT  id$ #define GRAPHLIFT id$+-- #define SUPPRESS_cncFor+-- #define SUPPRESS_cncFor2D #include "Cnc.Header.hs" -type TagCol  a   = (IORef (Set a), IORef [Step a])+type TagCol  a   = (IORef (Set.Set a), IORef [Step a]) type ItemCol a b = MutableMap a b  type StepCode  = IO @@ -58,8 +63,8 @@ -------------------------------------------------------------------------------- -- EXPERIMENTAL: ----------------------------------------------------------------------------------- This is a proposed addition for manipulating items outside of item collections. +-- This is a proposed addition for manipulating items outside of item collections. type Item = MVar newItem  = newEmptyMVar readItem = readMVar@@ -67,3 +72,37 @@   do b <- tryPutMVar mv x      if b then return () 	  else error "Violation of single assignment rule; second put on Item!"++#ifdef SUPPRESS_cncFor+#warning "Selecting specialized version of cncFor for Scheduler 3"+-- Because this scheduler doesn't have the *nested* structure that,+-- say, scheduler 8 does, the default definition of cncFor will not+-- provide much benefit.  Instead, we try one that uses explicit+-- placement of threads.+cncFor start end body = + -- With this version we don't create any additional graph nodes.+ -- Instead, we create additional IO threads.+ do --stepPutStr$ "FORKING THREADS FOR CNCFOR!! Ranges: "++ show ranges++"\n"+    forM_ [0..numthreads-1] fork_thread      + where +    splitfactor = 1 -- TBB uses 4, but IO threads have more overhead...+    numthreads = numCapabilities * splitfactor+    ranges = splitInclusiveRange numthreads (start,end)+    fork_thread i = +     -- Assign the IO thread to a particular CPU:+     forkOnIO (i `quot` splitfactor) $ +       let (x,y) = ranges !! i in+       for_ x (y+1) body+#endif++#ifdef SUPPRESS_cncFor2D+-- cncFor2D (s1,s2) (e1,e2) body =+--   cncFor s1 e1 $ \ i ->  +--    cncFor s2 e2 (body i)++-- When using the default cncFor his one does vastly worse.  But with+-- the custom cncFor above, it is better.+cncFor2D (s1,s2) (e1,e2) body =+  cncFor s1 e1 $ \ i ->  +    for_ s2 (e2+1) (body i)+#endif

@@ -2,9 +2,11 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses-  , CPP   #-} -- State monad transformer is needed for both step & graph: #ifndef MODNAME@@ -55,3 +57,4 @@   do b <- STEPLIFT tryPutMVar mv x      if b then return () 	  else error "Violation of single assignment rule; second put on Item!"+

@@ -2,6 +2,9 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses   #-}

@@ -2,6 +2,9 @@   , BangPatterns   , MagicHash    , ScopedTypeVariables+  , TypeFamilies +  , UndecidableInstances+  , OverlappingInstances   , DeriveDataTypeable   , MultiParamTypeClasses   #-}@@ -16,6 +19,7 @@ #define SUPPRESS_newItemCol #define SUPPRESS_initialize #define SUPPRESS_itemsToList+#define SUPPRESS_graphInStep #include "Cnc.Header.hs"  --------------------------------------------------------------------@@ -36,7 +40,10 @@ -- escape a step's execution upon a failed get.  An alternative is to -- use the ContT monad transformer. -type TagCol a   = (IORef (Set a), IORef [Step a])+-- TODO: The Cilk-like functionality could be factored into its own+-- reusable module.++type TagCol a   = (IORef (Set.Set a), IORef [Step a]) --type ItemCol a b = MutableMap a b  -- Here the hidden state keeps track of @@ -50,7 +57,7 @@ newtype HiddenState8 = HiddenState8 (StepCode (), [()])  -- In this version we don't use MVars because gets don't block:-newtype ItemCol a b = ItemCol (IORef (Map a ((Maybe b), WaitingSteps)))+newtype ItemCol a b = ItemCol (IORef (Map.Map a ((Maybe b), WaitingSteps))) type WaitingSteps = [StepCode ()]  data EscapeStep = EscapeStep  deriving (Show, Typeable)@@ -82,8 +89,6 @@ -- the end of the step with a sync.  It needs a retry action to tuck -- into the state so that the step can store it if it needs to escape -- with an exception.--- --- DESIGN DECISION:  try_stepcode :: StepCode () -> StepCode a -> IO (Maybe a) try_stepcode retry m = wrapped  where@@ -216,6 +221,9 @@      fil (key, (Nothing, _)) = False      fil _                   = True ++-- To execute graph code inside a step we just need to lift it into the monad transformer:+graphInStep = S.lift  quiescence_support=True ; 

@@ -723,7 +723,7 @@ 	     then putStr "EMPTIED\n" 	     else threadloop worldref blockedref newprimed (fresh ++ intags) -}-            return undefined+            return (error "CncPure distScheduler not complete yet")  -------------------------------------------------------------------------------- -- Run some steps, accumulate output, and then return to synchronize/schedule.@@ -988,6 +988,17 @@ 	  it = (IntMap.!) imap num       in (Just (finalmagic id (Map.toList it)), 	  Done tags items)++-- This is just a serial loop for now:+cncFor :: Int -> Int -> (Int -> StepCode ()) -> StepCode ()+cncFor start end body = for_ start (end+1) body++cncFor2D :: (Int,Int) -> (Int,Int) -> (Int -> Int -> StepCode ()) -> StepCode ()+cncFor2D (s1,s2) (e1,e2) body =+  cncFor s1 e1 $ \ i ->  +   cncFor s2 e2 (body i)++  -------------------------------------------------------------------------------- -- Testing:

@@ -30,7 +30,7 @@ -- |An internal utility module that supports the CnC implementations. #ifndef INCLUDEMETHOD module Intel.CncUtil (-		      foldRange, for_, splitN, forkJoin, +		      foldRange, for_, splitN, splitInclusiveRange, forkJoin,  		      doTrials, FitInWord (..),  		      GMapKey (..),  		      Hashable (..),@@ -43,6 +43,8 @@  		      ) where+#else+#warning "Loading CncUtil.hs through include method..." #endif  import GHC.Conc@@ -61,7 +63,7 @@ import Debug.Trace  import Test.HUnit-import Test.QuickCheck (quickCheck, (==>))+-- import Test.QuickCheck (quickCheck, (==>))  -------------------------------------------------------------------------------- -- Miscellaneous Utilities@@ -69,6 +71,7 @@  -- |A simple loop construct to use if you don't trust rewrite based deforestation. -- Usage foldRange start end acc, where start is inclusive, end uninclusive.+{-# INLINE foldRange #-} foldRange start end acc fn = loop start acc  where   loop !i !acc@@ -77,6 +80,7 @@  -- |My own forM, again, less trusting of optimizations. -- Inclusive start, exclusive end.+{-# INLINE for_ #-} for_ start end fn | start > end = error "for_: start is greater than end" for_ start end fn = loop start   where @@ -94,8 +98,33 @@     loop n ls = hd : loop (n-1) tl        where (hd,tl) = splitAt sz ls +-- Similar to splitN but for a (start,end) range not an actual list.+-- The first segment gets the extras and the rest are evenly sized:+-- splitInclusiveRange pieces (start,end) = +--   (start, start + portion - 1 + remain) : map fn [1 .. pieces-1]+--  where 	+--    len = end - start + 1 -- inclusive [start,end]+--    (portion, remain) = len `quotRem` pieces+--    fn i = let nextstart = start + i * portion + remain+--           in (nextstart, nextstart + portion - 1)  +-- Instead of having one oversized piece, spread the remainder one per+-- segment:+{-# INLINE splitInclusiveRange #-}+splitInclusiveRange pieces (start,end) = +  map largepiece [0..remain-1] ++ +  map smallpiece [remain..pieces-1]+ where 	+   len = end - start + 1 -- inclusive [start,end]+   (portion, remain) = len `quotRem` pieces+   largepiece i = +       let offset = start + (i * (portion + 1))+       in (offset, offset + portion)+   smallpiece i = +       let offset = start + (i * portion) + remain+       in (offset, offset + portion - 1) + -- |Run IO threads in parallel and wait till they're done. forkJoin actions =  -- I'm amazed this is not built-in.@@ -141,7 +170,8 @@ mmToList = HT.toList #warning "Enabling HashTable item collections.  These are not truly thread safe (yet)." -#elif USE_GMAP+#else +#ifdef USE_GMAP #warning "Using experimental indexed type family GMap implementation..." -- Trying to use GMaps: type MutableMap a b = IORef (GMap a (MVar b))@@ -190,6 +220,7 @@     do map <- readIORef col         return (DM.toList map) #endif+#endif  ------------------------------------------------------------ -- Hot Atomic Words operations@@ -322,15 +353,20 @@ #endif  -- Pairs can fit in words too!--- TODO: Use some code generation method to generate instances for all+-- FIXME TODO: Use some code generation method to generate instances for all -- combinations of small words/ints that fit in a machine word (a lot). instance FitInWord (Word16,Word16) where   toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)   fromWord n = (fromIntegral$ shiftR n 16,  		fromIntegral$ n .&. 0xFFFF) +instance FitInWord (Int16,Int16) where+  toWord (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)+  fromWord n = (fromIntegral$ shiftR n 16, +		fromIntegral$ n .&. 0xFFFF)  + -------------------------------------------------------------------------------- -- ADT definition for generic Maps: --------------------------------------------------------------------------------@@ -348,16 +384,13 @@  -------------------------------------------------------------------------------- +-- What problems was I running into here:+-- It's hard to avoid conflicting instances, for example with the tuple instance.+-- I think I may need a NotFitInWord class constraint.. #if 0 instance FitInWord t => GMapKey t where-  -- data GMap t v            = GMapWord (GMap t v) deriving Show-  -- empty                    = GMapWord empty-  -- lookup k    (GMapWord m) = lookup (ord k) m-  -- insert k v  (GMapWord m) = GMapWord (insert (ord k) v m)-  -- alter  fn k (GMapWord m) = GMapWord (alter fn (ord k) m)-  -- toList      (GMapWord m) = map (\ (i,v) -> (chr i,v)) (toList m)   data GMap t v           = GMapInt (DI.IntMap v) deriving Show-  --empty                   = trace "\n <<<<< Empty FitInWord Gmap... >>>>\n"$ GMapInt DI.empty+  --empty                   = trace "\n <<<<< FitInWord Gmap... >>>>\n"$ GMapInt DI.empty   empty                   = GMapInt DI.empty   lookup k    (GMapInt m) = DI.lookup (wordToInt$ toWord k) m   insert k v  (GMapInt m) = GMapInt (DI.insert (wordToInt$ toWord k) v m)@@ -365,9 +398,44 @@   toList      (GMapInt m) = map (\ (i,v) -> (fromWord$ intToWord i, v)) $  			    DI.toList m - #else +-- Unit and Bool can have specialized implementations, but because+-- they also "FitInWord", these result in conflicts.+------------------------------------------------------------+instance GMapKey () where+  data GMap () v           = GMapUnit (Maybe v)+  empty                    = GMapUnit Nothing+  lookup ()   (GMapUnit v) = v+  insert () v (GMapUnit _) = GMapUnit $ Just v+  alter fn () (GMapUnit v) = GMapUnit $ fn v+  toList (GMapUnit Nothing) = []+  toList (GMapUnit (Just v)) = [((),v)]+instance GMapKey Bool where+  data GMap Bool v              = GMapBool (Maybe v) (Maybe v)+  empty                       = GMapBool Nothing Nothing+  lookup True  (GMapBool v _) = v+  lookup False (GMapBool _ v) = v+  insert True v  (GMapBool a b) = GMapBool (Just v) b+  insert False v (GMapBool a b) = GMapBool a (Just v)+  alter fn True  (GMapBool a b) = GMapBool (fn a) b+  alter fn False (GMapBool a b) = GMapBool a (fn b)+  toList (GMapBool Nothing Nothing)   = []+  toList (GMapBool (Just a) Nothing)  = [(True,a)]+  toList (GMapBool Nothing (Just b))  = [(False,b)]+  toList (GMapBool (Just a) (Just b)) = [(True,a),(False,b)]+------------------------------------------------------------++-- GMaps on Int keys become Data.IntMaps:+instance GMapKey Int where+  data GMap Int v         = GMapInt (DI.IntMap v) deriving Show+  empty                   = GMapInt DI.empty+  lookup k    (GMapInt m) = DI.lookup k m+  insert k v  (GMapInt m) = GMapInt (DI.insert k v m)+  alter  fn k (GMapInt m) = GMapInt (DI.alter fn k m)+  toList      (GMapInt m) = DI.toList m++-- Then other scalar keys can be converted to Ints: -- CODE DUPLICATION instance GMapKey Char where   data GMap Char v         = GMapChar (GMap Int v) deriving Show@@ -401,14 +469,6 @@   alter  fn k (GMapWord m) = GMapWord (alter fn (fromIntegral k) m)   toList      (GMapWord m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) -instance GMapKey Int where-  data GMap Int v         = GMapInt (DI.IntMap v) deriving Show-  empty                   = GMapInt DI.empty-  lookup k    (GMapInt m) = DI.lookup k m-  insert k v  (GMapInt m) = GMapInt (DI.insert k v m)-  alter  fn k (GMapInt m) = GMapInt (DI.alter fn k m)-  toList      (GMapInt m) = DI.toList m- instance GMapKey Int8 where   data GMap Int8 v        = GMapInt8 (GMap Int v) deriving Show   empty                    = GMapInt8 empty@@ -426,40 +486,28 @@   toList      (GMapInt16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)  -- TODO IFDEF 64 BIT THEN WE CAN FIT AN INT64 AND WORD64 TOO!!-#endif +-- Can't get past the "Conflicting family instance declarations"+-- instance GMapKey (Int16, Int16) where+--   data GMap (Int16,Int16) v         = GMapInt16Pair (GMap Int v) deriving Show+--   empty                     = trace "<<< Constructing Double-Int16 GMAP (Intmap) >>>> " $ +-- 			      GMapInt16Pair empty+--   lookup k (GMapInt16Pair m)    = lookup (fromIntegral k) m+--   insert k v (GMapInt16Pair m)  = GMapInt16Pair (insert (fromIntegral k) v m)+--   alter  fn k (GMapInt16Pair m) = GMapInt16Pair (alter fn (fromIntegral k) m)+--   toList      (GMapInt16Pair m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m) --------------------------------------------------------------------------------- +#endif -instance GMapKey () where-  data GMap () v           = GMapUnit (Maybe v)-  empty                    = GMapUnit Nothing-  lookup ()   (GMapUnit v) = v-  insert () v (GMapUnit _) = GMapUnit $ Just v-  alter fn () (GMapUnit v) = GMapUnit $ fn v-  toList (GMapUnit Nothing) = []-  toList (GMapUnit (Just v)) = [((),v)] -instance GMapKey Bool where-  data GMap Bool v              = GMapBool (Maybe v) (Maybe v)-  empty                       = GMapBool Nothing Nothing-  lookup True  (GMapBool v _) = v-  lookup False (GMapBool _ v) = v-  insert True v  (GMapBool a b) = GMapBool (Just v) b-  insert False v (GMapBool a b) = GMapBool a (Just v)-  alter fn True  (GMapBool a b) = GMapBool (fn a) b-  alter fn False (GMapBool a b) = GMapBool a (fn b)-  toList (GMapBool Nothing Nothing)   = []-  toList (GMapBool (Just a) Nothing)  = [(True,a)]-  toList (GMapBool Nothing (Just b))  = [(False,b)]-  toList (GMapBool (Just a) (Just b)) = [(True,a),(False,b)]-+--------------------------------------------------------------------------------  -- |GMaps over pairs are implemented by nested GMaps. instance (GMapKey a, GMapKey b) => GMapKey (a, b) where   data GMap (a, b) v            = GMapPair (GMap a (GMap b v))-  empty		                = GMapPair empty+  empty		                = --trace "CONSTRUCTED GMAP USING NESTED MAPS!"$ +                                  GMapPair empty   lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b    insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of 				    Nothing  -> insert a (insert b v empty) gm@@ -542,6 +590,8 @@ -- We also switch to a mutable data structure here: -------------------------------------------------------------------------------- +-- UNFINISHED:+ -- A key/value pair that works inside a GMap2. class GMapKeyVal k v where   data GMap2 k v :: *@@ -604,8 +654,13 @@ testCase str io = TestLabel str $ TestCase$ do putStrLn$ "\n *** Running unit test: "++str; io; putStrLn ""  test1 = testCase "Spot check list lengths"$ assertEqual "splitN" [[1,2], [3,4,5]] (splitN 2 [1..5]) -test2 = testCase "Quickcheck splitN - varying split size"$ -	quickCheck$ (\ (n::Int) -> n>0 ==> -		     (\ (l::[Int]) -> concat (splitN n l) == l))  -tests = TestList [test1, test2]++-- [2010.05.31] I don't have quickcheck working under 6.13.xx+-- test2 = testCase "Quickcheck splitN - varying split size"$ +-- 	quickCheck$ (\ (n::Int) -> n>0 ==> +-- 		     (\ (l::[Int]) -> concat (splitN n l) == l)) ++-- tests = TestList [test1, test2]++tests = TestList [test1]

@@ -2,7 +2,7 @@ -- Pieces that are common to version 5 and 6 ------------------------------------------------------------ -type TagCol a   = (IORef (Set a), IORef [Step a])+type TagCol a   = (IORef (Set.Set a), IORef [Step a]) type ItemCol a b = MutableMap a b  -- Here the hidden state keeps track of a pointer to the work-sharing@@ -17,7 +17,7 @@ --   (2) the number of workers for this graph --   (3) the "make worker" function to spawn new threads --   (4) the set of "mortal threads"-newtype HiddenState5 = HiddenState5 (HotVar [StepCode ()], HotVar Int, IO (), HotVar (Set ThreadId))+newtype HiddenState5 = HiddenState5 (HotVar [StepCode ()], HotVar Int, IO (), HotVar (Set.Set ThreadId))   deriving Show  instance Show (IORef a) where @@ -83,11 +83,10 @@ --ver5_6_core_finalize :: Chan a -> IO b -> IO () -> StepCode b ver5_6_core_finalize :: Chan a -> StepCode b -> StepCode () -> GraphCode b ver5_6_core_finalize joiner finalAction worker = -    do (HiddenState5 (stack, numworkers, _, _)) <- S.get-       --state <- S.get +    do (HiddenState5 (stack, numworkers, _, mortal)) <- S.get        --GRAPHLIFT writeIORef global_makeworker makeworker        let mkwrkr = do S.runStateT worker state2; return ()-           state2 = HiddenState5 (stack, numworkers, mkwrkr, undefined)+           state2 = HiddenState5 (stack, numworkers, mkwrkr, mortal)         GRAPHLIFT atomicModifyIORef numworkers (\n -> (n + numCapabilities, ()))        -- Fork one worker per thread:@@ -122,5 +121,5 @@     do hv  <- newHotVar []        hv2 <- newHotVar 0        hv3 <- newHotVar Set.empty-       (a,_) <- S.runStateT x (HiddenState5 (hv,hv2, undefined, hv3))+       (a,_) <- S.runStateT x (HiddenState5 (hv,hv2, error "Intel.Cnc6 internal error: makeworker thunk used before initalized", hv3))        return a

@@ -5,6 +5,7 @@ default:          # This target builds CnC as precompiled modules:         # Pick default schedulers as well:+	ghc --make -c -cpp                   Intel/CncUtil.hs 	ghc --make -c -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs 	ghc --make -c -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs @@ -24,7 +25,7 @@ 	THREADS=1 ./run_all_tests.sh  longtest: -	NONSTRICT=1 LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh | tee all_tests.log+	NONSTRICT=1 LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh &> /dev/stdout | tee all_tests.log #	LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh &> /dev/stdout | tee all_tests.log  distro: pkg @@ -46,7 +47,15 @@  clean: 	rm -f Intel/*.o Intel/*.hi Intel/*~ +	rm -f *.aux little*.log  	(cd examples; $(MAKE) clean)  distclean: clean 	rm -rf distro_20*+# DO NOT DELETE: Beginning of Haskell dependencies+Intel/CncUtil.o : Intel/CncUtil.hs+Intel/Cnc3.o : Intel/Cnc3.hs+Intel/Cnc3.o : Intel/CncUtil.hi+examples/test_parfor.o : examples/test_parfor.hs+examples/test_parfor.o : Intel/Cnc3.hi+# DO NOT DELETE: End of Haskell dependencies

@@ -6,8 +6,14 @@  # -fvia-C #GHC_DEFAULT_FLAGS=" -fasm -O2"-#GHC_DEFAULT_FLAGS=" -rtsopts -O2"-GHC_DEFAULT_FLAGS=" -O2"++# For 6.13:++if [ "`ghc -V`" == "The Glorious Glasgow Haskell Compilation System, version 6.12.1" ];+then GHC_DEFAULT_FLAGS=" -O2"+#then GHC_DEFAULT_FLAGS=" "+else GHC_DEFAULT_FLAGS=" -rtsopts -O2"+fi   # Affinity is pretty much always good. GHC_DEFAULT_RTS="  -qa " 

@@ -29,7 +29,6 @@ import Debug.Trace import Control.Monad import System.Environment-import Intel.CncUtil  import qualified  Control.Monad.State.Strict as S  @@ -85,4 +84,4 @@        case args of  	   []  -> runit $ 50*1000*1000 	   [n] -> runit $ round (10 ** read n)-	   [trials, n] -> doTrials (read trials) (loop [n])+--	   [trials, n] -> doTrials (read trials) (loop [n])

@@ -20,11 +20,10 @@  import System.Environment import Data.Int-import Intel.CncUtil+import Control.Monad  #include "haskell_cnc.h" - run n = runGraph $          do tags  :: TagCol  Int       <- newTagCol 	  items :: ItemCol Int Int64 <- newItemCol@@ -35,8 +34,8 @@ 	  initialize $  	     do put items 0 0 		 		put items 1 1 -		for_ 2 (n+1) (putt tags)-		--forM_ [2..n] (putt tags)+		--for_ 2 (n+1) (putt tags)+		forM_ [2..n] (putt tags) 		--forM_ (reverse [2..n]) (putt tags)  	  finalize $  	     do get items n

@@ -19,9 +19,11 @@ -- Author: Ryan Newton   import Data.Complex-import Data.Word+import Data.Int import System.Environment+import Control.Monad +-- #define USE_GMAP -- #define MEMOIZE #include <haskell_cnc.h> @@ -34,7 +36,8 @@     | fn(z) >= 2.0   = count      | otherwise      = loop (i+1) (z*z + c) (count+1) -type Pair = (Word16, Word16)+-- A pair will fit in a word:+type Pair = (Int16, Int16)  mandelProg :: Int -> Int -> Int -> GraphCode Int mandelProg max_row max_col max_depth = @@ -48,33 +51,32 @@         prescribe position mandelStep  ---        gcPrintWorld "1"+        initialize $ -        for_ 0 max_row $ \i -> -         for_ 0 max_col $ \j ->+        forM_ [0..max_row] $ \i -> +         forM_ [0..max_col] $ \j ->           let (_i,_j) = (fromIntegral i, fromIntegral j) 	      z = (r_scale * (fromIntegral j) + r_origin) :+    		  (c_scale * (fromIntegral i) + c_origin) in 	  do put dat (_i,_j) z 	     putt position (_i,_j)---        gcPrintWorld "2"         -- Final result, count coordinates of the  pixels with a certain value:        finalize $ -	foldRange 0 max_row (return 0) $ \acc i -> -	 foldRange 0 max_col acc $ \acc j -> -	   do cnt <- acc-	      p <- get pixel (fromIntegral i, fromIntegral j)-	      if p == max_depth-   	       then return (cnt + (i*max_col + j))-   	       else return cnt+	foldM (\acc i -> +          foldM (\acc j -> +	           do p <- get pixel (fromIntegral i, fromIntegral j)+		      if p == max_depth+   		       then return (acc + (i*max_col + j))+   		       else return acc)+	        acc [0..max_col]+              ) 0 [0..max_row]             where      r_origin = -2                            :: Double     r_scale  = 4.0 / (fromIntegral max_row)  :: Double     c_origin = -2.0                          :: Double     c_scale = 4.0 / (fromIntegral max_col)   :: Double-   runMandel a b c = 

@@ -0,0 +1,110 @@+-- Author: Ryan Newton ++-- In this version we flatten our (x,y) positions into a single integer.+-- To that end, we FIX the grid size statically to 300x300.+++-- In this improved version, we look at three different optimizations.+--   First: enable GMaps and pack +--   Second: use cncFor to structure the spewing of the inital workload.+--   Third: do the work *inside* a cncFor and thereby drastically reduce the step count.++-- Set the environment variable MANDELOPT to {1,2,3} to add each of these optimizations.++import Data.Complex+import Data.Word+import System.Environment+import Control.Monad+import Data.Bits++-- #define MEMOIZE+#define USE_GMAP+#include <haskell_cnc.h>++-- Here we manually pack our pairs into scalars.+-- In the future the ItemCol data type may do this for us auto-magically.+type Pair = (Word16, Word16)+pack   :: Pair -> Int+unpack :: Int -> Pair+pack (a,b) = shiftL (fromIntegral a) 16 + (fromIntegral b)+unpack n   = (fromIntegral$ shiftR n 16, fromIntegral$ n .&. 0xFFFF)++mandel :: Int -> Complex Double -> Int+mandel max_depth c = loop 0 0 0+  where   +   fn = magnitude+   loop i z count+    | i == max_depth = count+    | fn(z) >= 2.0   = count +    | otherwise      = loop (i+1) (z*z + c) (count+1)++mandelProg :: Int -> Int -> Int -> Int -> GraphCode Int+mandelProg optlvl max_row max_col max_depth = +    do position :: TagCol  Int                  <- newTagCol+       dat      :: ItemCol Int (Complex Double) <- newItemCol+       pixel    :: ItemCol Int Int              <- newItemCol+       +       let mandelStep tag = +	    do cplx <- get dat tag+	       put pixel tag (mandel max_depth cplx)++       prescribe position mandelStep ++       let packit i j = (pack (_i,_j), z)+             where (_i,_j) = (fromIntegral i, fromIntegral j)+       	           z = (r_scale * (fromIntegral j) + r_origin) :++       		       (c_scale * (fromIntegral i) + c_origin)++       let kernel i j = do let (packed,z) = packit i j + 		       	   put  dat packed z+       	                   putt position packed++       let init1 = forM_ [0..max_row] $ \i -> +                     forM_ [0..max_col] $ \j ->+  	               kernel i j ++       -- This version uses cncFor to structure the work spawning.+       let init2 = +                 do stepPutStr "mandel_opt: Using cncFor implementation...\n"+                    cncFor2D (0,0) (max_row, max_col)  $ \ i j ->+		       kernel i j			  ++       -- This version uses cncFor to do the actual work.+       let init3 = do stepPutStr "mandel_opt: Using even better cncFor method...\n"+       		      cncFor2D (0,0) (max_row, max_col)  $ \ i j ->+			 do let (packed,z) = packit i j+       	                    put pixel packed (mandel max_depth z)++       initialize $ +        case optlvl of +	 1 -> init1+	 2 -> init2 +	 3 -> init3++       -- Final result, count coordinates of the  pixels with a certain value:+       finalize $ +	foldM (\acc i -> +          foldM (\acc j -> +	           do p <- get pixel (pack (fromIntegral i, fromIntegral j))+		      if p == max_depth+   		       then return (acc + (i*max_col + j))+   		       else return acc)+	        acc [0..max_col]+              ) 0 [0..max_row] +       +   where +    r_origin = -2                            :: Double+    r_scale  = 4.0 / (fromIntegral max_row)  :: Double+    c_origin = -2.0                          :: Double+    c_scale = 4.0 / (fromIntegral max_col)   :: Double+++runMandel optlvl a b c = +	do putStrLn$ "Running mandel with opt level: "++ show optlvl+	   let check = runGraph $ mandelProg optlvl a b c +	   putStrLn ("Mandel check " ++ show check)++main = do args <- getArgs  +	  case args of+	   []         -> runMandel 1 3 3 3   -- Should output 24.+	   [o, a,b,c] -> runMandel (read o) (read a) (read b) (read c)

@@ -31,7 +31,6 @@    import System.Environment import Data.Int-import Intel.CncUtil import Data.List  #include "haskell_cnc.h"

@@ -1,5 +1,5 @@ Name:           haskell-cnc-Version:        0.1.2+Version:        0.1.3 License: LGPL License-file:   LICENSE Stability: Beta@@ -13,19 +13,27 @@  stream-processing but in which nodes in the computation graph share data in tables.  Category: system, concurrent-Cabal-Version: >=1.2.3+Cabal-Version: >=1.6  build-type: Simple +source-repository head+  type:     darcs+  location: http://darcs.haskell.org/haskell-cnc/++--Data-Files: ntimes ntimes_minmedmax README.txt haskell_cnc.h Makefile install_environment_vars.sh + library-  build-depends:  base, mtl, containers, time, random, array, ghc-prim, extensible-exceptions, HUnit, QuickCheck+  build-depends:  base, mtl, containers, time, random, array, ghc-prim, extensible-exceptions, HUnit, MissingH, HSH+  -- QuickCheck -- I haven't got quickcheck working under 6.13.xx right now.   -- Needed for the scaling.hs plotting script:   --   HSH, gnuplot   -- , judy>=0.2.2 -  exposed-modules:  Intel.Cnc Intel.CncPure Intel.CncUtil+  exposed-modules:  Intel.Cnc Intel.CncPure  	            -- Various alternative schedulers:                     Intel.Cnc3 Intel.Cnc5 Intel.Cnc6 Intel.Cnc8+  other-modules: Intel.CncUtil   extensions: CPP,         -- These extensions are needed for Cnc.hs        FlexibleInstances, BangPatterns, MagicHash, ScopedTypeVariables, DeriveDataTypeable, MultiParamTypeClasses,@@ -37,13 +45,13 @@ -- -Wall    -- Unfortunately these go in the include/ subdirectory once cabal installs the package.   install-includes: ntimes ntimes_minmedmax README.txt haskell_cnc.h Makefile install_environment_vars.sh -                    default_opt_settings.sh runcnc run_all_examples.sh scaling.hs -                    examples/hello_world.hs examples/mandel.hs examples/primes.hs examples/primes2.hs +                    default_opt_settings.sh runcnc run_all_examples.sh scaling.hs timeout.hs+                    examples/hello_world.hs examples/mandel.hs examples/mandel_opt.hs examples/primes.hs examples/primes2.hs                      examples/sched_tree.hs examples/threadring_onestep.hs examples/threadring.hs                      examples/embarrassingly_par.hs examples/fib.hs examples/nbody.hs                     Intel/Cnc.Header.hs Intel/shared_5_6.hs -		    --Intel/CncUtil.hs-                    --Intel/Cnc.hs Intel/CncPure.hs Intel/Cnc3.hs Intel/Cnc5.hs Intel/Cnc6.hs Intel/Cnc8.hs+                    Intel/CncUtil.hs+                    Intel/Cnc.hs Intel/CncPure.hs Intel/Cnc3.hs Intel/Cnc5.hs Intel/Cnc6.hs Intel/Cnc8.hs    -- This seems to be completly ignored by cabal currently:   -- Test testit@@ -57,4 +65,3 @@   extensions: CPP   GHC-Options: -O2 -threaded  --  cpp-options: -DUSE_GMAP--- Intel.CncUtil

@@ -24,7 +24,7 @@ #warning "Loading CNC as a separately compiled module"  -- This is here to test the efficiency of the normal module include method: import Intel.Cnc-import Intel.CncUtil+-- import Intel.CncUtil  #undef INCLUDEMETHOD 

@@ -80,7 +80,9 @@  # [2009.12.17] I need to get a good cross-platform process time-out system:     if [ -e ./timeout ];-    then TIMEOUTRUN="./timeout -t $TIMEOUT"+    # [2010.06.03] --RTS is a hack for working around a problem with +RTS flags:+    then TIMEOUTRUN="./timeout $TIMEOUT --RTS "+    #then TIMEOUTRUN="./timeout -t $TIMEOUT"     else TIMEOUTRUN=     fi 

@@ -3,12 +3,13 @@ import qualified Intel.Cnc import qualified Intel.CncPure import qualified Intel.CncUtil- import System.Cmd(system)  import System.Exit +import HSH import Test.HUnit +import Data.String.Utils -- from MissingH package  main = do  	  cd <- getCurrentDirectory@@ -38,11 +39,19 @@ 	  putStrLn$ "Finally running system tests in all configurations (example programs):" 	  putStrLn$ "================================================================================\n" -          b <- doesFileExist "run_all_examples.sh"-          if not b-           then error$ "Uh oh, the script run_all_examples.sh doesn't exist in this directory.\n"++-		       "  If cabal installed the package you may find it in your ~/.cabal/lib directory."-	   else return ()   +          b1 <- doesFileExist "run_all_examples.sh"+          if b1+           then putStrLn "!!! run_all_examples.sh found in current directory, using that!\n\n"+           else do [ver] <- run "ghc-pkg latest haskell-cnc"+                   dir <- run$ ("ghc-pkg field "++ver++" include-dirs ") -|- replace "include-dirs:" ""+                   putStrLn$ "Switching to directory: " ++ show (strip dir)+                   setCurrentDirectory (strip dir)+	   +                   b2 <- doesFileExist "run_all_examples.sh"+                   if not b2+                    then error$ "Uh oh, the script run_all_examples.sh doesn't exist in this directory.\n"+    -- 		             "  If cabal installed the package you may find it in your ~/.cabal/lib directory."+    	            else return ()               -- I have problems with cabal sdist not preserving executable flags.           system "chmod +x ./runcnc" 

@@ -41,14 +41,18 @@  #export GHC=ghc-6.13.20100511  #export GHC=~/bin/Linux-i686/bin/ghc-6.13.20100511+unset HASKELLCNC +   # Which subset of schedures should we test: PURESCHEDS="2"-#IOSCHEDS="8 6 5 3"-IOSCHEDS="3 5 8"-#IOSCHEDS="3 5 6 8"+#IOSCHEDS="3"+IOSCHEDS="3 5 6 8" -#THREADSETTINGS="0 1 2 3 4 7 8"+if [ "$THREADSETTINGS" == "" ] +then THREADSETTINGS="4"+#then THREADSETTINGS="0 1 2 3 4"+fi  source default_opt_settings.sh @@ -62,7 +66,7 @@  # How many times to run a process before taking the best time: if [ "$TRIALS" == "" ]; then -  TRIALS=5+  TRIALS=1 fi  # Determine number of hardware threads on the machine:@@ -85,6 +89,9 @@ # ================================================================================ echo "# TestName Variant Scheduler NumThreads HashHackEnabled MinTime MedianTime MaxTime" > $RESULTS echo "# "`date` >> $RESULTS+echo "# "`uname -a` >> $RESULTS+echo "# "`ghc -V` >> $RESULTS+echo "# " echo "# Running each test for $TRIALS trials." >> $RESULTS echo "#  ... with default compiler options: $GHC_DEFAULT_FLAGS" >> $RESULTS echo "#  ... with default runtime options: $GHC_DEFAULT_RTS" >> $RESULTS@@ -131,7 +138,7 @@   CODE=$?   check_error $CODE "ERROR: compilation failed." -  echo "Executing ./examples/$test.exe $ARGS +RTS $RTS "+  echo "Executing ./ntimes_minmedmax "$TRIALS" ./examples/$test.exe $ARGS +RTS $RTS -RTS "   if [ "$LONGRUN" == "" ]; then export HIDEOUTPUT=1; fi   times=`./ntimes_minmedmax "$TRIALS" ./examples/$test.exe $ARGS +RTS $RTS -RTS`   CODE=$?@@ -151,11 +158,24 @@ echo "Running all tests, for THREADSETTINGS in {$THREADSETTINGS}" echo +# Build the timeout script if it hasn't been already:+if ! [ -e ./timeout ]; then +  ghc --make timeout.hs -threaded+  if [ "$?" != "0" ];+  then echo "GHC build of timeout.hs returned error."+       exit 1+  fi+fi++# Hygiene:+rm -f examples/*.exe+ # This specifies the list of tests and their arguments for a "long" run:-for line in "embarrassingly_par 9.2" "threadring 50000000 503" "sched_tree 18" "mandel 300 300 4000" "primes2 200000" "fib 20000"; do-#for line in "mandel 300 300 4000" "primes2 200000" ; do-#for line in "fib 20000"  "nbody 2000" ; do +#for line in "mandel_opt 1 300 300 4000" "mandel_opt 2 300 300 4000" "mandel_opt 3 300 300 4000" "mandel 300 300 4000"; do++for line in "embarrassingly_par 9.2" "threadring 50000000 503" "sched_tree 18" "primes2 200000" "fib 20000" "mandel 300 300 4000" "mandel_opt 1 300 300 4000"; do+   set -- $line   test=$1; shift @@ -170,6 +190,8 @@   echo "                           Running Test: $test.exe $ARGS                        "   echo "================================================================================" +  echo "# *** Config [$cnt ..], testing with command/args: $test.exe $ARGS " >> $RESULTS+  export CNC_VARIANT=pure  # Currently running the pure scheduler only in single threaded mode:  export NUMTHREADS=0@@ -197,8 +219,8 @@  # Finally, run once through separately compiled modules to compare performance (and make sure they build).  # This will basically use the IO based implementation with the default scheduler.  export CNC_VARIANT=separatemodule_io- export CNC_SCHEDULER=8- export NUMTHREADS=$MAXTHREADS+ export CNC_SCHEDULER=6+ export NUMTHREADS=4  runit   echo >> $RESULTS;

@@ -58,7 +58,7 @@ #EXTENSIONS="-fglasgow-exts" # -feager-blackholing TEMPEXT="-XFlexibleContexts -XTypeSynonymInstances"-EXTENSIONS=" -XExistentialQuantification -XScopedTypeVariables -XBangPatterns -XNamedFieldPuns -XRecordWildCards -XFlexibleInstances -XDeriveDataTypeable $TEMPEXT"+EXTENSIONS=" -XExistentialQuantification -XScopedTypeVariables -XBangPatterns -XNamedFieldPuns -XRecordWildCards -XFlexibleInstances -XDeriveDataTypeable -XTypeFamilies -XUndecidableInstances -XOverlappingInstances -XMultiParamTypeClasses $TEMPEXT" # MagicHash   # If the user has not set $HASKELLCNC we try the current directory.

@@ -0,0 +1,49 @@+#!/usr/bin/env runhaskell++import Data.List+import Data.IORef+import System.Exit+import System.Process+import System.Environment+import System.Posix.Unistd++import Control.Concurrent++polltime = 2 -- in seconds++main = +    do args <- getArgs +       -- A flag for completion:+       ref <- newIORef False+       case args of +        time:rest -> +	    let timeout = read time +		cmd = concat $ intersperse " " rest+            in+	    do putStrLn$ "++ Running command with timeout = "++ show timeout ++" seconds:\n  " ++ cmd+	       pid <- runCommand  cmd++               sync <- newEmptyMVar++	       let loop acc = +		    if acc > (timeout :: Int)+		    then do putStrLn$ "\nERROR: TIMED OUT!"+	 		    exitWith (ExitFailure 88)+	 	    else do sleep polltime+			    x <- getProcessExitCode pid+			    case x of +	                      Nothing -> do putStrLn$ "++ Polling, approximately "++ +						      show (acc+polltime) ++" seconds have elapsed..."+				            loop (acc+polltime)+			      Just code -> putMVar sync code+	       let poll_thread = loop 0+	       let wait_thread = +                        do waitForProcess pid+			   writeIORef ref True+			   putStrLn "++ Command completed without timing out."+			   putMVar sync ExitSuccess+	       forkIO wait_thread+	       forkIO poll_thread+	       final <- readMVar sync+	       exitWith final+