haskell-cnc (empty) → 0.1
raw patch · 33 files changed
+5135/−0 lines, 33 filesdep +HUnitdep +QuickCheckdep +arraysetup-changed
Dependencies added: HUnit, QuickCheck, array, base, containers, directory, extensible-exceptions, ghc-prim, mtl, process, random, time
Files
- Intel/Cnc.Header.hs +399/−0
- Intel/Cnc.hs +47/−0
- Intel/Cnc3.hs +69/−0
- Intel/Cnc5.hs +56/−0
- Intel/Cnc6.hs +61/−0
- Intel/Cnc8.hs +243/−0
- Intel/CncPure.hs +1082/−0
- Intel/CncUtil.hs +611/−0
- Intel/shared_5_6.hs +140/−0
- LICENSE +502/−0
- Makefile +52/−0
- README.txt +77/−0
- Setup.hs +24/−0
- default_opt_settings.sh +14/−0
- examples/embarrassingly_par.hs +88/−0
- examples/fib.hs +50/−0
- examples/hello_world.hs +45/−0
- examples/mandel.hs +87/−0
- examples/nbody.hs +87/−0
- examples/primes.hs +76/−0
- examples/primes2.hs +79/−0
- examples/sched_tree.hs +65/−0
- examples/threadring.hs +62/−0
- examples/threadring_onestep.hs +96/−0
- haskell-cnc.cabal +57/−0
- haskell_cnc.h +40/−0
- install_environment_vars.sh +7/−0
- ntimes +136/−0
- ntimes_minmedmax +38/−0
- runAllTests.hs +52/−0
- run_all_examples.sh +208/−0
- runcnc +152/−0
- scaling.hs +333/−0
+ Intel/Cnc.Header.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ #-}+-- Note: PatternSignatures was deprecated after 6.8.+{-# OPTIONS_HADDOCK prune #-}+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}++-- #define DEBUG_HASKELL_CNC++-- This must be defined because the runtime may allow a low+-- probability of duplicating stolen work.+-- #define REPEAT_PUT_ALLOWED++{-|+ 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.+ 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 + implemented by /tag/ and /item/ collections respectively.++ A brief introduction to CnC using this module can be found at <http://software.intel.com/foobar>.+ General documentation on the CnC model can be found at + <http://software.intel.com/en-us/articles/intel-concurrent-collections-for-cc/>.++ -}+#ifndef INCLUDEMETHOD+module MODNAME (+ Step, TagCol, ItemCol,+ -- |The @GraphCode@ monad represents+ -- computations for constructing CnC graphs. + GraphCode,+ -- |The @StepCode@ monad represents computations + -- running inside individual nodes of CnC graphs (in parallel). + StepCode(..), + newItemCol, newTagCol, prescribe, + putt, put, get,+ initialize, finalize,++ runGraph, + stepPutStr, cncPutStr, cncVariant,++ Item, newItem, readItem, putItem,++ tests, +-- * Example Program+{- |++Below is a simple program that prints \"Hello World 99\". Item+collections are indexed by string tags (keys). The CnC graph consists+of one node.++@+myStep items tag =+ do word1 <- 'get' items \"left\"+ word2 <- 'get' items \"right\"+ 'put' items \"result\" (word1 ++ word2 ++ show tag)++cncGraph = + do tags <- 'newTagCol'+ items <- 'newItemCol'+ 'prescribe' tags (mystep items)+ 'initialize' $+ do 'put' items \"left\" \"hello \"+ 'put' items \"right\" \"world \"+ 'putt' tags 99+ 'finalize' $ + do 'get' items \"result\"++main = putStrLn (runGraph cncGraph)+@++ -}+ )+where+#else+#warning "Loading imperative, IO-based CnC implementation."+#endif++{- ++ This is an implementation of CnC based on the IO monad. The+ exposed interface is the same as the pure implementation, and CnC+ computations remain pure.++ This version formulates steps as side-effecting functions on tables+ of MVars (item collections).++ If we had concurrent hashtables, that would be one option. Instead+ we need to use immutable maps stored inside a mutable reference.+ (Course lock to protect hash tables would also be a, probably+ undesirable, option.) +-}++import Data.Set as Set+import Data.HashTable as HT+import Data.Map as Map+import Data.Int+import Data.IORef+import Data.Word+import Data.Typeable+import Control.Monad+import Control.Monad.Trans+import qualified Control.Monad.State.Strict as S +--import qualified Control.Monad.State.Lazy as S +import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Control.Concurrent+--import Control.Exception+import Control.Exception.Extensible+import System.IO.Unsafe+import GHC.IO+import GHC.Conc+import GHC.Prim+import GHC.Exts ++import Test.HUnit++import Intel.CncUtil as GM hiding (tests)++------------------------------------------------------------+-- Configuration Toggles:++#ifdef MEMOIZE+#warning "Memoization enabled"+memoize = True+#else+memoize = False+#endif+++#ifdef HASHTABLE_TEST+#define ITEMPREREQS (Eq tag, Ord tag, Hashable tag, Show tag)+#elif 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++------------------------------------------------------------+-- Type signatures for the primary API operations:++-- |Attach a computation step to a supply of control tags. This adds a new node in the computation graph.+prescribe :: TagCol tag -> Step tag -> GraphCode ()++-- |Put-Tag. Push a control tag out into the computation graph.+#ifdef MEMOIZE+putt :: Ord tag => TagCol tag -> tag -> StepCode ()+#else+putt :: TagCol tag -> tag -> StepCode ()+#endif++-- |Put an item. Subsequently, any steps waiting on the item may subsequently execute.+put :: ITEMPREREQS => ItemCol tag val -> tag -> val -> StepCode ()+-- |Get an item. Synchronous read-data operation.+get :: ITEMPREREQS => ItemCol tag val -> tag -> StepCode val++-- |Run an initial step which populates the CnC graph with input tags and items.+-- Presently only a single initialize is allowed within a graph execution.+initialize :: StepCode a -> GraphCode a+-- |Run a final step which collects outputs of the graph that are of interest to the larger application.+-- Presently only a single finalize is allowed within a graph execution.+finalize :: StepCode a -> GraphCode a++-- |Construct a new tag collection.+newTagCol :: GraphCode (TagCol tag)+-- |Construct a new item collection.+newItemCol :: ITEMPREREQS => GraphCode (ItemCol tag val)++itemsToList :: ITEMPREREQS => ItemCol tag b -> StepCode [(tag,b)]++-- |Steps are functions that take a single 'tag' as input and perform+-- a computation in the "StepCode" monad, which may perform "put"s and "get"s.+type Step a = a -> StepCode ()+++--------------------------------------------------------------------------------+-- 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+newItemCol = GRAPHLIFT newMutableMap+#endif+#ifndef SUPPRESS_newTagCol+newTagCol = do ref1 <- GRAPHLIFT newIORef Set.empty+ ref2 <- GRAPHLIFT newIORef []+ return (ref1, ref2)+#endif++-- Putting items: If it's not there we add the mvar ourselves.+-- +-- [2010.02.15] Made this strict in the item. Otherwise we could+-- unintentionally delay work until the after the (parallel) CnC+-- evaluation and do it in serial!+#ifndef SUPPRESS_put+put col tag (!item) = + do mvar <- STEPLIFT assureMvar col tag + bool <- STEPLIFT tryPutMVar mvar item+#ifdef REPEAT_PUT_ALLOWED+ return ()+#else+ if not bool then error ("Already an item with tag " ++ show tag) else return ()+#endif+#endif++-- A tag collection stores the list of subscribed step collections.+-- To "prescribe", simply add it to the list:+prescribe (_set,_steps) step = + do steps <- GRAPHLIFT readIORef _steps+ GRAPHLIFT writeIORef _steps (step:steps)++-- This encapsulates the book-keeping necessary for a put-tag (putt).+-- It is common to all the scheduler variants below.+-- +-- FIXME: Consider a trampoline. Some schedulers may stack leak.+--proto_putt :: Ord a => ([Step a] -> a -> StepCode b) -> TagCol a -> a -> StepCode b+proto_putt action tc@(_set,_steps) tag = + do set <- STEPLIFT readIORef _set+ steps <- STEPLIFT readIORef _steps+-- if memoize +-- then +#ifdef MEMOIZE+ if Set.member tag set+ then return ()+ else STEPLIFT writeIORef _set (Set.insert tag set)+#else+-- else + return ()+#endif+ action steps tag++#ifndef SUPPRESS_itemsToList+itemsToList ht = + do if not quiescence_support + then error "need to use a scheduler with quiescence support for itemsToList" + else return ()+ ls <- STEPLIFT mmToList ht+ foldM (\ acc (key,mvar) -> + do --putStrLn "Try take mvar..."+ val <- STEPLIFT readMVar mvar+ --putStrLn " Took!"+ return $ (key,val) : acc)+ [] ls+#endif++-- Embed StepCode in the graph construction program:+#ifndef SUPPRESS_initialize+initialize x = x+#endif++-- | 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+runGraph x = unsafePerformIO x+#endif++stepUnsafeIO io = STEPLIFT io+cncUnsafeIO io = GRAPHLIFT io++-- | Print a message within a step (unsafe side effect).+stepPutStr :: String -> StepCode ()+stepPutStr str = stepUnsafeIO (putStr str)+-- | Print a message within the graph construction code (unsafe side effect).+cncPutStr :: String -> GraphCode ()+cncPutStr str = cncUnsafeIO (putStr str)++-- |An informal identifier of the CnC version presently in use (for example, identifying a scheduler implementation).+cncVariant :: String+--cncVariant="io/" ++ show (CNC_SCHEDULER :: Int)++--------------------------------------------------------------------------------+-- Testing+--------------------------------------------------------------------------------++-- Here's a tiny program to run:+incrStep d1 (t2,d2) tag = + do val <- get d1 tag + stepPutStr (" ("++ show tag ++") Incrementing " ++ show val ++"\n")+ put d2 tag (val + 1)+ putt t2 tag++smalltest = testCase "Small test of Cnc model under Cnc.hs" $ + putStrLn ("Final Result: "++ show v)+ where + v = runGraph g+ g = do -- First, allocate collections:+ t1 <- newTagCol+ t2 <- newTagCol+ t3 <- newTagCol+ d1 <- newItemCol+ d2 <- newItemCol+ d3 <- newItemCol++ -- Build and execute the graph:+ prescribe t1 (incrStep d1 (t2,d2))+ prescribe t2 (incrStep d2 (t3,d3))++ -- Start things up: + initialize $ do put d1 'a' 33+ put d1 'b' 100+ putt t1 'b'+ putt t1 'a'++ let incrStep d1 (t2,d2) tag = + do n <- get d1 tag+ put d2 tag (n+1)+ putt t2 tag++ -- Get some of the results:+ finalize $ + do a <- itemsToList d1+ b <- itemsToList d2+ c <- itemsToList d3+ return (a,b,c)++tests :: Test+tests = TestList [ smalltest ]+++--------------------------------------------------------------------------------+-- EXPERIMENTAL:+--------------------------------------------------------------------------------+-- This is a proposed addition for manipulating items outside of item collections.++newItem :: StepCode (Item a)+readItem :: Item a -> StepCode a+putItem :: Item a -> a -> StepCode ()++#if CNC_SCHEDULER != 3 && CNC_SCHEDULER != 5+type Item a = ()+newItem = error "newItem not implemented under this scheduler"+readItem = error "readItem not implemented under this scheduler"+putItem = error "putItem not implemented under this scheduler"+#endif++--------------------------------------------------------------------------------++------------------------------------------------------------+--Version 1: Serial+-- (This version has been disabled/removed.)++-- Version 2: +-- (This version has been disabled/removed.)++-- Here we do the tail call optimization for the common case of a single prescribed step.+++------------------------------------------------------------+-- TODO TODO TODO TODO TODO TODO TODO TODO TODO TODO -- +------------------------------------------------------------++-- [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. ***
+ Intel/Cnc.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ #-}+{-# OPTIONS_HADDOCK prune #-}+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}++#define MODNAME Intel.Cnc++-- This file is simple here to dispatch to the appropriate scheduler implementation.++#ifndef CNC_SCHEDULER+#warning "Cnc.hs -- CNC_SCHEDULER unset, defaulting to scheduler 6 "+#define CNC_SCHEDULER 6+#endif++#if CNC_SCHEDULER == 3+#include "Cnc3.hs"+#elif CNC_SCHEDULER == 5+#include "Cnc5.hs"+#elif CNC_SCHEDULER == 6+#include "Cnc6.hs"+#elif CNC_SCHEDULER == 8+#include "Cnc8.hs"+#else+#error "Cnc.hs -- CNC_SCHEDULER is not set to a support scheduler: {3,4,5,6,8}"+#endif
+ Intel/Cnc3.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ #-}+-- We don't need to lift through a monad transformer for the step or+-- graph monads in this implementation:+#ifndef MODNAME+#define MODNAME Intel.Cnc3+#endif+#define CNC_SCHEDULER 3+#define STEPLIFT id$+#define GRAPHLIFT id$+#include "Cnc.Header.hs"++type TagCol a = (IORef (Set a), IORef [Step a])+type ItemCol a b = MutableMap a b++type StepCode = IO +type GraphCode = IO++------------------------------------------------------------+-- Version 3: Here we try for forked parallelism:+------------------------------------------------------------++putt = proto_putt (\ steps tag -> + case steps of + --[] -> error "putt on tag collection with no prescribed steps"+ steps -> + foldM (\ () step -> do forkIO (step tag); return ())+ () steps+ )++-- We needn't fork a new thread if it's "tail call"+tail_putt :: Ord a => TagCol a -> a -> StepCode ()+tail_putt = proto_putt$ \ steps tag -> + case steps of+ [] -> error "putt on tag collection with no prescribed steps"+ fst:rest -> + do forM_ rest $ \step -> forkIO (step tag)+ fst tag++get col tag = do mvar <- assureMvar col tag + readMVar mvar++-- The above 'putt's use a trivial finalizer:+-- WARNING -- this will not wait for workers to finish during finalization.+-- Therefore, this only works with programs that 'get' their output.+-- E.g. it does not support quiescent completion.+finalize x = x +-- TODO: At least kill off the existing threads here?++quiescence_support=False; +++--------------------------------------------------------------------------------+-- EXPERIMENTAL:+--------------------------------------------------------------------------------+-- This is a proposed addition for manipulating items outside of item collections.++type Item = MVar+newItem = newEmptyMVar+readItem = readMVar+putItem mv x = + do b <- tryPutMVar mv x+ if b then return ()+ else error "Violation of single assignment rule; second put on Item!"
+ Intel/Cnc5.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , CPP+ #-}+-- State monad transformer is needed for both step & graph:+#ifndef MODNAME+#define MODNAME Intel.Cnc5+#endif+#define CNC_SCHEDULER 5+#define STEPLIFT S.lift$+#define GRAPHLIFT S.lift$+#define SUPPRESS_runGraph+#include "Cnc.Header.hs"++------------------------------------------------------------+-- Version 5a: A global work queue.+-- (This version has been disabled/removed.)+-- This version uses a global work-queue.+-- Here laziness comes in handy, we queue the thunks.++#include "shared_5_6.hs"++------------------------------------------------------------+-- Version 5: Thread spammer -- fork a permanent worker every time we block.++-- TODO: we should do a better job here by using a monad transformer on top of IO:+-- But if we must keep the same CnC interface... This is expedient:+ +get col tag = ver5_6_core_get (return ()) col tag++-- At finalize time we set up the workers and run them.+finalize finalAction = + do joiner <- S.lift$ newChan + let worker = + do x <- S.lift$ tryPop global_stack+ case x of + Nothing -> S.lift$ writeChan joiner ()+ Just action -> do action+ worker + ver5_6_core_finalize joiner finalAction worker ++------------------------------------------------------------++quiescence_support = True++type Item = MVar+newItem = STEPLIFT newEmptyMVar+readItem = grabWithBackup (return ())+putItem mv x = + do b <- STEPLIFT tryPutMVar mv x+ if b then return ()+ else error "Violation of single assignment rule; second put on Item!"
+ Intel/Cnc6.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ #-}+-- State monad transformer is needed for both step & graph:+#ifndef MODNAME+#define MODNAME Intel.Cnc6+#endif+#define CNC_SCHEDULER 6+#define STEPLIFT S.lift$+#define GRAPHLIFT S.lift$+#define SUPPRESS_runGraph+#include "Cnc.Header.hs"++------------------------------------------------------------+-- Version 6: Blocking with replacement.++#include "shared_5_6.hs"++-- When a thread goes down (blocks waiting on data) this version+-- regenerates a new thread to replace it. The thread that went down+-- is mortal when it wakes up. It will finish what it was doing and+-- then die.++-- This version is correct but sometimes inefficient. It can have+-- threads terminate prematurely when the program enters a serial+-- bottleneck.+++-- Then at finalize time we set up the workers and run them.+finalize finalAction = + do joiner <- GRAPHLIFT newChan + let worker :: StepCode () = + do x <- STEPLIFT tryPop global_stack+ case x of + Nothing -> STEPLIFT writeChan joiner ()+ Just action -> + do action + myId <- STEPLIFT myThreadId+ set <- STEPLIFT readIORef global_mortalthreads+ if Set.notMember myId set+ then worker -- keep going+ else STEPLIFT writeChan joiner ()+ ver5_6_core_finalize joiner finalAction worker++get col tag = ver5_6_core_get io col tag+ where io = do myId <- myThreadId+ atomicModifyIORef global_mortalthreads (\s -> (Set.insert myId s, ()))++quiescence_support = True+++------------------------------------------------------------+-- Version 7: Now with healing -- bring back worker threads that died+-- prematurely.++-- TODO: Improve on 6 by correcting premature deaths.+
+ Intel/Cnc8.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ #-}+-- State monad transformer is needed for both step & graph:+#ifndef MODNAME+#define MODNAME Intel.Cnc8+#endif+#define CNC_SCHEDULER 8+#define STEPLIFT S.lift$+#define GRAPHLIFT id$+#define SUPPRESS_put+#define SUPPRESS_newItemCol+#define SUPPRESS_initialize+#define SUPPRESS_itemsToList+#include "Cnc.Header.hs"++--------------------------------------------------------------------+-- Version 8: This also uses the GHC scheduler directly (like 3) but+-- it uses sparks rather than forkIO.+--------------------------------------------------------------------++-- Note, the spark pool is lossy and can't be counted on. (It will+-- happily discard sparks when it overflows. In the future it may not+-- even serve as GC roots.)++-- Therefore this version does a litle book-keeping it both sparks a+-- step, and adds the step to a list so that after each step is+-- completed it can "sync" on its children. This this scheduler+-- behaves very much like a Cilk version of CnC.++-- Like Concurrent Collectins for C++, this version uses exceptions to+-- 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])+--type ItemCol a b = MutableMap a b++-- Here the hidden state keeps track of +--newtype StepCode a = StepCode (S.StateT HiddenState8 IO a)+type StepCode a = (S.StateT (HiddenState8) IO a)+type GraphCode = IO++-- The hidden stat stores two things:+-- (1) "Self": the current action, if needed for requeueing.+-- (2) A list of child tasks/thunks that were spawned in parallel.+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)))+type WaitingSteps = [StepCode ()]++data EscapeStep = EscapeStep deriving (Show, Typeable)+instance Exception EscapeStep+--instance GHC.Exception.Exception EscapeStep++--------------------------------------------------------------------------------+-- Misc utility functions used by the version 8 API functions:+--------------------------------------------------------------------------------+liftHidden fn = (\ (HiddenState8 (self,ls)) -> HiddenState8 (self, fn ls))+atomicModifyIORef_ ref fn = atomicModifyIORef ref (\x -> (fn x, ()))++stepStats :: StepCode ()+stepStats = + do + tid <- S.lift myThreadId+ HiddenState8 (_, ls) <- S.get + S.lift$ putStrLn (">>> Step state: list len: "++ show (length ls))++-- This is the high level interface for running several steps in+-- parallel and then blocking on the result.+launch_steps :: [StepCode ()] -> StepCode ()+launch_steps mls = + foldM (\ () m -> spawn (do try_stepcode m m; return ()))+ () mls+++-- This consumes the state thats threaded through step code by capping+-- 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+ -- If data is not ready yet, fizzle:+ wrapped = do x <- try sync_action + case x of Left EscapeStep -> return Nothing + Right v -> return (Just v)+ -- This is a Cilk-like sync. Run the action to accumulate the list of+ -- spawned children-actions. Here we serially execute those children+ -- if they haven't been done in parallel.+ sync_action = + do -- First RUN the step code:+ (v, HiddenState8 (_, ls)) <- S.runStateT m (HiddenState8 (retry,[]))+ tid <- myThreadId+ -- Second, sync all child computations that the step created.+ -- We may be racing to fill these in with other threads.+#ifdef DEBUG_HASKELL_CNC+ putStrLn (">>> "++show tid ++": Syncing children")+#endif+ --return (foldr pseq v ls)+ --return v+ foldr pseq (return v) ls++-- Release an IO action for parallel execution, and squirrel it away+-- so we can sync as well.+spawn :: IO () -> StepCode ()+spawn ioaction = + do -- Add the new action to the list of actions for this step.+ --let thunk = unsafeDupablePerformIO ioaction + let thunk = unsafePerformIO ioaction ++#ifdef DEBUG_HASKELL_CNC+ --let wrapped = unsafeDupablePerformIO$ + let wrapped = unsafePerformIO$ + do { tid <- myThreadId; putStrLn ("\n>>> "++show tid++": STOLE WORK!\n"); pseq thunk (return ()) }+ let parthunk = wrapped+#else + let parthunk = thunk+#endif++ --S.modify $ liftHidden (parthunk:)+ S.modify $ liftHidden (thunk:)+ id <- S.lift$ myThreadId ++#ifdef DEBUG_HASKELL_CNC+ S.lift$ putStrLn $ ">>> "++ show id ++ ": Spawning..."+ stepStats+#endif++ --return (parthunk `par` ())+ parthunk `par` (do +#ifdef DEBUG_HASKELL_CNC+ mid <- S.lift$ myThreadId+ S.lift$putStrLn (">>> "++show mid++" (spawned parallel)") +#endif+ return ())++++--------------------------------------------------------------------------------+-- The core of the version 8 implementation:+--------------------------------------------------------------------------------++newItemCol = do ref <- newIORef Map.empty+ return (ItemCol ref)++putt = proto_putt+ (\ steps tag -> + -- Spark each downstream step, attempting to do it in parallel before a + -- subsequent sync (at the end of the containing step). + launch_steps (Prelude.map (\step -> step tag) steps))++get (ItemCol icol) tag = + do map <- S.lift$ readIORef icol + case Map.lookup tag map of + Nothing -> addquit [] + Just (Nothing, waiting) -> addquit waiting+ Just (Just v, []) -> return v+ Just (Just v, a:b) -> error "CnC: internal invariant violated"+ where + addquit ls = + do (HiddenState8 (retry ,_)) <- S.get+ S.lift$ atomicModifyIORef_ icol (Map.insert tag (Nothing, retry:ls))+ -- After adding ourself to the wait list, jump out of this step:+ throw EscapeStep++initfin :: String -> StepCode a -> GraphCode a+initfin str m = do let err = error str+ x <- try_stepcode err m+ case x of Nothing -> err+ Just v -> return v++initialize = initfin "Get failed within initialize action!"+finalize = initfin "Get failed within finalize action!"+++-- Put must replay any steps that are waiting.+put (ItemCol icol) tag (!item) = + do waiting <- S.lift$ atomicModifyIORef icol mod + launch_steps waiting+ return ()+ where + mod map = + let new = (Just item, [])+ f key _ (Nothing, _) = new+#ifdef REPEAT_PUT_ALLOWED+ f key _ old@(Just v, ls) = old+#else+ f key _ (Just v, _) = error ("Single assignment violated at tag: "++ show tag)+#endif+ (old, map') = Map.insertLookupWithKey f tag new map+ in case old of+ Nothing -> (map', [])+ Just (Nothing, waiting) -> (map', waiting)+#ifdef REPEAT_PUT_ALLOWED+ Just (Just _, waiting) -> (map , waiting)+#else+ Just (Just _, _) -> error ("Single assignment violated at tag: "++ show tag)+#endif++itemsToList (ItemCol icol) = + do if not quiescence_support + then error "need to use a scheduler with quiescence support for itemsToList" + else return ()+ map <- S.lift$ readIORef icol + return $ Prelude.map (\ (key, (Just v, _)) -> (key,v)) + $ Prelude.filter fil + $ (Map.toList map)+ where + fil (key, (Nothing, _)) = False+ fil _ = True+++quiescence_support=True ;++--------------------------------------------------------------------------------+-- Version 9++-- TODO??? Get COULD explicitly capture the continuation to avoid replay from the beginning.++-- Combining continuation monad with IO:+-- import Control.Monad.Cont+-- import System.IO++-- main = do+-- hSetBuffering stdout NoBuffering+-- runContT (callCC askString) reportResult++-- askString :: (String -> ContT () IO String) -> ContT () IO String+-- askString next = do+-- liftIO $ putStrLn "Please enter a string"+-- s <- liftIO $ getLine+-- next s++-- reportResult :: String -> IO ()+-- reportResult s = do+-- putStrLn ("You entered: " ++ s)
+ Intel/CncPure.hs view
@@ -0,0 +1,1082 @@+{-# LANGUAGE ExistentialQuantification+ , ScopedTypeVariables+ , BangPatterns+ , NamedFieldPuns, RecordWildCards+ #-}+{-# OPTIONS_HADDOCK prune #-}+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}++-- |This module is an alternative implementation exposing the same inteface as "Intel.Cnc".+#ifndef INCLUDEMETHOD+module Intel.CncPure(+ Step, TagCol, ItemCol,+ StepCode(..), GraphCode,+ newItemCol, newTagCol, prescribe, + putt, put, get,+ initialize, finalize,++ runGraph, + stepPutStr, cncPutStr, cncVariant,++ tests, + )+ where+#endif++import Data.Array as Array++import Data.List as List+import Data.Set as Set+import Data.Map as Map+import Data.Maybe+import Data.IORef+import qualified Data.IntMap as IntMap+import Data.Word+import Data.Complex++import Control.Concurrent+import GHC.Conc+import Control.Monad+--import System+import Debug.Trace+import Unsafe.Coerce++import Intel.CncUtil hiding (tests)++import System.IO.Unsafe+import System.Random++import Test.HUnit++-- README+------------------------------------------------------------+-- How to do a *PURE* CnC?++-- Well, this is a bit tricky because the a cnc step is a function+-- from a heterogeneous set of collections to a set of new tags and+-- items. We could use various methods:++-- (1) We could require that the user construct a sum-type including+-- all the item types that will occur in their program. (And+-- another for the tag types.)++-- (2) We could use existential types to pack various sorts of output+-- items and tags into one list. Together with an unsafe cast we +-- could build a safe interface into heterogeneous collections.++-- This file implements (2). This is fairly inefficent because our+-- primary representation is a Map of Maps. We have the overhead of+-- that double indirection times the cost of the pure data structures.++-- Below you will see two interfaces, the "raw" functional interface+-- (functions prefixed with "_") and a nicer monadic interface.++------------------------------------------------------------+-- Toggles++-- Should we remember which tags have been invoked?+#ifdef MEMOIZE+#warning "Memoization enabled"+memoize = True+#else+memoize = False+#endif+++#ifndef CNC_SCHEDULER+#warning "CncPure.hs -- CNC_SCHEDULER unset, defaulting to scheduler 2 "+#define CNC_SCHEDULER 2+#endif+++#if CNC_SCHEDULER == 1+scheduler = simpleScheduler+#elif CNC_SCHEDULER == 2+scheduler = betterBlockingScheduler+#elif CNC_SCHEDULER == 3+#warning "Enabling parallel scheduler..."+scheduler = parallelScheduler++#elif CNC_SCHEDULER == 4+scheduler = parSched2++-- #elif CNC_SCHEDULER == 5+--scheduler = distScheduler ++#else+#error "CncPure.hs -- CNC_SCHEDULER is not set to one of {1,2,3}"+#endif++cncVariant = "pure/" ++ show CNC_SCHEDULER+++{- +Notes on Schedulers:++[2009.08.12] {Initial testing of betterBlockingScheduler}+Ok, for the sched_tree.hs test, enabling betterBlockingScheduler slows+it down from 1.19 user (200,000 limit) to 1.26 user. And that's with+no blocking! Just the extra cost of checking to see if there are+blocked steps hanging off of new items.++ primes 100K - makes no difference (heavyweight steps)+ mandel 100 100 1000 - makes no difference (heavyweight)+ threadring_onestepcollection 1M - 3.67 vs 3.6++-}++------------------------------------------------------------+-- Type definitions:++-- The central abstraction is a (heterogeneous) group of item and tag collections.+type Collections = (Int, MatchedTagMap, MatchedItemMap)++data MatchedItemMap = forall a b. MI !(IntMap.IntMap (ItemColInternal a b))+data MatchedTagMap = forall a. MT !(IntMap.IntMap (TagColInternal a))++-- We pass around HANDLES to the real item/tag collections, called "ID"s:+data TagCol a = TCID Int deriving (Ord, Eq, Show)+data ItemCol a b = ICID Int deriving (Ord, Eq, Show)+type TagColInternal a = Set a+type ItemColInternal a b = Map a b++-- A step either produces a batch of new data to write, or blocks:+type Step a = a -> Collections -> StepResult+data StepResult = Done [NewTag] [NewItem]+ | forall a b. (Ord a, Show a) => Block (ItemCol a b) a+data NewTag = forall a. Ord a => NT (TagCol a) a+data NewItem = forall a b. (Ord a,Show a) => NI (ItemCol a b) a b++-- Need it to be a map... but this type is not truly polymorphic enough:+data Graph = forall a. G (IntMap.IntMap [Step a])++------------------------------------------------------------+-- (Optional) type signatures for operations:++-- The raw functional interface:+_newWorld :: Int -> Collections+_newTagCol :: Collections -> (TagCol ma, Collections)+_newItemCol :: Collections -> (ItemCol a b, Collections)++-- These are called by the step code and produce outbound tags and items:+_put :: (Show a,Ord a) => ItemCol a b -> a -> b -> NewItem+_putt :: Ord a => TagCol a -> a -> NewTag+_get :: Ord a => Collections -> ItemCol a b -> a -> Maybe b++_prescribe :: Ord a => TagCol a -> Step a -> Graph -> Graph++--------------------------------------------------------------------------------+-- Implementation:++-- A "world" is a (heterogeneous) set of collections.+-- A world keeps a counter that is used to uniquely name each collection in that world:+_newWorld n = (n, MT IntMap.empty, MI IntMap.empty)+_newTagCol (cnt, MT tags, items) = + (TCID cnt, (cnt+1, MT newtags, items))+ where newtags = IntMap.insert cnt Set.empty tags ++_newItemCol (cnt, tags, MI items) =+ (ICID cnt, (cnt+1, tags, MI newitems))+ where newitems = IntMap.insert cnt Map.empty items++magic :: ItemCol a b -> ItemColInternal c d -> ItemColInternal a b+magic id = (unsafeCoerce)++_get (_, _, MI imap) id tag = + let ICID n = id + badcol = (IntMap.!) imap n+ goodcol = magic id badcol+ in+ case Map.lookup tag goodcol of+ Nothing -> Nothing+ Just d -> Just d++-- INTERNAL USE ONLY: Remove an item from an item collection.+_rem :: Ord a => Collections -> ItemCol a b -> a -> Collections+_rem (cnt,tmap,MI imap) id tag = + let ICID n = id in+ (cnt, tmap,+ MI$ IntMap.adjust + (\col -> moremagic imap $ Map.delete tag (magic id col))+ n imap)+-- MI$ IntMap.insert +-- n (moremagic imap $ Map.delete tag goodcol)+-- imap)++--data MatchedItemMap = forall a b. MI (IntMap.IntMap (ItemColInternal a b))++_put id tag item = NI id tag item -- Just accumulate puts as data+_putt id tag = NT id tag ++moremagic :: IntMap.IntMap (ItemColInternal a b) -> ItemColInternal c d -> ItemColInternal a b+moremagic id = (unsafeCoerce)++tmagic :: TagCol a -> TagColInternal c -> TagColInternal a+tmagic id = (unsafeCoerce)++mostmagic :: IntMap.IntMap (TagColInternal a) -> TagColInternal c -> TagColInternal a+mostmagic id = (unsafeCoerce)+++-- This inserts new items and tags into a Collections object.+-- It also returns a list containing the tags that were actually new.+--+-- This is inefficient in that it looks up the tagCol/itemCol ID for+-- each update. Ideally, steps would produce a more organized+-- "chunked" structure so that we could+--+-- Also, we could optimize this here by optimistically assuming that a+-- batch of updates are likely to the same collection.+--mergeUpdates :: IORef Collections -> [NewTag] -> [NewItem] -> IO ()+mergeUpdates :: [NewTag] -> [NewItem] -> Collections -> (Collections, [NewTag])+mergeUpdates newtags newitems (n, MT tags, MI items) =+ -- SHOULD WE USE a strict foldl' ???+ let items' = foldl (\ acc (NI id k x) -> + let ICID n = id + badcol = (IntMap.!) acc n+ goodcol = magic id badcol+ newcol = moremagic acc $ Map.insert k x goodcol+ in+ IntMap.insert n newcol acc)+ items newitems in+ -- This also keeps track of what tags are new.+ let (tags',fresh) = + foldl (\ (acc,fresh) nt -> + case nt of + NT id k -> + let + TCID n = id + badcol = (IntMap.!) acc n+ goodcol = tmagic id badcol+ newcol = mostmagic acc $ Set.insert k goodcol+ notnew = Set.member k goodcol+ in+ (IntMap.insert n newcol acc, + if notnew then fresh else nt:fresh))+ (tags,[]) newtags in+ if memoize+ then ((n, MT tags', MI items'), fresh)+ else ((n, MT tags, MI items'), newtags)++megamagic :: TagCol a -> IntMap.IntMap [Step b] -> IntMap.IntMap [Step a]+megamagic id col = (unsafeCoerce col)+++emptyGraph = G IntMap.empty+_prescribe id step (G gmap) = + case id of + TCID n ->+ G (IntMap.insertWith (++) n [step] $ megamagic id gmap)++-- Retrieve the steps from a graph:+getSteps :: Graph -> TagCol a -> [Step a]+getSteps (G gmap) id = + case id of + TCID n -> IntMap.findWithDefault [] n (megamagic id gmap)+++-- A "primed" step is one that already has its tag and just needs a Collections:+type PrimedStep = Collections -> StepResult++-- Looks up all the steps associated with a tag and returns a list of+-- ready-to-execute steps, just waiting for a Collections argument.+callSteps :: Graph -> TagCol a -> a -> [PrimedStep]+callSteps (G gmap) id tag = + case id of + TCID n -> Prelude.map (\fn -> fn tag) $ + IntMap.findWithDefault [] n (megamagic id gmap)++--------------------------------------------------------------------------------+-- A simple scheduler. +-- This runs blocked steps naively and only when it runs out of other steps.+-- WARNING: this is not a CORRECT scheduler -- it can loop indefinitely +simpleScheduler :: Graph -> [NewTag] -> Collections -> Collections+simpleScheduler graph inittags cols = schedloop cols [] inittags []+ where -- The scheduler loop takes four arguments:+ -- (1) The world (all collections).+ -- (2) Blocked steps.+ -- (3) New tags to process.+ -- (4) Steps ready to execute.+ schedloop c [] [] [] = c+ schedloop c blocked [] [] = schedloop c [] [] blocked++ schedloop c blocked (hd : tl) [] = + case hd of + NT id tag ->+ schedloop c blocked tl (callSteps graph id tag)++ schedloop c blocked tags (step : tl) = + case step c of+ Block d_id tag -> schedloop c (step:blocked) tags tl+ Done newtags newitems -> + let (c2,fresh) = mergeUpdates newtags newitems c+ in schedloop c2 blocked (fresh++tags) tl++-- Bring an ID into the alternate reality (which stores blocked steps)+magic_to_alternate :: ItemCol a b -> ItemCol a [PrimedStep]+magic_to_alternate id = unsafeCoerce id+++--------------------------------------------------------------------------------+-- We reuse the typing magic of the existing collections mechanism for+-- creating a collection of blocked steps.+betterBlockingScheduler :: Graph -> [NewTag] -> Collections -> Collections+betterBlockingScheduler graph inittags world = schedloop world alternate' inittags []+ where + alternate' = mirrorWorld world ++ schedloop :: Collections -> Collections -> [NewTag] -> [PrimedStep] -> Collections+ schedloop w alternate [] [] = w++ schedloop w alternate (hd : tl) [] = + case hd of + NT id tag ->+ schedloop w alternate tl (callSteps graph id tag)++ schedloop w alternate tags (pstep:tl) = + --trace (case id of TCID n -> " *** Executing tagcol "++ show n ++" tag: "++ show (char tag)) $ + case pstep w of+ Block (d_id) tag -> +#ifdef VERBOSEBLOCKING+ trace (" ... Blocked ... " ++ show (d_id,tag)) $ +#endif+ let alternate' = updateMirror alternate d_id tag pstep + in schedloop w alternate' tags tl++ Done newtags newitems -> + let (w2,fresh) = mergeUpdates newtags newitems w+ -- Check to see if the new items have activated any blocked actions:+ (steps',alternate') = + foldl (\ (acc,alternate) (NI (id) tag _) -> + let (alternate',steps) = mirrorGet alternate id tag in + --trace (" ... REACTIVATED ... " ++ show (id,tag)) $+ (steps++acc, alternate')+ )+ (tl,alternate) newitems+ in schedloop w2 alternate' (fresh++tags) steps'+++--------------------------------------------------------------------------------++-- Parallel scheduler: ++-- The basic idea here is that there's a single copy of the world+-- state. Each worker thread computes some number of steps and lazily+-- tries to push the updates to the global copy. ++-- We have a choice as to the data structure for the global world+-- state -- IORef or MVar.++-- The complication in this approach is blocking steps. By the time a+-- thread commits its output, a step may have blocked on data that has+-- since become available.++-- Unless we use a trickier data structure (some kind of sliding+-- window, storing updates at each "revision number" and processing+-- only the item updates since we last snapshotted the global state)+-- then we need to recheck all new blocked items against the new+-- global state. I don't think we can really amortize this cost by+-- committing less often, because we then have proportinally more+-- blocked items to commit -- each new blocked needs to be looked up+-- against the global state.++-- ==============================================================================+-- Interface for maintaining a mirror of the Collections, including+-- blocked steps rather than items.++-- Duplicate all the ICIDs used in the real world.+-- (We will expect all the entries in the IntMap to be defined.)+-- However, all that's important here is that we initialize the+-- alternate reality with the same NUMBER of item collections.+mirrorWorld :: Collections -> Collections+mirrorWorld world = + case world of + (_,_,MI imap) ->+ -- HACK: we actually need to make ADDITIONAL item+ -- collections to fill in the gaps where tag collections+ -- used up ID numbers. Wouldn't be necessary if+ -- Collections stored two counters...+ foldl (\ w _ -> snd $ _newItemCol w)+ (_newWorld 0) + [0.. foldl max 0 (IntMap.keys imap)]++updateMirror :: (Show a, Ord a) => Collections -> ItemCol a b -> a -> PrimedStep -> Collections+updateMirror mirror d_id tag val = mirror'+ where+ alt_id = magic_to_alternate d_id + others = + case _get mirror alt_id tag of+ Nothing -> []+ Just ls -> ls+ new = _put alt_id tag (val:others)+ (mirror',[]) = mergeUpdates [] [new] mirror++-- Similar but takes a list of Block entries and a list of primed steps:+updateMirrorList mirror bls sls = + case bls of + [] -> mirror+ Block d_id tag : tl -> + updateMirrorList (updateMirror mirror d_id tag (head sls))+ tl (tail sls)++-- Destructive get operation:+mirrorGet mirror id tag =+ let alt_id = magic_to_alternate id in+ case _get mirror alt_id tag of+ Nothing -> (mirror, [])+ Just steps -> (_rem mirror alt_id tag, steps)++------------------------------------------------------------++-- Scan new items against the existing blocked+-- Complexity m * (log n) +-- Would be better asymptotically to intersect maps.+-- (Well, we'd pay when we built up the little map... but that would+-- be, m * log m and presumably m << n.)+-- This function returns:+-- (1) the activated steps and +-- (2) a new collection of blocked-entries with the activated steps removed.+newItemsAgainstBlocked :: [NewItem] -> Collections -> (Collections, [PrimedStep])+newItemsAgainstBlocked newitems mirror = + foldl (\ (mirror,acc) (NI (id) tag _) -> + let alt_id = magic_to_alternate id in+ case _get mirror alt_id tag of+ Nothing -> (mirror,acc)+ --Just [] -> (acc,mirror)+ Just steps -> + -- Remove the blocked steps from the collection:+ trace (" ... REACTIVATED ... " ++ show (alt_id,tag)) $+ (_rem mirror alt_id tag, steps++acc)+ )+ (mirror,[]) newitems+++-- ==============================================================================+-- Scheduler version 3: Now in parallel.++data Bundle a = + B { blocked :: [StepResult]+ , bsteps :: [PrimedStep]+ , intags :: a+ , outtags :: [NewTag]+ , items :: [NewItem]}+ +_GRAIN = 5 ; _NUMTHREADS = numCapabilities+-- _GRAIN = 1 ; _NUMTHREADS = 1+--_GRAIN = 2 ;_NUMTHREADS = 2++-- _NUMTHREADS = numCapabilities++parallelScheduler :: Graph -> [NewTag] -> Collections -> Collections+parallelScheduler graph inittags world = + -- It's safe to be unsafe here!! (If you follow the CnC rules...)+ unsafePerformIO $ + do global_world <- newIORef world+ global_blocked <- newIORef (mirrorWorld world)+ -- How do we split the initial tags up?+ -- Let's split them evenly for now, ignorant of any data locality principles.+ forkJoin $ Prelude.map (threadloop global_world global_blocked []) + $ splitN _NUMTHREADS inittags+ -- Finally, return the quiescent world:+ readIORef global_world+ where + threadloop worldref blockedref primed mytags = + do + -- Snapshot the world:+ world <- readIORef worldref+ -- If the world is stale, we might block unnecessarily.+ let B {blocked, bsteps, intags, outtags, items} = + runSomeSteps graph world _GRAIN + (B {blocked=[], bsteps=[], intags=mytags, outtags=[], items=[]}) + primed++ len <- return $ length bsteps+ -- Now we atomically write back changes to the world:+ fresh <- atomicModifyIORef worldref (mergeUpdates outtags items)++ -- Atomically read blocked and unblock steps as necessary,+ -- extending blocked and returning unblocked steps.+ newprimed <- atomicModifyIORef blockedref+ (\ oldblck -> + -- NEED TO INCORPORATE blckd' into blocked+ let newb = updateMirrorList oldblck blocked bsteps in + newItemsAgainstBlocked items newb)+ if Prelude.null intags && Prelude.null fresh && Prelude.null newprimed+ then return ()+ else threadloop worldref blockedref newprimed (fresh ++ intags)++-- ==============================================================================++-- Here's another variation:++parSched2 :: Graph -> [NewTag] -> Collections -> Collections+parSched2 graph inittags world = + -- It's safe to be unsafe here!! (If you follow the CnC rules...)+ unsafePerformIO $ + do worldref <- newIORef world+ blockedref <- newIORef (mirrorWorld world)++ -- For now work-queues are indeed queues... should be stacks.+ work_queues <- mapM (\_ -> newChan) [1..10]++ -- For fast indexing:+ let queue_arr = listArray (0,length work_queues-1) work_queues++ ------------------------------------------------------------+ let --perms = let p = permutations work_queues in listArray (0,length p - 1) p+ workerthread primed (myid, chan, mytags) = + do putStrLn $ "=== Starting thread "++ show (myid) ++" with "++ show (length mytags) ++" initial tags."+ writeList2Chan chan mytags + threadloop primed + where + -- THIS COULD DEADLOCK!! WE NEED A NONBLOCKING GET!! + -- FIXME: DON'T STEAL FROM OURSELVES!! + trysteal 0 = putStr "Thread giving up and dying...\n"+ trysteal n = + do _i :: Int <- randomIO + let i = _i `mod` _NUMTHREADS+ if myid == i then return () else putStrLn $ " "++ show myid ++" Stealing from " ++ show i+ let q = (Array.!) queue_arr i+ b <- isEmptyChan q+ if b then trysteal (n-1)+ else do x <- readChan q+ putStrLn " <STOLEN>"+ writeChan chan x+ threadloop []++ threadloop primed = + do+ -- Snapshot the world:+ world <- readIORef worldref+ -- If the world is stale, we might block unnecessarily.+ B {blocked, bsteps, outtags, items} <- + runSomeSteps2 graph world _GRAIN chan + (B {blocked=[], bsteps=[], intags=(), outtags=[], items=[]}) + primed++ -- Now we atomically write back changes to the world:+ fresh <- atomicModifyIORef worldref (mergeUpdates outtags items)++ -- Atomically read blocked and unblock steps as necessary,+ -- extending blocked and returning unblocked steps.+ newprimed <- atomicModifyIORef blockedref+ (\ oldblck -> + -- NEED TO INCORPORATE blckd' into blocked+ let newb = updateMirrorList oldblck blocked bsteps in + newItemsAgainstBlocked items newb)++ writeList2Chan chan fresh++ --putStrLn $ "PERMS OF " ++ show (length (work_queues))+ --putStrLn $ "PERMS " ++ show ((permutations work_queues !! 10000))++ -- Are we out of work?+ if List.null newprimed+ then do b <- isEmptyChan chan+ if b then trysteal (_NUMTHREADS * 2)+ else threadloop newprimed+ else threadloop newprimed ++ ------------------------------------------------------------+ -- How do we split the initial tags up?+ -- Let's split them evenly for now, ignorant of any data locality principles.+ forkJoin $ Prelude.map (workerthread []) + $ zip3 [0.. length work_queues] work_queues+ $ splitN _NUMTHREADS inittags+ -- Finally, return the quiescent world:+ readIORef worldref+ +++runSomeSteps2 :: Graph -> Collections -> Int -> Chan NewTag -> Bundle () -> [PrimedStep] -> IO (Bundle ())+runSomeSteps2 g w n c (rec @ B{..}) primed = + case primed of + [] ->+ -- If we're over our limit, we stop even if there's work left.+ -- (But we make sure to finish the already primed steps.)+ if n <= 0 then return rec else+ -- If we run out of (readily available) work we have to stop:+ do b <- isEmptyChan c+ if b then return rec else+ -- In this case we're out of primed steps, but we have more tags.+ -- We prime a batch of new steps (corresponding to the next tag).+ do hd <- readChan c + case hd of + NT id tag ->+ runSomeSteps2 g w n c rec (callSteps g id tag)++ -- In this case we have primed steps and just need to do the real work:+ pstep:tl ->+ case pstep w of+ -- Accumulate blocked tokens:+ newb@(Block _ _) -> + runSomeSteps2 g w (n-1) c + rec{blocked= newb:blocked, bsteps= pstep:bsteps} tl+ -- Alas, we don't know which of these newtags are really+ -- FRESH (seen for the first time) until we merge it back+ -- into the global world state.+ Done newtags newitems ->+ runSomeSteps2 g w (n-1) c+ rec{outtags=newtags++outtags, items=newitems++items} tl+++-- ==============================================================================+-- Scheduler version 5: Local world copies.++-- UNFINISHED?++-- This version is an intermediate step towards a distributed version.+-- Each thread maintains its own picture of the world.++-- Communication is via a gossip protocol.+-- In this prototype version, every thread maintains a channel with+-- every other. However, we have a great deal of leeway wrt the+-- communication organization here. We could, for example, try to+-- coelesce updates in various ways... The trick will be versioning+-- the updates and suppressing duplicates.++-- Initial tags are split evenly. Work stealing balances load+-- subsquently. The trickiest part here is managing duplicated work.++--distScheduler :: Graph -> [NewTag] -> Collections -> Collections+distScheduler graph inittags world = + -- It's safe to be unsafe here!! (If you follow the CnC rules...)+ unsafePerformIO $ + -- Open up a comm channel for every pair of workers:++ do chans <- sequence + [ sequence [ do c <- newChan; return (i,j,c) + | j <- [1.. _NUMTHREADS], not(i == j) ] + | i <- [1.. _NUMTHREADS] ]+-- do chans <- sequence [ do c <- newChan; return (i,j,c) | +-- i <- [1.. _NUMTHREADS], +-- j <- [1.. _NUMTHREADS], +-- not(i == j) ]++ -- How do we split the initial tags up?+ -- Let's split them evenly for now, ignorant of any data locality principles.+ forkJoin $ Prelude.map + (\ (ch,tags) -> + let (my_i,_,_):_ = ch + myinbound = List.filter (\ (_,j,_) -> j == my_i)+ $ concat chans+ third (_,_,x) = x+ thirds = List.map third+ in threadloop world (mirrorWorld world) + (thirds ch) (thirds myinbound) [] tags)+ $ zip chans+ -- zip (List.groupBy (\ (a,b,_) (x,_) -> a==x) chans)+ $ splitN _NUMTHREADS inittags+ -- Finally, return the quiescent world:+ --readIORef global_world+ return chans+ where + threadloop world bworld outchans inchans primed mytags = + do + --worldref <- newIORef world+ --blockedref <- newIORef (mirrorWorld world)+ --let mirror = mirrorWorld world++ -- Receive updates from other workers:+ world2 <-+ foldM (\ w c -> do b <- isEmptyChan c+ if b then return w+ else return w+ )+ world inchans++ -- If the world is stale, we might block unnecessarily.+ let B {blocked, bsteps, intags, outtags, items} = + runSomeSteps graph world _GRAIN + (B {blocked=[], bsteps=[], intags=mytags, outtags=[], items=[]})+ primed+ world2 = mergeUpdates outtags items + newb = updateMirrorList bworld blocked bsteps + bworld2 = newItemsAgainstBlocked items newb++ -- Send updates to other workers:+ mapM_ (\_ -> return () ) outchans+{-++ -- Atomically read blocked and unblock steps as necessary,+ -- extending blocked and returning unblocked steps.+++ if Prelude.null intags && Prelude.null fresh && Prelude.null newprimed+ then putStr "EMPTIED\n"+ else threadloop worldref blockedref newprimed (fresh ++ intags)+-}+ return undefined++--------------------------------------------------------------------------------+-- Run some steps, accumulate output, and then return to synchronize/schedule.+--------------------------------------------------------------------------------++-- The big question is how many actions we should run before we+-- stop and commit. Perhaps we should determine some heuristic+-- that would serve here. One example heuristic would be that+-- we could check realtime every time that we come back to+-- commit and dynamically adjust the number of actions so that+-- we don't come back to commit too often.++-- There are several additional choices in terms of how we+-- commit the output of a worker thread. ++-- First, if we batch up output items without committing them+-- to the local copy of the world, then subsequent steps we+-- perform within a thread (before committing) will not be able+-- to see those items and will block unnecessarily. We can+-- live with this problem, but it will create trouble on+-- "depth-first" style problems---ones where the thread could+-- go ahead as far as it likes using only local data. There+-- are a couple solutions to the problem:+ +-- (1) If we commit to the local world, then we would need to+-- do a full merge of the local & global worlds. ++-- (2) We could build up the new items as a Map (rather than+-- a list), and modify get so that it always checks the local+-- item collection before the (snapshot of) the global one.++-- For now, however, we just live with the problem:++runSomeSteps :: Graph -> Collections -> Int -> Bundle [NewTag] -> [PrimedStep] -> Bundle [NewTag]++-- If we run out of work we have to stop:+runSomeSteps _ _ n (rec @ B{intags=[]}) [] = rec+--trace ("Out of work.. stopping blocked: "++ show (length blocked)) $ +--(blocked,bsteps,[],items)++-- If we're over our limit, we stop even if there's work left.+-- (But we make sure to finish the already primed steps.)+runSomeSteps _ _ n bundle [] | n <= 0 = bundle+ +-- In this case we're out of primed steps, but we have more tags.+-- We prime a batch of new steps (corresponding to the next tag).+runSomeSteps graph w n (rec @ B{intags = hd:tl}) [] = + case hd of + NT id tag ->+ runSomeSteps graph w n rec{intags=tl} (callSteps graph id tag)++-- Here's where we do the real work, execute the next primed step:+runSomeSteps g w n (rec @ B{..}) (pstep:tl) = + -- INVOKE THE STEP!+ case pstep w of+ -- Accumulate blocked tokens:+ newb@(Block _ _) -> + runSomeSteps g w (n-1) + rec{blocked= newb:blocked, bsteps= pstep:bsteps} tl++ -- Alas, we don't know which of these newtags are really+ -- FRESH (seen for the first time) until we merge it back+ -- into the global world state.+ Done newtags newitems ->+ runSomeSteps g w (n-1) + rec{outtags=newtags++outtags, items=newitems++items} tl+++--------------------------------------------------------------------------------+-- Common interface for interoperability:++-- The StepCode monad carries forward a state (newtags, newitems) and+-- blocks on a failed get.+data StepCode a = CC (Collections -> [NewTag] -> [NewItem] -> (Maybe a, StepResult))+-- [2010.05.03] Could probably do this with a state and exception monad transformers.++-- Currently ONE GRAPH context implicit in the monad (could do many):+-- GraphCode threads through the Collections and Graph values:+data GraphCode a = GC (Collections -> Graph -> [NewTag] -> (Collections, Graph, [NewTag], a))++++newTagCol :: GraphCode (TagCol a)+newItemCol :: GraphCode (ItemCol a b)++-- The monadic interface +put :: (Show a, Ord a) => ItemCol a b -> a -> b -> StepCode ()+get :: (Show a, Ord a) => ItemCol a b -> a -> StepCode b+putt :: Ord a => TagCol a -> a -> StepCode ()++-- StepCode accumulates a list of new items/tags without committing them to the Collections.+instance Monad StepCode where + return x = CC$ \w nt ni -> (Just x, Done nt ni)+ -- Bind catches blocks and threads the state through:+ (CC ma) >>= f = CC$ \w nt ni -> + case ma w nt ni of + (_, Block ic t) -> (Nothing, Block ic t)+ (Just a, Done nt' ni') -> let CC mb = f a + in mb w nt' ni'+get col tag = CC $+ \ w tags items -> + case _get w col tag of + Nothing -> (Nothing, Block col tag)+ Just x -> (Just x, Done tags items)++put col tag val = CC $ + \ w tags items -> + (Just (), Done tags (_put col tag val : items))++putt col tag = CC $ + \ w tags items -> + (Just (), Done (_putt col tag : tags) items)+++-- The graph monad captures code that builds graphs:+instance Monad GraphCode where + return x = GC$ \ w g it -> (w,g,it, x)+ (GC ma) >>= f = + GC $ \w g itags -> + let (w',g',it',a) = ma w g itags+ GC mb = f a+ in mb w' g' it'+ +newTagCol = + GC$ \(cnt, MT tags, items) graph inittags -> + let newtags = IntMap.insert cnt Set.empty tags in+ ((cnt+1, MT newtags, items), + graph, inittags,TCID cnt)++newItemCol = + GC$ \(cnt, tags, MI items) graph inittags -> + let newitems = IntMap.insert cnt Map.empty items in+ ((cnt+1, tags, MI newitems), + graph, inittags, ICID cnt)++prescribe :: Ord a => TagCol a -> (a -> StepCode ()) -> GraphCode ()+--prescribe tc step = +prescribe tc stepcode = + GC$ \ cols graph inittags -> + (cols,+ _prescribe tc + (\a w -> + let CC fn = stepcode a + (_,result) = fn w [] []+ in result)+ graph,+ inittags, ()) ++-- Initialize runs StepCode but does not invoke the scheduler.+-- You should not do any 'gets' inside this StepCode.+-- New tags introduced are accumulated as "inittags":+initialize :: StepCode a -> GraphCode a+initialize (CC fn) = + GC$ \w graph inittags -> + case fn w inittags [] of + -- This commits the new tags/items to the Collections+ (Just x, Done nt ni) -> + --seq (unsafePerformIO $ putStrLn $ show (" initializing", length nt, length ni)) $+ let (w2,[]) = mergeUpdates [] ni w+ in (w2, graph, nt, x)+ (Nothing, Block itemcol tag) ->+ error ("Tried to run initialization StepCode within the GraphCode monad but it blocked!: "+ ++ show (itemcol, tag))++-- Execute is like init except that it invokes the scheduler.+-- Any tags already in the collection are taken to be "unexecuted"+-- and make up the inittags argument to the scheduler.+-- +-- NOTE: The current philosophy is that the scheduler runs until+-- nothing is blocking. Thus the finalize action won't need to block.+-- A different method would be to only run the scheduler just enough+-- to satisfy the finalize action. That would be nice.+finalize :: StepCode a -> GraphCode a+finalize (CC fn) = + GC$ \w graph inittags -> + case w of + (_, MT tmap, _) -> + let finalworld = scheduler graph inittags w in+ -- After the scheduler is done executing, then when run the final action:+ case fn finalworld [] [] of + (Just x, Done [] []) -> (finalworld, graph, [], x)+ (Just _, Done _ _) -> error "It isn't proper for a finalize action to produce new tags/items!"+ (Nothing, Block itemcol tag) ->+ error ("Tried to run finalization StepCode but it blocked!: "+ ++ show (itemcol, tag))++-- Run a complete CnC graph and get a final result.+runGraph :: GraphCode a -> a+runGraph (GC fn) = x+ where (_,_,_,x) = fn (_newWorld 0) emptyGraph []+++gcPrintWorld :: String -> GraphCode ()+gcPrintWorld str =+ GC$ \w g it -> + case w of + (n, MT tmap, MI imap) ->+ seq (unsafePerformIO $+ do putStr "GraphCode - Printing world: "+ putStrLn str+ putStrLn (" "++ show (IntMap.size tmap) ++" tag collections "+++ show (IntMap.size imap) ++" item collections")+ mapM (\key -> + let m = IntMap.findWithDefault (error "shouldn't happen") key tmap in+ putStrLn (" Tag col "++ show key ++" size "++ show (Set.size m)))+ (IntMap.keys tmap)++ mapM (\key -> + let m = IntMap.findWithDefault (error "shouldn't happen") key imap in+ putStrLn (" Item col "++ show key ++" size "++ show (Map.size m)))+ (IntMap.keys imap)+ )+ (w,g,it,())+ +-- show (n, IntMap.size tmap, IntMap.keys imap, +-- Map.keys foo, +-- Map.elems foo)+++-- cncPutStr :: String -> GraphCode ()+-- cncPutStr str = +-- GC$ \w g it -> +-- seq (unsafePerformIO (putStr str))+-- (w,g,it,())++-- stepPutStr :: String -> StepCode ()+-- stepPutStr str =+-- CC$ \w nt ni -> +-- seq (unsafePerformIO (putStr str))+-- (Just (), Done nt ni)++-- -- For debugging we have print messages lifted into the CnC monads.+-- stepPutStr' :: String -> StepCode ()+-- stepPutStr' msg = +-- CC$ \w nt ni -> trace msg (Just (), Done nt ni)++cncUnsafeIO :: IO () -> GraphCode ()+cncUnsafeIO action = + GC$ \w g it -> + seq (unsafePerformIO action)+ (w,g,it,())++stepUnsafeIO :: IO () -> StepCode ()+stepUnsafeIO action = + CC$ \w nt ni -> + seq (unsafePerformIO action)+ (Just (), Done nt ni)++stepPutStr str = stepUnsafeIO (putStr str)+cncPutStr str = cncUnsafeIO (putStr str)+++finalmagic :: ItemCol a b -> [(c,d)] -> [(a,b)]+finalmagic id ls = unsafeCoerce ls++itemsToList :: ItemCol a b -> StepCode [(a,b)]+itemsToList id = + CC $ \w tags items -> + case w of + (_, _, MI imap) ->+ let ICID num = id + it = (IntMap.!) imap num+ in (Just (finalmagic id (Map.toList it)),+ Done tags items)++--------------------------------------------------------------------------------+-- Testing:+--------------------------------------------------------------------------------+++type TI = TagCol Char+type II = ItemCol Char Int+incrStep :: II -> (TI, II) -> Step Char+incrStep d1 (t2,d2) tag c = + case _get c d1 tag of + Nothing -> Block d1 tag+ Just n -> Done [_putt t2 tag]+ [_put d2 tag (n+1)]++-- Test using the function interface directly:+test1 = TestCase $ + -- Allocate collections:+ let w0 = _newWorld 0+ (t1,w2) = _newTagCol w0+ (t2,w3) = _newTagCol w2+ (t3,w4) = _newTagCol w3+ (d1,w5) = _newItemCol w4+ (d2,w6) = _newItemCol w5+ (d3,w7) = _newItemCol w6+ + -- Initialize:+ (w8,[]) = mergeUpdates [] [_put d1 'a' 33, + _put d1 'b' 100] w7++ graph = _prescribe t1 (incrStep d1 (t2,d2)) $+ _prescribe t2 (incrStep d2 (t3,d3)) $+ emptyGraph++ inittags = [_putt t1 'b', _putt t1 'a']++ w9 = scheduler graph inittags w8++ in + do putStrLn $ ""+ putStrLn $ showcol w9+ putStrLn $ " d1: " ++ show (_get w9 d1 'a', _get w9 d1 'b') + putStrLn $ " d2: " ++ show (_get w9 d2 'a', _get w9 d2 'b') + putStrLn $ " d3: " ++ show (_get w9 d3 'a', _get w9 d3 'b') + return ()++-- Same test using wrappers: +test2 = TestCase $ + let v = runGraph $ do+ t1 <- newTagCol+ t2 <- newTagCol+ t3 <- newTagCol+ d1 <- newItemCol+ d2 <- newItemCol+ d3 <- newItemCol+ + initialize $ do stepPutStr "\n"+ put d1 'a' 33+ put d1 'b' 100+ putt t1 'b'+ putt t1 'a'++ let incrStep d1 (t2,d2) tag = + do n <- get d1 tag+ put d2 tag (n+1)+ putt t2 tag++ prescribe t1 (incrStep d1 (t2,d2))+ prescribe t2 (incrStep d2 (t3,d3))++ gcPrintWorld "Initialization finished"++ -- Get some of the results:+ finalize $ + do a <- itemsToList d1+ b <- itemsToList d2+ c <- itemsToList d3+ return (a,b,c)+ + in putStrLn ("Final: "++ show v)++showcol (n, MT tmap, MI imap) =+ show (n, IntMap.size tmap, IntMap.keys imap, + Map.keys foo, + Map.elems foo)+ where + -- Hack -- pull out the first item collection:+ foo = (unsafeCoerce $ (IntMap.!) imap 3) :: ItemColInternal Char Int++--------------------------------------------------------------------------------++tests = TestList [test1, test2]
+ Intel/CncUtil.hs view
@@ -0,0 +1,611 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , TypeFamilies + , UndecidableInstances+ , OverlappingInstances+ , MultiParamTypeClasses+ #-}+{-# OPTIONS_HADDOCK hide #-}+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}++-- |An internal utility module that supports the CnC implementations.+#ifndef INCLUDEMETHOD+module Intel.CncUtil (+ foldRange, for_, splitN, forkJoin, + doTrials, FitInWord (..), + GMapKey (..), + Hashable (..),+ (!),+ testCase,+ tests,++ MutableMap, newMutableMap, assureMvar, mmToList,+ HotVar, newHotVar, modifyHotVar, modifyHotVar_,++ )+where+#endif++import GHC.Conc+import Control.Concurrent+import Data.Time.Clock -- Not in 6.10+import qualified Data.Map as DM+import qualified Data.IntMap as DI+import qualified Data.List as L+import Prelude hiding (lookup)+import Data.Char (ord,chr)+import Data.Word+import Data.Int+import Data.Bits+import Data.IORef+import qualified Data.HashTable as HT+import Debug.Trace++import Test.HUnit+import Test.QuickCheck (quickCheck, (==>))++--------------------------------------------------------------------------------+-- Miscellaneous Utilities+--------------------------------------------------------------------------------++-- |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.+foldRange start end acc fn = loop start acc+ where+ loop !i !acc+ | i == end = acc+ | otherwise = loop (i+1) (fn acc i)++-- |My own forM, again, less trusting of optimizations.+-- Inclusive start, exclusive end.+for_ start end fn | start > end = error "for_: start is greater than end"+for_ start end fn = loop start + where + loop !i | i == end = return ()+ | otherwise = do fn i; loop (i+1) ++-- |Split a list into N pieces (not evenly sized if N does not divide+-- the length of the list).+splitN :: Int -> [a] -> [[a]]+splitN n ls | n <= 0 = error "Cannot split list by a factor of 0"+splitN n ls = loop n ls+ where + sz = length ls `quot` n+ loop 1 ls = [ls]+ loop n ls = hd : loop (n-1) tl+ where (hd,tl) = splitAt sz ls++++-- |Run IO threads in parallel and wait till they're done.+forkJoin actions = +-- I'm amazed this is not built-in.+ do joiner <- newChan + mapM (\a -> forkIO (do a; writeChan joiner ())) actions+ mapM_ (\_ -> readChan joiner) actions+ return ()++t = forkJoin [putStrLn "foo", putStrLn "bar", putStrLn "baz"]+++-- |Run a test and time it.+doTrials trials mnd = + sequence_ $ take trials $ repeat $ + do putStrLn "------------------------------------------------------------"+ strt <- getCurrentTime+ --start <- getCPUTime+ mnd+ --end <- getCPUTime+ end <- getCurrentTime+ let diff = (diffUTCTime end strt)+ --let diff = fromIntegral (end-start) / (10.0 ^ 12)+ putStrLn$ show diff ++ " real time consumed"+++--------------------------------------------------------------------------------+-- Mutable Maps. +--------------------------------------------------------------------------------+-- Abstract over the shared mutable data structure used+-- for item collections (in the IO-based Cnc.hs)++#ifdef HASHTABLE_TEST+type MutableMap a b = HashTable a (MVar b)+newMutableMap :: (Eq tag, Hashable tag) => IO (MutableMap tag b)+newMutableMap = HT.new (==) hash+assureMvar col tag = + do mayb <- HT.lookup col tag+ case mayb of + Nothing -> do mvar <- newEmptyMVar+ HT.insert col tag mvar+ return mvar+ Just mvar -> return mvar+mmToList = HT.toList+#warning "Enabling HashTable item collections. These are not truly thread safe (yet)."++#elif USE_GMAP+#warning "Using experimental indexed type family GMap implementation..."+-- Trying to use GMaps:+type MutableMap a b = IORef (GMap a (MVar b))+newMutableMap :: (GMapKey tag) => IO (MutableMap tag b)+newMutableMap = newIORef empty+assureMvar col tag = + do map <- readIORef col+ case lookup tag map of + Nothing -> do mvar <- newEmptyMVar+ atomicModifyIORef col + (\mp -> + let altered = alter + (\mv -> + case mv of+ Nothing -> Just mvar+ Just mv -> Just mv)+ tag mp + -- Might be able to optimize this somehow...+ in (altered, (!) altered tag))+ Just mvar -> return mvar+mmToList col = + do map <- readIORef col + return (toList map)+#else+-- A Data.Map based version:+-- Can probably get rid of this once we build a little confidence with GMap:+type MutableMap a b = IORef (DM.Map a (MVar b))+newMutableMap :: (Ord tag) => IO (MutableMap tag b)+newMutableMap = newIORef DM.empty+assureMvar col tag = + do map <- readIORef col+ case DM.lookup tag map of + Nothing -> do mvar <- newEmptyMVar+ atomicModifyIORef col + (\mp -> + let altered = DM.alter + (\mv -> + case mv of+ Nothing -> Just mvar+ Just mv -> Just mv)+ tag mp + -- Might be able to optimize this somehow...+ in (altered, (DM.!) altered tag))+ Just mvar -> return mvar+mmToList col = + do map <- readIORef col + return (DM.toList map)+#endif++------------------------------------------------------------+-- Hot Atomic Words operations+------------------------------------------------------------++-- In this library we abuse individual words of memory with many+-- concurrent, atomic operations. In Haskell, there are three choices+-- for these: IORef, MVars, and STVars.++-- We want to experiment with all three of these. ++#define HOTVAR 1+newHotVar :: a -> IO (HotVar a)+modifyHotVar :: HotVar a -> (a -> (a,b)) -> IO b+modifyHotVar_ :: HotVar a -> (a -> a) -> IO ()++#if HOTVAR == 1+type HotVar a = IORef a+newHotVar = newIORef+modifyHotVar = atomicModifyIORef+modifyHotVar_ v fn = atomicModifyIORef v (\a -> (fn a, ()))++#elif HOTVAR == 2 +#warning "Using MVars for hot atomic variables."+type HotVar a = MVar a+newHotVar = newMVar+modifyHotVar v fn = modifyMVar v (return . fn)+modifyHotVar_ v fn = modifyMVar_ v (return . fn)++#elif HOTVAR == 3+#warning "Using TVars for hot atomic variables."+-- Simon Marlow said he saw better scaling with TVars (surprise to me):+type HotVar a = TVar a+newHotVar = newTVarIO+modifyHotVar tv fn = atomically (do x <- readTVar tv + let (x2,b) = fn x+ writeTVar tv x2+ return b)+modifyHotVar_ tv fn = atomically (do x <- readTVar tv; writeTVar tv (fn x))+#endif++++--------------------------------------------------------------------------------+-- Class of types which are hashable.+--------------------------------------------------------------------------------++-- TODO: Might as well replace this by the Data.Hash module on cabal.++class Hashable a where+ hash :: a -> Int32++instance Hashable Bool where+ hash True = 1+ hash False = 0++instance Hashable Int where+ hash = HT.hashInt+instance Hashable Char where+ hash = HT.hashInt . fromEnum +instance Hashable Word16 where+ hash = HT.hashInt . fromIntegral+--instance Hashable String where -- Needs -XTypeSynonymInstances +instance Hashable [Char] where+ hash = HT.hashString+instance (Hashable a, Hashable b) => Hashable (a,b) where + hash (a,b) = hash a + hash b++instance Hashable a => Hashable [a] where+ hash [] = 0 + hash (h:t) = hash h + hash t++-- Needs -fallow-undecidable-instances:+-- instance Integral t => Hashable t where+-- hash n = hashInt (fromInteger (toInteger n))+-- instance Enum a => Hashable a where+-- hash = hashInt . fromEnum +++++--------------------------------------------------------------------------------+-- Class of types that fit in a machine word.+--------------------------------------------------------------------------------++-- |All datatypes that can be packed into a single word, including+-- scalars and some tuple types.+class FitInWord v where + toWord :: v -> Word+ fromWord :: Word -> v++intToWord :: Int -> Word+intToWord = fromIntegral++wordToInt :: Word -> Int+wordToInt = fromIntegral ++instance FitInWord Char where+ toWord = intToWord . ord+ fromWord = chr . wordToInt++instance FitInWord Int where+ toWord = fromIntegral+ fromWord = fromIntegral++instance FitInWord Int16 where+ toWord = fromIntegral+ fromWord = fromIntegral++instance FitInWord Int8 where+ toWord = fromIntegral+ fromWord = fromIntegral++instance FitInWord Word8 where+ toWord = fromIntegral+ fromWord = fromIntegral++instance FitInWord Word16 where+ toWord = fromIntegral+ fromWord = fromIntegral+++#ifdef x86_64_HOST_ARCH+instance FitInWord Int64 where+ toWord = fromIntegral+ fromWord = fromIntegral+instance FitInWord Word64 where+ toWord = fromIntegral+ fromWord = fromIntegral+#endif++-- Pairs can fit in words too!+-- 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)++++--------------------------------------------------------------------------------+-- ADT definition for generic Maps:+--------------------------------------------------------------------------------++-- |Class for generic map key types. By using indexed type families,+-- |each key type may correspond to a different data structure that+-- |implements it.+class (Ord k, Eq k, Show k) => GMapKey k where+ data GMap k :: * -> *+ empty :: GMap k v+ lookup :: k -> GMap k v -> Maybe v+ insert :: k -> v -> GMap k v -> GMap k v+ alter :: (Maybe a -> Maybe a) -> k -> GMap k a -> GMap k a+ toList :: GMap k a -> [(k,a)]++--------------------------------------------------------------------------------++#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 = 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)+ alter fn k (GMapInt m) = GMapInt (DI.alter fn (wordToInt$ toWord k) m)+ toList (GMapInt m) = map (\ (i,v) -> (fromWord$ intToWord i, v)) $ + DI.toList m+++#else++-- CODE DUPLICATION+instance GMapKey Char where+ data GMap Char v = GMapChar (GMap Int v) deriving Show+ empty = GMapChar empty+ lookup k (GMapChar m) = lookup (ord k) m+ insert k v (GMapChar m) = GMapChar (insert (ord k) v m)+ alter fn k (GMapChar m) = GMapChar (alter fn (ord k) m)+ toList (GMapChar m) = map (\ (i,v) -> (chr i,v)) (toList m)++instance GMapKey Word8 where+ data GMap Word8 v = GMapWord8 (GMap Int v) deriving Show+ empty = GMapWord8 empty+ lookup k (GMapWord8 m) = lookup (fromIntegral k) m+ insert k v (GMapWord8 m) = GMapWord8 (insert (fromIntegral k) v m)+ alter fn k (GMapWord8 m) = GMapWord8 (alter fn (fromIntegral k) m)+ toList (GMapWord8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)++instance GMapKey Word16 where+ data GMap Word16 v = GMapWord16 (GMap Int v) deriving Show+ empty = GMapWord16 empty+ lookup k (GMapWord16 m) = lookup (fromIntegral k) m+ insert k v (GMapWord16 m) = GMapWord16 (insert (fromIntegral k) v m)+ alter fn k (GMapWord16 m) = GMapWord16 (alter fn (fromIntegral k) m)+ toList (GMapWord16 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)++instance GMapKey Word where+ data GMap Word v = GMapWord (GMap Int v) deriving Show+ empty = GMapWord empty+ lookup k (GMapWord m) = lookup (fromIntegral k) m+ insert k v (GMapWord m) = GMapWord (insert (fromIntegral k) v m)+ 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+ lookup k (GMapInt8 m) = lookup (fromIntegral k) m+ insert k v (GMapInt8 m) = GMapInt8 (insert (fromIntegral k) v m)+ alter fn k (GMapInt8 m) = GMapInt8 (alter fn (fromIntegral k) m)+ toList (GMapInt8 m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)++instance GMapKey Int16 where+ data GMap Int16 v = GMapInt16 (GMap Int v) deriving Show+ empty = GMapInt16 empty+ lookup k (GMapInt16 m) = lookup (fromIntegral k) m+ insert k v (GMapInt16 m) = GMapInt16 (insert (fromIntegral k) v m)+ alter fn k (GMapInt16 m) = GMapInt16 (alter fn (fromIntegral k) m)+ 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+++--------------------------------------------------------------------------------+++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+ 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+ Just gm2 -> insert a (insert b v gm2 ) gm+ alter fn (a, b) (GMapPair gm) = GMapPair $ alter newfun a gm+ where + newfun entry =+ case entry of + Nothing -> case fn Nothing of + Nothing -> Nothing+ Just v -> Just $ insert b v empty+ Just m -> Just$ alter fn b m++ toList (GMapPair gm) = L.foldl' (\ acc (a,m) -> map (\ (b,v) -> ((a,b),v)) (toList m) ++ acc) [] $ + toList gm+{-+-- Here's a traditional Data.Map implementation:+instance (Ord a, Ord b) => GMapKey (a, b) where+ newtype GMap (a, b) v = GMapPair (DM.Map (a,b) v)+ empty = GMapPair DM.empty+ lookup pr (GMapPair gm) = DM.lookup pr gm+ insert pr v (GMapPair gm) = GMapPair $ DM.insert pr v gm+-}++-- -- Here's a traditional Data.Map implementation:+-- instance (Ord a, Ord b) => GMapKey (a, b) where+-- empty = DM.empty+-- lookup = DM.lookup+-- insert = DM.insert++-- |Sum types are represented by separate GMaps for the separate variants.+instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where+ data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)+ empty = GMapEither empty empty+ lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1+ lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2+ insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2+ insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2)+ alter fn (Left a) (GMapEither gm1 gm2) = GMapEither (alter fn a gm1) gm2+ alter fn (Right b) (GMapEither gm1 gm2) = GMapEither gm1 (alter fn b gm2)+ toList (GMapEither gm1 gm2) = + map (\ (a,v) -> (Left a, v)) (toList gm1) ++ + map (\ (b,v) -> (Right b, v)) (toList gm2)++-- |GMaps with list indices could be treated like tuples (nested+-- |maps). Instead, we put them in a regular Data.Map.+instance (GMapKey a) => GMapKey [a] where+ data GMap [a] v = GMapList (DM.Map [a] v) deriving Show+ empty = GMapList DM.empty+ lookup k (GMapList m) = DM.lookup k m+ insert k v (GMapList m) = GMapList (DM.insert k v m)+ alter fn k (GMapList m) = GMapList (DM.alter fn k m)+ toList (GMapList m) = DM.toList m+ +++(!) :: (GMapKey k) => GMap k v -> k -> v+(!) m k = + case lookup k m of+ Nothing -> error "GMap (!) operator failed, element was not present."+ Just x -> x+++myGMap :: GMap (Int, Either Char ()) String+myGMap = insert (5, Left 'c') "(5, Left 'c')" $+ insert (4, Right ()) "(4, Right ())" $+ insert (5, Right ()) "This is the one!" $+ insert (5, Right ()) "This is the two!" $+ insert (6, Right ()) "(6, Right ())" $+ insert (5, Left 'a') "(5, Left 'a')" $+ empty++intMap :: GMap Int String+intMap = insert 3 "Entry 3" $+ insert 4 "(4, Right ())" $+ empty+--------------------------------------------------------------------------------+-- Experimental: trying to parameterize by both key and value type and+-- thereby use things like Judy arrays.+-- We also switch to a mutable data structure here:+--------------------------------------------------------------------------------++-- A key/value pair that works inside a GMap2.+class GMapKeyVal k v where+ data GMap2 k v :: *+ empty2 :: IO (GMap2 k v)+ lookup2 :: k -> GMap2 k v -> IO (Maybe v)+ insert2 :: k -> v -> GMap2 k v -> IO ()++-- instance GMapKeyVal Int Int where+-- data GMap2 Int Int = GMapInt2 (DI.IntMap Int) deriving Show+-- empty2 = GMapInt2 DI.empty+-- lookup2 k (GMapInt2 m) = DI.lookup k m+-- insert2 k v (GMapInt2 m) = GMapInt2 (DI.insert k v m)++-- instance (FitInWord k, FitInWord v) => GMapKeyVal k v where+-- data GMap2 k v = GMapInt2 (DI.IntMap v) deriving Show+-- empty2 = GMapInt2 DI.empty+-- lookup2 k (GMapInt2 m) = DI.lookup (wordToInt $ toWord k) m+-- insert2 k v (GMapInt2 m) = GMapInt2 (DI.insert (wordToInt $ toWord k) v m)+++-- [2010.05.19] TEMPTOGGLE uncommenting to compile on laptop:+{-+instance FitInWord t => J.JE t where+ toWord = undefined+ fromWord = undefined++-- If we know a little more, use the Judy version:+instance (FitInWord k, J.JE v) => GMapKeyVal k v where+ data GMap2 k v = GMapInt2 (J.JudyL v) + empty2 = do x <- J.new + return $ GMapInt2 x+ lookup2 = undefined+ insert2 = undefined+ -- empty2 = do x <- J.new+ -- return $ GMapInt2 x+ -- lookup2 k (GMapInt2 r) = do m <- readIORef r+ -- return$ DI.lookup (wordToInt $ toWord k) m+ -- insert2 k v (GMapInt2 r) = modifyIORef r (DI.insert (wordToInt $ toWord k) v)+-}++++-- Otherwise this is the Data.IntMap version+-- instance (FitInWord k) => GMapKeyVal k v where+-- data GMap2 k v = GMapInt2 (IORef (DI.IntMap v)) +-- empty2 = do x <- newIORef DI.empty+-- return $ GMapInt2 x+-- lookup2 k (GMapInt2 r) = do m <- readIORef r+-- return$ DI.lookup (wordToInt $ toWord k) m+-- insert2 k v (GMapInt2 r) = modifyIORef r (DI.insert (wordToInt $ toWord k) v)+++++test1gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap+test2gmap = putStrLn $ maybe "Couldn't find key!" id $ lookup 3 intMap++-- There's a problem with quickcheck where it doesn't+-- newline-terminate the "Cases: N" report message.+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]
@@ -0,0 +1,140 @@++-- Pieces that are common to version 5 and 6+------------------------------------------------------------++type TagCol a = (IORef (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+-- stack used for this graph.+type StepCode a = (S.StateT (HiddenState5) IO a)++-- In this version we need to thread the state through the graph code as well:+type GraphCode a = StepCode a++-- Here the hidden state keeps four things:+-- (1) the stack used for this graph+-- (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 (), Set ThreadId)+ deriving Show++instance Show (IORef a) where + show ref = "<ioref>"+instance Show (IO a) where + show ref = "<io>"++atomicIncr x = atomicModifyIORef x (\n -> (n+1, ()))+atomicDecr x = atomicModifyIORef x (\n -> (n-1, ()))+++-- This will be one hot IORef:+global_stack :: HotVar [StepCode ()]+global_stack = unsafePerformIO (newHotVar [])++global_numworkers :: IORef Int+global_numworkers = unsafePerformIO (newIORef 0)++-- A computation that forks a new worker thread:+global_makeworker :: IORef (IO ())+global_makeworker = unsafePerformIO$ newIORef (return ())+++-- This is a bit silly, this emulates "thread local storage" to let+-- each worker thread know whether it is recursive (True) or "oneshot".+global_mortalthreads :: IORef (Set ThreadId)+global_mortalthreads = unsafePerformIO (newIORef Set.empty)+++-- A simple stack interface:+----------------------------------------+push :: HotVar [a] -> a -> IO ()+tryPop :: HotVar [a] -> IO (Maybe a)+push stack val = modifyHotVar_ stack (val:)+tryPop stack = modifyHotVar stack tryfirst+ where + tryfirst [] = ([], Nothing)+ tryfirst (a:b) = (b, Just a)+----------------------------------------++++-- FIXME: [2010.05.05] I believe this has a problem.+-- tryTakeMVar can fail spuriously if there's a collision with another+-- thread reading the mvar. This is a sense in which mvars CANNOT+-- mimick IVars (at least ivars with the ability to test for presence+-- -- a monotonic test!)++-- This should only be a performance bug (forks an extra task for no+-- good reason). When the code below falls back to readMVar that+-- should succeed.++issueReplacement = + do STEPLIFT atomicIncr global_numworkers+ -- If this were CPS then we would just give our+ -- continuation to the forked thread. Alas, no.+ makeworker <- STEPLIFT readIORef global_makeworker+ STEPLIFT forkIO makeworker++grabWithBackup hook mvar =+ do hopeful <- STEPLIFT tryTakeMVar mvar+ case hopeful of + Just v -> do STEPLIFT putMVar mvar v -- put it back where we found it+ return v+ -- Otherwise, no data. If we block our own thread, we need to issue a replacement.+ Nothing -> do issueReplacement+ + STEPLIFT hook -- Any IO action can go here...+#ifdef DEBUG_HASKELL_CNC+ STEPLIFT putStrLn $ " >>> Blocked on "++ show tag ++"||| "+#endif+ STEPLIFT readMVar mvar+++ver5_6_core_get hook (col) tag = + do --(HiddenState5 (stack, numworkers, makeworker, _)) <- S.get+ mvar <- STEPLIFT assureMvar col tag + grabWithBackup hook mvar++--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, makeworker, _)) <- S.get+ state <- S.get + let makeworker = do S.runStateT worker state; return ()+ S.lift$ writeIORef global_makeworker makeworker+ S.lift$ atomicModifyIORef global_numworkers (\n -> (n + numCapabilities, ()))+ -- Fork one worker per thread:+#ifdef DEBUG_HASKELL_CNC+ S.lift$ putStrLn$ "Forking "++ show numCapabilities ++" threads"+#endif+ S.lift$ mapM (\n -> forkIO makeworker) [0..numCapabilities-1]++ -- This waits for quiescense:+ let waitloop = do num <- readIORef global_numworkers+ if num == 0+ then return () + else do +#ifdef DEBUG_HASKELL_CNC+ putStrLn ("=== Waiting on workers: "++ show num ++" left")+#endif+ readChan joiner+ atomicDecr global_numworkers+ waitloop+ S.lift$ waitloop+ finalAction+++putt = proto_putt+ (\ steps tag -> + do --(HiddenState5 (stack, numworkers, makeworker, _)) <- S.get+ foldM (\ () step -> S.lift$ push global_stack (step tag))+ () steps)++runGraph x = unsafePerformIO (runState x)+runState x =+ do hv <- newHotVar []+ hv2 <- newHotVar 0+ (a,_) <- S.runStateT x (HiddenState5 (hv,hv2, undefined, Set.empty))+ return a
+ LICENSE view
@@ -0,0 +1,502 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 2.1, February 1999++ Copyright (C) 1991, 1999 Free Software Foundation, Inc.+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++[This is the first released version of the Lesser GPL. It also counts+ as the successor of the GNU Library Public License, version 2, hence+ the version number 2.1.]++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+Licenses are intended to guarantee your freedom to share and change+free software--to make sure the software is free for all its users.++ This license, the Lesser General Public License, applies to some+specially designated software packages--typically libraries--of the+Free Software Foundation and other authors who decide to use it. You+can use it too, but we suggest you first think carefully about whether+this license or the ordinary General Public License is the better+strategy to use in any particular case, based on the explanations below.++ When we speak of free software, we are referring to freedom of use,+not price. Our General Public Licenses are designed to make sure that+you have the freedom to distribute copies of free software (and charge+for this service if you wish); that you receive source code or can get+it if you want it; that you can change the software and use pieces of+it in new free programs; and that you are informed that you can do+these things.++ To protect your rights, we need to make restrictions that forbid+distributors to deny you these rights or to ask you to surrender these+rights. These restrictions translate to certain responsibilities for+you if you distribute copies of the library or if you modify it.++ For example, if you distribute copies of the library, whether gratis+or for a fee, you must give the recipients all the rights that we gave+you. You must make sure that they, too, receive or can get the source+code. If you link other code with the library, you must provide+complete object files to the recipients, so that they can relink them+with the library after making changes to the library and recompiling+it. And you must show them these terms so they know their rights.++ We protect your rights with a two-step method: (1) we copyright the+library, and (2) we offer you this license, which gives you legal+permission to copy, distribute and/or modify the library.++ To protect each distributor, we want to make it very clear that+there is no warranty for the free library. Also, if the library is+modified by someone else and passed on, the recipients should know+that what they have is not the original version, so that the original+author's reputation will not be affected by problems that might be+introduced by others.++ Finally, software patents pose a constant threat to the existence of+any free program. We wish to make sure that a company cannot+effectively restrict the users of a free program by obtaining a+restrictive license from a patent holder. Therefore, we insist that+any patent license obtained for a version of the library must be+consistent with the full freedom of use specified in this license.++ Most GNU software, including some libraries, is covered by the+ordinary GNU General Public License. This license, the GNU Lesser+General Public License, applies to certain designated libraries, and+is quite different from the ordinary General Public License. We use+this license for certain libraries in order to permit linking those+libraries into non-free programs.++ When a program is linked with a library, whether statically or using+a shared library, the combination of the two is legally speaking a+combined work, a derivative of the original library. The ordinary+General Public License therefore permits such linking only if the+entire combination fits its criteria of freedom. The Lesser General+Public License permits more lax criteria for linking other code with+the library.++ We call this license the "Lesser" General Public License because it+does Less to protect the user's freedom than the ordinary General+Public License. It also provides other free software developers Less+of an advantage over competing non-free programs. These disadvantages+are the reason we use the ordinary General Public License for many+libraries. However, the Lesser license provides advantages in certain+special circumstances.++ For example, on rare occasions, there may be a special need to+encourage the widest possible use of a certain library, so that it becomes+a de-facto standard. To achieve this, non-free programs must be+allowed to use the library. A more frequent case is that a free+library does the same job as widely used non-free libraries. In this+case, there is little to gain by limiting the free library to free+software only, so we use the Lesser General Public License.++ In other cases, permission to use a particular library in non-free+programs enables a greater number of people to use a large body of+free software. For example, permission to use the GNU C Library in+non-free programs enables many more people to use the whole GNU+operating system, as well as its variant, the GNU/Linux operating+system.++ Although the Lesser General Public License is Less protective of the+users' freedom, it does ensure that the user of a program that is+linked with the Library has the freedom and the wherewithal to run+that program using a modified version of the Library.++ The precise terms and conditions for copying, distribution and+modification follow. Pay close attention to the difference between a+"work based on the library" and a "work that uses the library". The+former contains code derived from the library, whereas the latter must+be combined with the library in order to run.++ GNU LESSER GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License Agreement applies to any software library or other+program which contains a notice placed by the copyright holder or+other authorized party saying it may be distributed under the terms of+this Lesser General Public License (also called "this License").+Each licensee is addressed as "you".++ A "library" means a collection of software functions and/or data+prepared so as to be conveniently linked with application programs+(which use some of those functions and data) to form executables.++ The "Library", below, refers to any such software library or work+which has been distributed under these terms. A "work based on the+Library" means either the Library or any derivative work under+copyright law: that is to say, a work containing the Library or a+portion of it, either verbatim or with modifications and/or translated+straightforwardly into another language. (Hereinafter, translation is+included without limitation in the term "modification".)++ "Source code" for a work means the preferred form of the work for+making modifications to it. For a library, complete source code means+all the source code for all modules it contains, plus any associated+interface definition files, plus the scripts used to control compilation+and installation of the library.++ Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running a program using the Library is not restricted, and output from+such a program is covered only if its contents constitute a work based+on the Library (independent of the use of the Library in a tool for+writing it). Whether that is true depends on what the Library does+and what the program that uses the Library does.++ 1. You may copy and distribute verbatim copies of the Library's+complete source code as you receive it, in any medium, provided that+you conspicuously and appropriately publish on each copy an+appropriate copyright notice and disclaimer of warranty; keep intact+all the notices that refer to this License and to the absence of any+warranty; and distribute a copy of this License along with the+Library.++ You may charge a fee for the physical act of transferring a copy,+and you may at your option offer warranty protection in exchange for a+fee.++ 2. You may modify your copy or copies of the Library or any portion+of it, thus forming a work based on the Library, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) The modified work must itself be a software library.++ b) You must cause the files modified to carry prominent notices+ stating that you changed the files and the date of any change.++ c) You must cause the whole of the work to be licensed at no+ charge to all third parties under the terms of this License.++ d) If a facility in the modified Library refers to a function or a+ table of data to be supplied by an application program that uses+ the facility, other than as an argument passed when the facility+ is invoked, then you must make a good faith effort to ensure that,+ in the event an application does not supply such function or+ table, the facility still operates, and performs whatever part of+ its purpose remains meaningful.++ (For example, a function in a library to compute square roots has+ a purpose that is entirely well-defined independent of the+ application. Therefore, Subsection 2d requires that any+ application-supplied function or table used by this function must+ be optional: if the application does not supply it, the square+ root function must still compute square roots.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Library,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Library, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote+it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Library.++In addition, mere aggregation of another work not based on the Library+with the Library (or with a work based on the Library) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may opt to apply the terms of the ordinary GNU General Public+License instead of this License to a given copy of the Library. To do+this, you must alter all the notices that refer to this License, so+that they refer to the ordinary GNU General Public License, version 2,+instead of to this License. (If a newer version than version 2 of the+ordinary GNU General Public License has appeared, then you can specify+that version instead if you wish.) Do not make any other change in+these notices.++ Once this change is made in a given copy, it is irreversible for+that copy, so the ordinary GNU General Public License applies to all+subsequent copies and derivative works made from that copy.++ This option is useful when you wish to copy part of the code of+the Library into a program that is not a library.++ 4. You may copy and distribute the Library (or a portion or+derivative of it, under Section 2) in object code or executable form+under the terms of Sections 1 and 2 above provided that you accompany+it with the complete corresponding machine-readable source code, which+must be distributed under the terms of Sections 1 and 2 above on a+medium customarily used for software interchange.++ If distribution of object code is made by offering access to copy+from a designated place, then offering equivalent access to copy the+source code from the same place satisfies the requirement to+distribute the source code, even though third parties are not+compelled to copy the source along with the object code.++ 5. A program that contains no derivative of any portion of the+Library, but is designed to work with the Library by being compiled or+linked with it, is called a "work that uses the Library". Such a+work, in isolation, is not a derivative work of the Library, and+therefore falls outside the scope of this License.++ However, linking a "work that uses the Library" with the Library+creates an executable that is a derivative of the Library (because it+contains portions of the Library), rather than a "work that uses the+library". The executable is therefore covered by this License.+Section 6 states terms for distribution of such executables.++ When a "work that uses the Library" uses material from a header file+that is part of the Library, the object code for the work may be a+derivative work of the Library even though the source code is not.+Whether this is true is especially significant if the work can be+linked without the Library, or if the work is itself a library. The+threshold for this to be true is not precisely defined by law.++ If such an object file uses only numerical parameters, data+structure layouts and accessors, and small macros and small inline+functions (ten lines or less in length), then the use of the object+file is unrestricted, regardless of whether it is legally a derivative+work. (Executables containing this object code plus portions of the+Library will still fall under Section 6.)++ Otherwise, if the work is a derivative of the Library, you may+distribute the object code for the work under the terms of Section 6.+Any executables containing that work also fall under Section 6,+whether or not they are linked directly with the Library itself.++ 6. As an exception to the Sections above, you may also combine or+link a "work that uses the Library" with the Library to produce a+work containing portions of the Library, and distribute that work+under terms of your choice, provided that the terms permit+modification of the work for the customer's own use and reverse+engineering for debugging such modifications.++ You must give prominent notice with each copy of the work that the+Library is used in it and that the Library and its use are covered by+this License. You must supply a copy of this License. If the work+during execution displays copyright notices, you must include the+copyright notice for the Library among them, as well as a reference+directing the user to the copy of this License. Also, you must do one+of these things:++ a) Accompany the work with the complete corresponding+ machine-readable source code for the Library including whatever+ changes were used in the work (which must be distributed under+ Sections 1 and 2 above); and, if the work is an executable linked+ with the Library, with the complete machine-readable "work that+ uses the Library", as object code and/or source code, so that the+ user can modify the Library and then relink to produce a modified+ executable containing the modified Library. (It is understood+ that the user who changes the contents of definitions files in the+ Library will not necessarily be able to recompile the application+ to use the modified definitions.)++ b) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (1) uses at run time a+ copy of the library already present on the user's computer system,+ rather than copying library functions into the executable, and (2)+ will operate properly with a modified version of the library, if+ the user installs one, as long as the modified version is+ interface-compatible with the version that the work was made with.++ c) Accompany the work with a written offer, valid for at+ least three years, to give the same user the materials+ specified in Subsection 6a, above, for a charge no more+ than the cost of performing this distribution.++ d) If distribution of the work is made by offering access to copy+ from a designated place, offer equivalent access to copy the above+ specified materials from the same place.++ e) Verify that the user has already received a copy of these+ materials or that you have already sent this user a copy.++ For an executable, the required form of the "work that uses the+Library" must include any data and utility programs needed for+reproducing the executable from it. However, as a special exception,+the materials to be distributed need not include anything that is+normally distributed (in either source or binary form) with the major+components (compiler, kernel, and so on) of the operating system on+which the executable runs, unless that component itself accompanies+the executable.++ It may happen that this requirement contradicts the license+restrictions of other proprietary libraries that do not normally+accompany the operating system. Such a contradiction means you cannot+use both them and the Library together in an executable that you+distribute.++ 7. You may place library facilities that are a work based on the+Library side-by-side in a single library together with other library+facilities not covered by this License, and distribute such a combined+library, provided that the separate distribution of the work based on+the Library and of the other library facilities is otherwise+permitted, and provided that you do these two things:++ a) Accompany the combined library with a copy of the same work+ based on the Library, uncombined with any other library+ facilities. This must be distributed under the terms of the+ Sections above.++ b) Give prominent notice with the combined library of the fact+ that part of it is a work based on the Library, and explaining+ where to find the accompanying uncombined form of the same work.++ 8. You may not copy, modify, sublicense, link with, or distribute+the Library except as expressly provided under this License. Any+attempt otherwise to copy, modify, sublicense, link with, or+distribute the Library is void, and will automatically terminate your+rights under this License. However, parties who have received copies,+or rights, from you under this License will not have their licenses+terminated so long as such parties remain in full compliance.++ 9. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Library or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Library (or any work based on the+Library), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Library or works based on it.++ 10. Each time you redistribute the Library (or any work based on the+Library), the recipient automatically receives a license from the+original licensor to copy, distribute, link with or modify the Library+subject to these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties with+this License.++ 11. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Library at all. For example, if a patent+license would not permit royalty-free redistribution of the Library by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Library.++If any portion of this section is held invalid or unenforceable under any+particular circumstance, the balance of the section is intended to apply,+and the section as a whole is intended to apply in other circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 12. If the distribution and/or use of the Library is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Library under this License may add+an explicit geographical distribution limitation excluding those countries,+so that distribution is permitted only in or among countries not thus+excluded. In such case, this License incorporates the limitation as if+written in the body of this License.++ 13. The Free Software Foundation may publish revised and/or new+versions of the Lesser General Public License from time to time.+Such new versions will be similar in spirit to the present version,+but may differ in detail to address new problems or concerns.++Each version is given a distinguishing version number. If the Library+specifies a version number of this License which applies to it and+"any later version", you have the option of following the terms and+conditions either of that version or of any later version published by+the Free Software Foundation. If the Library does not specify a+license version number, you may choose any version ever published by+the Free Software Foundation.++ 14. If you wish to incorporate parts of the Library into other free+programs whose distribution conditions are incompatible with these,+write to the author to ask for permission. For software which is+copyrighted by the Free Software Foundation, write to the Free+Software Foundation; we sometimes make exceptions for this. Our+decision will be guided by the two goals of preserving the free status+of all derivatives of our free software and of promoting the sharing+and reuse of software generally.++ NO WARRANTY++ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH+DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Libraries++ If you develop a new library, and you want it to be of the greatest+possible use to the public, we recommend making it free software that+everyone can redistribute and change. You can do so by permitting+redistribution under these terms (or, alternatively, under the terms of the+ordinary General Public License).++ To apply these terms, attach the following notices to the library. It is+safest to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least the+"copyright" line and a pointer to where the full notice is found.++ <one line to give the library's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Lesser General Public+ License as published by the Free Software Foundation; either+ version 2.1 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Lesser General Public License for more details.++ You should have received a copy of the GNU Lesser General Public+ License along with this library; if not, write to the Free Software+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA++Also add information on how to contact you by electronic and paper mail.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the library, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.++ <signature of Ty Coon>, 1 April 1990+ Ty Coon, President of Vice++That's all there is to it!
+ Makefile view
@@ -0,0 +1,52 @@+++# PARGHCOPTS=-feager-blackholing++default: + # This target builds CnC as precompiled modules:+ # Pick default schedulers as well:+ ghc --make -c -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs+ ghc --make -c -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs++all:+ cabal configure+ cabal build+ cabal haddock+ ./Setup.hs test++interact:+ ghci -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs++interactio:+ ghci -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs++test: + 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+# LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh &> /dev/stdout | tee all_tests.log++distro: pkg +pkg:+ ./build_distro.sh++wc:+ cloc --by-file $(FILES)+ wc $(FILES)+++DOCBASE=html_doc++doc: + mkdir -p $(DOCBASE)/url/Intel/+ ls Intel/*.hs | xargs -i HsColour -html {} -ohtml_doc/url/{}+ haddock --source-base=url/ --source-module=url/%F -o html_doc -html --optghc -cpp Intel/Cnc.hs Intel/CncPure.hs+++clean:+ rm -f Intel/*.o Intel/*.hi Intel/*~ + (cd examples; $(MAKE) clean)++distclean: clean+ rm -rf distro_20*
+ README.txt view
@@ -0,0 +1,77 @@+++ Intel Concurrent Collections for Haskell+ ----------------------------------------+ Author: Ryan Newton, Copyright 2009-2010+++This directory contains an implementation of the Intel Concurrent+Collections programming model (CnC) for Haskell. It works only with+GHC.++If you are looking in this directory, you are probably not using this+package through cabal. Currently, it contains a Makefile and other+scripts that are redundant with the cabal file and will be removed in+the future.++Quick Start:+-----------------------------------------+ On Unix(ish) systems with a Bash shell, try this:++ source install_environment_vars.sh+ runcnc examples/primes.hs++You can also rerun the primes executable directly after that+(primes.exe). To run with a particular number of threads, say 8, try:+ ./primes.exe +RTS -N8++++------------------------------------------------------------+Installing Haskell CnC +------------------------------------------------------------++ cabal install haskell-cnc++------------------------------------------------------------a+Running Haskell CnC, Method (1): Normal method.+------------------------------------------------------------++CnC for Haskell can be used as a regular Haskell module. +Look at "hello_world.hs" in the examples directory.+++------------------------------------------------------------+Running Haskell CnC, Method (2): Inlined library.+------------------------------------------------------------++For testing purposes, Haskell CnC can inline the library and enable+the user to choose between different scheduling options and runtime+parameters statically. Under this methodology the "runcnc" script is+used to compile and execute CnC programs. The following environment+variable must be set:++ HASKELLCNC -- should be set to the install directory.+ (Sourcing install_environment_vars.sh is one way to+ accomplish this.)+++Preprocessor variables:++ MEMOIZE Turns on memoization of steps over tags.+ This is frequently done on a per-program basis using+ "#define MEMOIZE".++ REPEAT_PUT_ALLOWED + Are multiple put's into an item collection with+ the same tag valid or an error? ++ CNC_VARIANT Which implementation? 'pure' or 'io'?+ CNC_SCHEDULER Which scheduler within that implementation? (1-N)+ These can also be set as environment variables when using+ runcnc.++ INCLUDEMETHOD+ ignore this, it's internal and is used for switching + between schedulers-as-modules or schedulers-as-includes+
+ Setup.hs view
@@ -0,0 +1,24 @@+#!/usr/bin/env runhaskell++import Distribution.Simple+import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo +import System.Cmd(system) +import System.Exit++--main = defaultMainWithHooks simpleUserHooks+-- --defaultUserHooks++--main = defaultMainWithHooks hooks+-- where hooks = simpleUserHooks { runTests = runTests' }++--import Intel.Cnc++main :: IO () +main = do putStrLn$ "Running Setup.hs ..."+ defaultMainWithHooks (simpleUserHooks {runTests = myTests}) ++myTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +myTests _ _ _ _ = do code <- system "./dist/build/runAllTests/runAllTests" + exitWith code+
+ default_opt_settings.sh view
@@ -0,0 +1,14 @@++# This file is sourced by both runcnc and run_all_tests++# This represents a set of default compile-time and run-time options+# for GHC that are used for all benchmarks.++# -fvia-C+#GHC_DEFAULT_FLAGS=" -fasm -O2"+#GHC_DEFAULT_FLAGS=" -rtsopts -O2"+GHC_DEFAULT_FLAGS=" -O2"++ # Affinity is pretty much always good.+GHC_DEFAULT_RTS=" -qa " +
+ examples/embarrassingly_par.hs view
@@ -0,0 +1,88 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++-- Embarassingly parallel.+-- If this doesn't get a speedup nothing will!++-- Note: This program is an example of a CnC Haskell program that+-- depends on "put" being strict. If it were not the real work would+-- be deferred until after the parallel computation is finished!++import GHC.Conc+import Debug.Trace+import Control.Monad+import System.Environment+import Intel.CncUtil++import qualified Control.Monad.State.Strict as S ++#include <haskell_cnc.h> ++-- Compute sum_n(1/n)+work :: Int -> Int -> Double -> Double+work offset 0 n = n+work offset (!i) (!n) = work offset (i-1) (n + 1 / fromIntegral (i+offset))++runit total = runGraph graph `pseq` return ()+ where+ oneshare = total `quot` numCapabilities+ mystep items jid =+ do +#if CNC_VARIANT == 1+ let tid = -99+#elif CNC_SCHEDULER == 8 || CNC_SCHEDULER == 5 || CNC_SCHEDULER == 6+ tid <- S.lift$ myThreadId +#else+ tid <- myThreadId +#endif+ stepPutStr (show tid++" job "++show jid++": About to do big work ("++ show oneshare ++" iterations)...\n")+ let res = work (oneshare * jid) oneshare 0.0+ --tid2 <- S.lift$ myThreadId + stepPutStr (show tid++" job "++show jid++": done with work (result "++ show res ++"), putting item...\n")+ put items jid res+ graph = + do items <- newItemCol+ tags <- newTagCol+ cncPutStr$ "Running embarassingly parallel benchmark. CnC Variant: "++ show cncVariant ++"\n"+ prescribe tags (mystep items)+ initialize $ + do stepPutStr$ "Begin initialize. Splitting work into "++show numCapabilities++" pieces\n"+ forM_ [0 .. numCapabilities-1] (putt tags) + stepPutStr "Done initializing.\n"+ finalize $ + do stepPutStr "About to block on output:\n"+ final <- + foldM (\ acc i -> + do stepPutStr$ " Retrieving output "++ show i ++": "+ n <- get items i+ stepPutStr$ show n ++ "\n"+ return (acc + n)) + 0.0 [0 .. numCapabilities-1]+ stepPutStr$ "Final Output: " ++ show final ++"\n"+++main = do args <- getArgs + loop args+ where + loop args = + case args of + [] -> runit $ 50*1000*1000+ [n] -> runit $ round (10 ** read n)+ [trials, n] -> doTrials (read trials) (loop [n])
+ examples/fib.hs view
@@ -0,0 +1,50 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+++import System.Environment+import Data.Int+import Intel.CncUtil++#include "haskell_cnc.h"+++run n = runGraph $ + do tags :: TagCol Int <- newTagCol+ items :: ItemCol Int Int64 <- newItemCol+ prescribe tags $ \i -> + do x <- get items (i-1)+ y <- get items (i-2)+ put items i (x+y)+ initialize $ + do put items 0 0 + put items 1 1 + for_ 2 (n+1) (putt tags)+ --forM_ [2..n] (putt tags)+ --forM_ (reverse [2..n]) (putt tags)+ finalize $ + do get items n+++main = do args <- getArgs + putStrLn $ show $ + case args of + [] -> run 10+ [s] -> run (read s)+
+ examples/hello_world.hs view
@@ -0,0 +1,45 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++-- #include <haskell_cnc.h>++-- This demonstrates the normal (NOT #include) method of loading CnC:+import Intel.Cnc++-- Here's an odd little hello world where we communicate the two words+-- to a computational step which puts them together.++myStep items tag =+ do word1 <- get items "left"+ word2 <- get items "right"+ put items "result" (word1 ++ word2 ++ show tag)++cncGraph = + do tags <- newTagCol+ items <- newItemCol+ prescribe tags (myStep items)+ initialize$ + do put items "left" "Hello "+ put items "right" "World "+ putt tags 99+ finalize$ + do get items "result"++main = putStrLn (runGraph cncGraph)
+ examples/mandel.hs view
@@ -0,0 +1,87 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++import Data.Complex+import Data.Word+import System.Environment++-- #define MEMOIZE+#include <haskell_cnc.h>++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)++type Pair = (Word16, Word16)++mandelProg :: Int -> Int -> Int -> GraphCode Int+mandelProg max_row max_col max_depth = + do position :: TagCol Pair <- newTagCol+ dat :: ItemCol Pair (Complex Double) <- newItemCol+ pixel :: ItemCol Pair Int <- newItemCol+ + let mandelStep tag = + do cplx <- get dat tag+ put pixel tag (mandel max_depth cplx)++ prescribe position mandelStep ++-- gcPrintWorld "1"+ initialize $ + for_ 0 max_row $ \i -> + for_ 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+ + 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 = + let check = runGraph $ mandelProg a b c in+ putStrLn ("Mandel check " ++ show check)++main = do args <- getArgs + case args of+ [] -> runMandel 3 3 3 -- Should output 24.+ [a,b,c] -> runMandel (read a) (read b) (read c)
+ examples/nbody.hs view
@@ -0,0 +1,87 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+{-# LANGUAGE ExistentialQuantification+ , ScopedTypeVariables+ , BangPatterns+ , NamedFieldPuns + , RecordWildCards+ , FlexibleInstances+ , DeriveDataTypeable+ #-}++-- Author: Chih-Ping Chen++-- This program uses CnC to calculate the accelerations of the bodies in a 3D system. + +import System.Environment+import Data.Int+import Intel.CncUtil+import Data.List++#include "haskell_cnc.h"++-- This step generates the bodies in the system.+genVectors vectors tag = + do put vectors tag (tag' * 1.0, tag' * 0.2, tag' * 30.0)+ where tag' = fromIntegral tag++-- This step computes the accelerations of the bodies. +compute vectors accels n tag =+ do vecList <- sequence (List.map (get vectors) [1..n])+ vector <- get vectors tag+ put accels tag (accel vector vecList)+ where accel vector vecList = multTriple g $ sumTriples $ List.map (pairWiseAccel vector) vecList+ pairWiseAccel (x,y,z) (x',y',z') = let dx = x'-x+ dy = y'-y+ dz = z'-z+ eps = 0.005+ distanceSq = dx^2 + dy^2 + dz^2 + eps+ factor = 1/sqrt(distanceSq ^ 3)+ in multTriple factor (dx,dy,dz)+ sumTriples = foldr (\(x,y,z) (x',y',z') -> (x+x',y+y',z+z')) (0,0,0)+ multTriple c (x,y,z) = (c*x,c*y,c*z)+ g = 9.8++-- This describes the graph-- The same tag collection prescribes the two step collections. +run n = runGraph $ + do tags <- newTagCol+ vectors <- newItemCol+ accels <- newItemCol+ prescribe tags (genVectors vectors)+ prescribe tags (compute vectors accels n)+ initialize $+ do sequence_ (List.map (putt tags) [1..n])+ finalize $ + do stepPutStr "Begin finalize action.\n"+ vecList <- itemsToList vectors+ accList <- itemsToList accels+ return (vecList, accList)++main = + do args <- getArgs + let (vecList, accList) = case args of + [] -> run 3+ [s] -> run (read s)+ --putStrLn $ show vecList; putStrLn $ show accList;+ -- Do a meaningless sum to generate a small output:+ --putStrLn $ show (foldl (\sum (_,(x,y,z)) -> sum + x+y+z) 0 vecList)+ --putStrLn $ show (foldl (\sum (_,(x,y,z)) -> sum + x+y+z) 0 accList)+ putStrLn $ show (foldl (\sum (_,(x,y,z)) -> if x>0.1 then sum+1 else sum) 0 vecList)+ putStrLn $ show (foldl (\sum (_,(x,y,z)) -> if x>0 then sum+1 else sum) 0 accList)+
+ examples/primes.hs view
@@ -0,0 +1,76 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+++-- This file contains a simple example that tests numbers for primality in parallel.+-- Author: Ryan Newton ++import System.Environment++-- #define MEMOIZE+#include <haskell_cnc.h>+----------------------------------------++-- First a naive serial test for primality:++isPrime :: Int -> Bool+isPrime 2 = True+isPrime n = (prmlp 3 == n)+ where prmlp :: Int -> Int+ prmlp i = if (rem n i) == 0+ then i else prmlp (i + 2)++----------------------------------------++-- Next, a CnC program that calls the serial test in parallel.++primes n = + do primes :: ItemCol Int Int <- newItemCol+ tags <- newTagCol+ prescribe tags (\t -> if isPrime (t) + then put primes t t+ else return ())++ let loop i | i >= n = return ()+ loop i = do putt tags i + loop (i+2)+ initialize $+ do put primes 2 2+ loop 3 ++ finalize $ + do result <- itemsToList primes+ return (length result) ++-- For reference, here's a sieve :+primels :: [Integer]+primels = 2 : Prelude.filter isPrime [3,5..]+ where+ isPrime n = all (not . divides n) $ takeWhile (\p -> p*p <= n) primels+ divides n p = n `mod` p == 0+++main = do args <- getArgs + let run n =+ do x <- return $ runGraph $ primes n+ putStrLn (show x)+ case args of + [] -> run 1000 -- Should output 168+ [n] -> run (read n)+ [trials, n] -> doTrials (read trials) (run (read n))
+ examples/primes2.hs view
@@ -0,0 +1,79 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}++-- This version uses a item collection and does an explicit 'get' to+-- check primality for each number it tests. Thus it does not require+-- quiescence-support. But the Maps grow much larger and there's much+-- more MVar traffic.++-- Author: Ryan Newton++import System.Environment++-- #define MEMOIZE+#include <haskell_cnc.h>+----------------------------------------++-- First a naive serial test for primality:++isPrime :: Int -> Bool+isPrime 2 = True+isPrime n = (prmlp 3 == n)+ where prmlp :: Int -> Int+ prmlp i = if (rem n i) == 0+ then i else prmlp (i + 2)++----------------------------------------++-- Next, a CnC program that calls the serial test in parallel.++primes n = + do primes :: ItemCol Int Bool <- newItemCol+ tags <- newTagCol+ prescribe tags (\t -> put primes t (isPrime t))++ let loop i | i >= n = return ()+ loop i = do putt tags i + loop (i+2)++ let loop2 i acc | i >= n = return acc+ loop2 i acc = do b <- get primes i+ loop2 (i+2) (if b then acc+1 else acc)++ initialize $+ do put primes 2 True+ loop 3++ finalize $ loop2 3 1++-- For reference, here's a sieve :+primels :: [Integer]+primels = 2 : Prelude.filter isPrime [3,5..]+ where+ isPrime n = all (not . divides n) $ takeWhile (\p -> p*p <= n) primels+ divides n p = n `mod` p == 0+++main = do args <- getArgs + let run n =+ do x <- return $ runGraph $ primes n+ putStrLn (show x)+ case args of + [] -> run 1000 -- Should output 168+ [n] -> run (read n)
+ examples/sched_tree.hs view
@@ -0,0 +1,65 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++-- sched_tree.hs+-- A simple scheduler test that creates a tree of exponentially+-- expanding numbers of step executions (as though it were a binary+-- tree). ++import System.Environment++#define MEMOIZE+#define REPEAT_PUT_ALLOWED+#include <haskell_cnc.h>+++-- We use lists of booleans as "tree indices":+type Tag = [Bool]++run limit = putStrLn (show v)+ where + v = runGraph $ + do tags :: TagCol Tag <- newTagCol+ items :: ItemCol Tag Int <- newItemCol+ prescribe tags + (\ls -> do -- bin tree path as input+ if length ls == limit+ -- Trivial output: count the "right" steps in the tree path:+ then put items ls (length $ Prelude.filter id ls)+ else do putt tags (True:ls)+ putt tags (False:ls)+ )+ initialize $ + do putt tags []++ -- Grab all the leaves of the binary tree:+ let grabloop ls =+ if length ls == limit+ then get items ls+ else do x <- grabloop (True:ls)+ y <- grabloop (False:ls)+ return (x+y) ++ finalize $ grabloop [] ++main = do args <- getArgs + case args of + [] -> run 10+ [s] -> run (read s)
+ examples/threadring.hs view
@@ -0,0 +1,62 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++import Control.Monad+import Data.Complex+import System.Environment++#include <haskell_cnc.h>++-- This simple microbenchmark is drawn from the "Great Language Shootout".+-- It passes token(s) around a ring.++-- This version uses a separate tag collection to represent each actor.++threadring hops agents 1 =+ do + answer :: ItemCol Int Int <- newItemCol++ first:resttags <- mapM (\i -> do x <- newTagCol; return (i,x))+ [1..agents]++ foldM (\ (i,last) (j,next) ->+ do prescribe last+ (\n -> if n == 0 + then put answer 0 i+ else putt next (n-1))+ return (j,next))+ first (resttags++[first])++ initialize $ + do putt (snd$ first) hops++ finalize $ get answer 0++-- Takes #hops #agents and #tokens in flight.+-- However tokens in flight > 1 is not yet implemented.+main = + do ls <- getArgs + let v = runGraph $ + case Prelude.map read ls of + [] -> threadring 17 503 1+ [h] -> threadring h 503 1+ [h,a] -> threadring h a 1+ [h,a,t] -> threadring h a t + putStrLn (show v)
+ examples/threadring_onestep.hs view
@@ -0,0 +1,96 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+-- Author: Ryan Newton ++-- #define INCLUDEMETHOD+-- -- #define MEMOIZE+-- #include "CncPure.hs"+-- -- #include "Cnc.hs"++import System.Environment++#include <haskell_cnc.h>+++-- This simple microbenchmark is drawn from the "Great Language Shootout".+-- It passes token(s) around a ring.++-- This implementation is for comparison with the C++ CnC implementation.a++threadring hops agents 1 =+ do tags :: TagCol Int <- newTagCol+ items :: ItemCol Int Int <- newItemCol+ answer :: ItemCol Int Int <- newItemCol++ prescribe tags + (\n -> do let next = n+1 + let myid = n `mod` agents+ --putStr$ "Actor executing, id "++ show myid ++"\n"+ token <- get items n+ --putStr$ " token "++ show token ++"\n"+ if token == 0 + then put answer 0 myid+ else do put items next (token-1)+ putt tags next )++ initialize $ + do put items 0 hops; putt tags 0+-- MAKE SURE THIS WORKS ALSO:+-- ([2009.08.12] It currently does with CncPure but not Cnc)+-- do putt tags 0; put items 0 hops++ finalize $ get answer 0+ --finalize $ return () +++main = + do ls <- getArgs + let v = runGraph $ + case Prelude.map read ls of + [] -> threadring 17 503 1+ [h] -> threadring h 503 1+ [h,a] -> threadring h a 1+ [h,a,t] -> threadring h a t+ putStrLn (show v)++{- +NOTES:++[2009.08.12]++ With CncPure we get a horrible score: 24.17s for only 5M rounds+ (plus 1.1gb of mem)! (I didn't even test 50M.) Well we have the+ same problem CnC/C++ does, of course, we leak memory like crazy.++ Turning MEMOIZE off, it peaks out at 560mb of mem and takes 12.15s+ (for 5M).++ How much do we spend in GC? Running with "+RTS -sstderr":++ ____++ Switching to Cnc.hs ... hah, well first that gives me a stack space overflow.+ That should NOT happen.+ That's a good hint though... Need to strictify some folds probably.+ (Btw, if I just force the stack size up to 100mb, it runs... but+ very slowly. It takes >23.5 minutes... and, well it stack+ overflowed the 100mb after using 1.3gb heap. Egad.)+++ -}
+ haskell-cnc.cabal view
@@ -0,0 +1,57 @@+Name: haskell-cnc+Version: 0.1+License: LGPL+License-file: LICENSE+Stability: Beta+Author: Ryan Newton <rrnewton@gmail.com>+Maintainer: Ryan Newton <rrnewton@gmail.com>+homepage: http://software.intel.com/en-us/articles/intel-concurrent-collections-for-cc/+Copyright: Copyright (c) 2009-2010 Intel Corporation+Synopsis: Library for parallel programming in the Intel Concurrent Collections paradigm.+Description: Intel (Concurrent Collections) CnC is a data-flow like+ deterministic parallel programming model, similar to+ stream-processing but in which nodes in the computation graph share data in tables.++Category: system, concurrent+Cabal-Version: >=1.2.3++build-type: Simple++library+ build-depends: base, mtl, containers, time, random, array, ghc-prim, extensible-exceptions, HUnit, QuickCheck+ -- Needed for the scaling.hs plotting script:+ -- HSH, gnuplot+ -- , judy>=0.2.2++ exposed-modules: Intel.Cnc Intel.CncPure+ -- Various alternative schedulers:+ Intel.Cnc3 Intel.Cnc5 Intel.Cnc6 Intel.Cnc8+ extensions: CPP, + -- These extensions are needed for Cnc.hs+ FlexibleInstances, BangPatterns, MagicHash, ScopedTypeVariables, DeriveDataTypeable, MultiParamTypeClasses,+ -- And the following are needed for CncPure.hs:+ ExistentialQuantification, ScopedTypeVariables, BangPatterns, NamedFieldPuns, RecordWildCards++ GHC-Options: -O2 +-- cpp-options: -DUSE_GMAP +-- -Wall + 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 + 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++ -- This seems to be completly ignored by cabal currently:+ -- Test testit+ -- type: library-1+ -- test-is: Intel.Cnc++Executable runAllTests+ Main-is: runAllTests.hs+ Build-Depends: base >= 3 && < 5, directory, process+ other-modules: Intel.Cnc Intel.CncPure+ extensions: CPP+ GHC-Options: -O2 -threaded +-- cpp-options: -DUSE_GMAP+-- Intel.CncUtil
+ haskell_cnc.h view
@@ -0,0 +1,40 @@+{-+ - Intel Concurrent Collections for Haskell+ - Copyright (c) 2010, Intel Corporation.+ -+ - This program is free software; you can redistribute it and/or modify it+ - under the terms and conditions of the GNU Lesser General Public License,+ - version 2.1, as published by the Free Software Foundation.+ -+ - This program is distributed in the hope it will be useful, but WITHOUT+ - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+ - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+ - more details.+ -+ - You should have received a copy of the GNU Lesser General Public License along with+ - this program; if not, write to the Free Software Foundation, Inc., + - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+ -+ -}+++#define INCLUDEMETHOD++#if CNC_VARIANT == 0+#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++#undef INCLUDEMETHOD++#elif CNC_VARIANT == 1+#include "Intel/CncPure.hs"+#elif CNC_VARIANT == 2+#include "Intel/Cnc.hs"+#elif CNC_VARIANT == 3+#error "Cnc_serialST not fully working yet"+#include "Cnc_serialST.hs"+#else+#error "CNC_VARIANT not set to a known value."+#endif
+ install_environment_vars.sh view
@@ -0,0 +1,7 @@+#!/bin/sh++# Instructions:+# 'source' me from my containing directory.++export HASKELLCNC=`pwd`+export PATH="$HASKELLCNC:$PATH"
+ ntimes view
@@ -0,0 +1,136 @@+#!/bin/bash+# ---------------------------------------------------------------------------+# Intel Concurrent Collections for Haskell+# Copyright (c) 2010, Intel Corporation.+# +# This program is free software; you can redistribute it and/or modify it+# under the terms and conditions of the GNU Lesser General Public License,+# version 2.1, as published by the Free Software Foundation.+# +# This program is distributed in the hope it will be useful, but WITHOUT+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+# more details.+# +# You should have received a copy of the GNU Lesser General Public License along with+# this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+# ---------------------------------------------------------------------------+++# Usage: ntimes <N> cmd args ...++# Takes the best time out of N.+# Returns that best time in seconds to stdout.++# This script writes a bunch of stuff to stderr, but only one thing to+# stdout. The one thing, the "return value" of this process is the+# best time in seconds.++# Responds to the environment variable HIDEOUTPUT, which, if non-empty+# suppresses echoing of the child command's output.++# Also responds to NOTIME which turns off the timing.+++# Time out processes after two minutes.+TIMEOUT=120++# Unfortunately 'tempfile' is not a standard command:+function mytempfile {+ date=`date +"%Y.%m.%d"`+ secs=`date +"%s"`+ #index=$(($index+1))+ index=$1+ file=./runs/"$date"_"$base"_"$CNC_VARIANT"_"$CNC_SCHEDULER"_"$NUMTHREADS"_"$secs"_"$index".log+ touch $file+ echo $file+}++N=$1+shift+CMD=$*++if [ "$CMD" == "" ];+then echo Usage: "ntimes <trials> <cmd> <cmdargs> ..."+ exit 1+fi+base=`basename $1`++if [ ! -d "./runs" ]; then mkdir ./runs; fi ++CAT=/bin/cat++ # This serves as the log+ TMP1=`mytempfile 1`+ echo "Execution log file: " >> /dev/stderr+ echo " $TMP1" >> /dev/stderr++ #echo "=================== ASYNCHRONOUS TEST OUTPUT TO FOLLOW ======================" > $TMP1++ # if [ "$HIDEOUTPUT" == "" ];+ # then (tail -f $TMP1 >> /dev/stderr) &+ # fi++EXITCODE=0++ for ((i=1; i <= $N; i++)); do+ # Stores the executable output:+ TMP2=`mytempfile 2`++# [2009.12.17] I need to get a good cross-platform process time-out system:+ if [ -e ./timeout ];+ then TIMEOUTRUN="./timeout -t $TIMEOUT"+ else TIMEOUTRUN=+ fi++ if [ "$HIDEOUTPUT" == "" ];+ then MYOUT=/dev/stderr+ else MYOUT=/dev/null+ fi++ echo | tee -a $TMP2 >> $MYOUT+ echo "Running trial $i of $N:" | tee -a $TMP2 >> $MYOUT+ echo "------------------------------------------------------------" | tee -a $TMP2 >> $MYOUT++ # This is hackish, it depends on the program output not containing+ # the string "real". (Aside from the timing results.)++ if [ "$NOTIME" != "" ];+ then ($TIMEOUTRUN $CMD) &> /dev/stdout | tee -a $TMP2 >> $MYOUT; CODE=${PIPESTATUS[0]}+ elif [ `uname` == "Linux" ];+ then (/usr/bin/time --format="%e real" $TIMEOUTRUN $CMD) &> /dev/stdout | tee -a $TMP2 >> $MYOUT; CODE=${PIPESTATUS[0]}+ else (/usr/bin/time $TIMEOUTRUN $CMD) &> /dev/stdout | tee -a $TMP2 >> $MYOUT; CODE=${PIPESTATUS[0]}+ fi++ # If there was an error, we don't commit the output to $TMP1:+ if [ "$CODE" == "0" ];+ then echo " Run $i of command succeeded" >> /dev/stderr+ cat $TMP2 >> $TMP1+ # [2010.05.11] I used to just give warnings when not ALL of the trials failed:+ # This was for timing the nondeterministic hashtable hack:+ #else echo "Warning: run $i of command failed with code $CODE: $CMD" >> /dev/stderr+ else echo "ERROR run $i of command failed with code $CODE: $CMD" >> /dev/stderr+ #exit $CODE+ EXITCODE=$CODE+ fi++ rm -f $TMP2+done;++ # Stores the times:+ TMP3=`mytempfile 3`++ # Hack: this assumes the string "real" doesn't occur in the test output.+ grep real $TMP1 | awk '{ print $1" "$2 }' | sort -n > $TMP3++ # Echo the final output to stdout:++ echo "Final Timings: " > /dev/stderr++ cat $TMP3 | sed 's/real //' | sed 's/ real//' ++ # Leave behind only $TMP1+ rm -f $TMP3++exit $EXITCODE
+ ntimes_minmedmax view
@@ -0,0 +1,38 @@+#!/bin/bash+# ---------------------------------------------------------------------------+# Intel Concurrent Collections for Haskell+# Copyright (c) 2010, Intel Corporation.+# +# This program is free software; you can redistribute it and/or modify it+# under the terms and conditions of the GNU Lesser General Public License,+# version 2.1, as published by the Free Software Foundation.+# +# This program is distributed in the hope it will be useful, but WITHOUT+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+# more details.+# +# You should have received a copy of the GNU Lesser General Public License along with+# this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+# ---------------------------------------------------------------------------++ntimes=`dirname $0`/ntimes++times=`$ntimes $*`+CODE=$?+if [ "$CODE" != "0" ];+then exit $CODE+fi++lines=`echo $times | xargs -n1 echo | wc -l`+half=$((($lines+1)/2))++echo "Median time (of $lines): " >> /dev/stderr+#echo "Median time of: $times" >> /dev/stderr++MIN=`echo $times | xargs -n1 echo | sort -n | head -n1`+MED=`echo $times | xargs -n1 echo | sort -n | head -n$half | tail -n1`+MAX=`echo $times | xargs -n1 echo | sort -n | tail -n1`++echo $MIN $MED $MAX
+ runAllTests.hs view
@@ -0,0 +1,52 @@++import System.Directory+import qualified Intel.Cnc+import qualified Intel.CncPure+import qualified Intel.CncUtil++import System.Cmd(system) +import System.Exit++import Test.HUnit+++main = do + cd <- getCurrentDirectory++ putStrLn$ "Running Unit tests in directory: " ++ show cd++ putStrLn$ "\n================================================================================"+ putStrLn$ "Running "++ show (testCaseCount Intel.CncUtil.tests) ++" tests from Intel.CncUtil"+ putStrLn$ "================================================================================\n"+ code1 <- runTestTT Intel.CncUtil.tests++ putStrLn$ "\n================================================================================"+ putStrLn$ "Running "++ show (testCaseCount Intel.Cnc.tests) ++" tests from Intel.Cnc"+ putStrLn$ "================================================================================\n"+ code2 <- runTestTT Intel.Cnc.tests++ putStrLn$ "\n================================================================================"+ putStrLn$ "Running "++ show (testCaseCount Intel.CncPure.tests) ++" tests from Intel.CncPure"+ putStrLn$ "================================================================================\n"+ code3 <- runTestTT Intel.CncPure.tests++ let problems = errors code1 + failures code1 ++ errors code2 + failures code2 + + errors code3 + failures code3++ putStrLn$ "\n================================================================================"+ putStrLn$ "Finally running system tests in all configurations (example programs):"+ putStrLn$ "================================================================================\n"++ -- I have problems with cabal sdist not preserving executable flags.+ system "chmod +x ./runcnc" + system "chmod +x ./run_all_examples.sh" + system "chmod +x ./ntimes" + system "chmod +x ./ntimes_minmedmax" ++ code <- system "TRIALS=1 ./run_all_examples.sh" + let code = ExitSuccess + case (problems,code) of+ (0, ExitSuccess) -> exitWith ExitSuccess+ (n, ExitSuccess) -> do putStrLn$ "ERROR: "++ show n ++" failures in unit tests!"; exitWith (ExitFailure n)+ (_, ExitFailure n) -> do putStrLn "ERROR: Example programs failed!\n"; exitWith (ExitFailure n)
+ run_all_examples.sh view
@@ -0,0 +1,208 @@+#!/bin/bash++# ---------------------------------------------------------------------------+# Intel Concurrent Collections for Haskell+# Copyright (c) 2010, Intel Corporation.+# +# This program is free software; you can redistribute it and/or modify it+# under the terms and conditions of the GNU Lesser General Public License,+# version 2.1, as published by the Free Software Foundation.+# +# This program is distributed in the hope it will be useful, but WITHOUT+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+# more details.+# +# You should have received a copy of the GNU Lesser General Public License along with+# this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+# ---------------------------------------------------------------------------+++# This will put all the example programs through the paces under all+# possible scheduler configurations. ++# ---------------------------------------------------------------------------+# Usage: [set env vars] ./run_all_tests++# Call it with environment variable LONGRUN=1 to get a longer run that+# can serve as benchmarks.++# Call it with THREADS="1 2 4" to run with # threads = 1, 2, or 4.++# Call it with NONSTRICT=1 to keep going after the first error.++# Call it with TRIALS=N to control the number of times each benchmark is run.+# ---------------------------------------------------------------------------+++# Settings:+# ----------------------------------------++#export GHC=ghc-6.13.20100511 +#export GHC=~/bin/Linux-i686/bin/ghc-6.13.20100511++ # Which subset of schedures should we test:+PURESCHEDS="2"+#IOSCHEDS="8 6 5 3"+IOSCHEDS="3 5 8"+#IOSCHEDS="3 5 6 8"++#THREADSETTINGS="0 1 2 3 4 7 8"++source default_opt_settings.sh++ # Where to put the timing results:+RESULTS=results.dat+if [ -e $RESULTS ];+then BAK="$RESULTS".bak.`date +%s`+ echo "Backing up old results to $BAK"+ mv $RESULTS $BAK+fi++# How many times to run a process before taking the best time:+if [ "$TRIALS" == "" ]; then + TRIALS=5+fi++# Determine number of hardware threads on the machine:+# if [ -f /proc/cpuinfo ]; + if [ -d /sys/devices/system/cpu/ ];+ then + MAXTHREADS=`ls /sys/devices/system/cpu/ | grep "cpu[0123456789]*$" | wc -l`+ echo "Detected the number of CPUs on the machine to be $MAXTHREADS"+ elif [ `uname` == "Darwin" ];+ then MAXTHREADS=`sysctl -n hw.ncpu`+ else MAXTHREADS=2+ fi ++if [ "$THREADSETTINGS" == "" ]; then + THREADSETTINGS=$MAXTHREADS+ #for ((i=1; i <= $MAX; i++)); do THREADSETTINGS="$THREADSETTINGS $i"; done +fi+++# ================================================================================+echo "# TestName Variant Scheduler NumThreads HashHackEnabled MinTime MedianTime MaxTime" > $RESULTS+echo "# "`date` >> $RESULTS+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++cnt=0++function check_error() {+ CODE=$1+ MSG=$2+ # Error code 143 was a timeout+ if [ "$CODE" == "143" ]+ then echo " Return code $CODE Params: $CNC_VARIANT $CNC_SCHEDULER $FLAGS"+ echo " Process TIMED OUT!!"+ elif [ "$CODE" != "0" ]+ then echo $MSG+ echo " Error code $CODE Params: $CNC_VARIANT $CNC_SCHEDULER $FLAGS"+ echo "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"+ if [ "$NONSTRICT" == "" ];+ then exit $CODE+ fi+ fi+}++# Dynamic scoping. Lame. This uses $test.+function runit() +{+ cnt=$((cnt+1))+ echo + echo "--------------------------------------------------------------------------------"+ echo " Running Config $cnt: $test variant $CNC_VARIANT sched $CNC_SCHEDULER threads $NUMTHREADS $hashtab"+ echo "--------------------------------------------------------------------------------"+ echo + if [ "$NUMTHREADS" != "0" ] && [ "$NUMTHREADS" != "" ]+ then export RTS=" $GHC_DEFAULT_RTS -s -N$NUMTHREADS "+ else export RTS=""+ fi+ if [ "$hashtab" == "" ];+ then HASH="0"+ else HASH="1"+ fi++ # We compile the test case using runcnc:+ NORUN=1 ./runcnc $hashtab examples/"$test".hs+ CODE=$?+ check_error $CODE "ERROR: compilation failed."++ echo "Executing ./examples/$test.exe $ARGS +RTS $RTS "+ if [ "$LONGRUN" == "" ]; then export HIDEOUTPUT=1; fi+ times=`./ntimes_minmedmax "$TRIALS" ./examples/$test.exe $ARGS +RTS $RTS -RTS`+ CODE=$?++ echo " >>> MIN/MEDIAN/MAX TIMES $times"++ check_error $CODE "ERROR: run_all_tests this test failed completely: $test.exe"++ if [ "$CODE" != "0" ] && [ "$CODE" != "143" ];+ then echo "$test.exe" "$CNC_VARIANT" "$CNC_SCHEDULER" "$NUMTHREADS" "$HASH" "ERR ERR ERR" >> $RESULTS+ else + echo "$test.exe" "$CNC_VARIANT" "$CNC_SCHEDULER" "$NUMTHREADS" "$HASH" "$times" >> $RESULTS+ fi+}+++echo "Running all tests, for THREADSETTINGS in {$THREADSETTINGS}"+echo++# 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++ set -- $line+ test=$1; shift++ if [ "$LONGRUN" == "" ];+ # If we're not in LONGRUN mode we run each executable with no+ # arguments causing it to go to its default problem size.+ then ARGS=+ else ARGS=$*+ fi++ echo "================================================================================"+ echo " Running Test: $test.exe $ARGS "+ echo "================================================================================"++ export CNC_VARIANT=pure+ # Currently running the pure scheduler only in single threaded mode:+ export NUMTHREADS=0+ for sched in $PURESCHEDS; do+ unset hashtab+ export CNC_SCHEDULER=$sched+ runit+ done++ export CNC_VARIANT=io+ for sched in $IOSCHEDS; do+ export CNC_SCHEDULER=$sched+ #for NUMTHREADS in 4; do+ for NUMTHREADS in $THREADSETTINGS; do+ # Running with the hashtable hack off:+ export hashtab=""+ runit++ # This one is incorrect and nondeterministic:+ # export hashtab="-DHASHTABLE_TEST"; runit+ done # threads+ echo >> $RESULTS;+ done # schedulers++ # 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+ runit++ echo >> $RESULTS;+ echo >> $RESULTS;+done++echo "Finished with all test configurations."
+ runcnc view
@@ -0,0 +1,152 @@+#!/bin/bash++# ---------------------------------------------------------------------------+# Intel Concurrent Collections for Haskell+# Copyright (c) 2010, Intel Corporation.+# +# This program is free software; you can redistribute it and/or modify it+# under the terms and conditions of the GNU Lesser General Public License,+# version 2.1, as published by the Free Software Foundation.+# +# This program is distributed in the hope it will be useful, but WITHOUT+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for+# more details.+# +# You should have received a copy of the GNU Lesser General Public License along with+# this program; if not, write to the Free Software Foundation, Inc., +# 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA.+# ---------------------------------------------------------------------------+++++# This is a script used for running an CnC Haskell program.+# It responds to a bunch of environment variables that choose configuration to use.++# This script responds to a number of ENVIRONMENT VARIABLES:+# --------------------------------------------------------------------------------+# NUMTHREADS -- if this is "0" the program is compiled without threading++# CNC_VARIANT -- which implementation? "pure" or "io"+# CNC_SCHEDULER -- which (numbered) scheduler, 1-N?+# FLAGS -- flags for ghc+# GHC -- command to call ghc compiler+# INTERACTIVE -- set to non-empty value to call ghci instead of ghc+# --------------------------------------------------------------------------------++#source "$HASKELLCNC/default_opt_settings.sh"+DEFAULT_SETTINGS_FILE=`dirname $0`/default_opt_settings.sh+source $DEFAULT_SETTINGS_FILE+# if [ -z ]+++FILE=$1+BIN=`echo $1 | sed 's/\.hs//'`.exe+shift++if [ "$GHC" == "" ]; then + GHC=ghc+fi++if [ "$INTERACTIVE" == "" ];+then CMD="$GHC --make";+else CMD=ghci+fi++# [2010.02.16] Strangely enabling -fglasgow-exts causes CncPure.hs to NOT compile correctly. Parse error.+#EXTENSIONS="-fglasgow-exts"+# -feager-blackholing+TEMPEXT="-XFlexibleContexts -XTypeSynonymInstances"+EXTENSIONS=" -XExistentialQuantification -XScopedTypeVariables -XBangPatterns -XNamedFieldPuns -XRecordWildCards -XFlexibleInstances -XDeriveDataTypeable $TEMPEXT"+# MagicHash ++# If the user has not set $HASKELLCNC we try the current directory.+if [ "$HASKELLCNC" == "" ]; then +if [ -e "./Intel/Cnc.hs" ]; then+ echo ' *** WARNING: Guessing $HASKELLCNC is current directory.'+ export HASKELLCNC=`pwd`+else+ echo "ERROR: Environment variable HASKELLCNC must be set to installation directory!"+ exit 1+fi+fi++# We need to include the install dir in the search path for GHC and+# for the C preprocessor.+FLAGS="$GHC_DEFAULT_FLAGS $EXTENSIONS -I""$HASKELLCNC -i""$HASKELLCNC"++# This is an undocumented environment variable dependence -- NORUN+# disables execution and causes this script to compile-only.+if [ "$NORUN" == "" ]; then + EXTRAGHCARGS=+else+ # In NORUN mode extra arguments are meant for GHC, not the final application.+ EXTRAGHCARGS=$*+fi++# && [ "$NUMTHREADS" != "" ];+if [ "$NUMTHREADS" != "0" ] +then + FLAGS="$FLAGS -threaded"+ EXTRA_RUN_ARGS=" +RTS $GHC_DEFAULT_RTS -N$NUMTHREADS -RTS"+else+ # This is annoying, the thread-related flags must be removed from+ # the defaults if we're not in threaded mode:+ FILTERED_RTS=`echo $GHC_DEFAULT_RTS | sed 's/-qa//'` + EXTRA_RUN_ARGS=" +RTS $FILTERED_RTS -RTS "+fi++# CnC implementation variant. Translate string setting to numeric one.+if [ "$CNC_VARIANT" == "pure" ]; then + echo "Using CNC_VARIANT='pure'"+ FLAGS="$FLAGS -DCNC_VARIANT=1"+elif [ "$CNC_VARIANT" == "io" ] || [ "$CNC_VARIANT" == "normal" ] ; then+ echo "Using CNC_VARIANT='io'"+ FLAGS="$FLAGS -DCNC_VARIANT=2"++elif [ "$CNC_VARIANT" == "" ]; then+ echo " *** "+ echo " *** \$CNC_VARIANT unset (should be 'pure' or 'io')!"+ echo " *** Defaulting to 'io'..."+ echo " *** "+ CNC_VARIANT="io"+ FLAGS="$FLAGS -DCNC_VARIANT=2" ++elif [ "$CNC_VARIANT" == "separatemodule_io" ]; then+ FLAGS="$FLAGS -DCNC_VARIANT=0" ++else + echo "ERROR: unknown CNC_VARIANT: $CNC_VARIANT"+ exit 2+fi++# Scheduler:+if [ "$CNC_SCHEDULER" == "" ];+then echo+# [2010.05.19] For cabal builds its easier if the default is set in the code itself.+#+ # if [ "$CNC_VARIANT" == "pure" ]; then+ # FLAGS="$FLAGS -DCNC_SCHEDULER=2"+ # echo " *** WARNING - defaulting CNC_SCHEDULER to '2' (pure)"+ # else+ # FLAGS="$FLAGS -DCNC_SCHEDULER=6"+ # echo " *** WARNING - defaulting CNC_SCHEDULER to '6' (io)"+ # fi+else FLAGS="$FLAGS -DCNC_SCHEDULER=$CNC_SCHEDULER"+fi++echo " [Compiling $FILE to $BIN, $CNC_VARIANT $CNC_SCHEDULER ]"+echo $CMD $FLAGS -cpp "$FILE" -o "$BIN" -fforce-recomp $EXTRAGHCARGS+if $CMD $FLAGS -cpp "$FILE" -o "$BIN" -fforce-recomp $EXTRAGHCARGS+ #if ghc -cpp -O2 $FILE -o + then + if [ "$NORUN" == "" ]; then + echo; echo " [Executing: time ./$BIN $* $EXTRA_RUN_ARGS;]"+ echo "----------------------------------------"+ exec time ./$BIN $* $EXTRA_RUN_ARGS; + # exec time memprof ./$BIN $* + fi+ else exit 33+fi+
+ scaling.hs view
@@ -0,0 +1,333 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE NamedFieldPuns+ #-}++import Text.PrettyPrint.HughesPJClass+import Text.Regex+import Data.List+import Data.Function+import Control.Monad+import System++import HSH++++-- import Graphics.Gnuplot.Simple+-- import Graphics.Gnuplot.Advanced+-- import Graphics.Gnuplot.Frame+-- import Graphics.Gnuplot.Frame.OptionSet++-- import qualified Graphics.Gnuplot.Terminal.X11+-- import Graphics.Gnuplot.Plot.TwoDimensional++++import qualified Graphics.Gnuplot.Simple as Simple++import qualified Graphics.Gnuplot.Advanced as Plot+import qualified Graphics.Gnuplot.Terminal.X11 as X11++import qualified Graphics.Gnuplot.Frame as Frame+import qualified Graphics.Gnuplot.Frame.Option as Opt+import qualified Graphics.Gnuplot.Frame.OptionSet as Opts++import qualified Graphics.Gnuplot.Plot.ThreeDimensional as Plot3D++import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D+import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D+import Graphics.Gnuplot.Plot.TwoDimensional (linearScale, )++import Data.Array (listArray, )+import Data.Monoid (mappend, )+++--import qualified Graphics.Gnuplot.Private.LineSpecification as LineSpec+import qualified Graphics.Gnuplot.LineSpecification as LineSpec++simple2d :: Plot2D.T+simple2d =+ Plot2D.function (linearScale 100 (-10,10::Double)) sin++circle2d :: Plot2D.T+circle2d =+ fmap+ (Graph2D.typ Graph2D.points)+ (Plot2D.parameterFunction+ (linearScale 24 (-pi,pi::Double))+ (\t -> (cos t, sin t)))++overlay2d :: Frame.T Graph2D.T+overlay2d =+ Frame.cons (Opts.size 1 0.4 $ Opts.remove Opt.key $ Opts.deflt) $+ Plot2D.function (linearScale 100 (-pi,pi::Double)) cos+ `mappend`+ circle2d++-- mypath :: Graph2D.T +mypath :: Plot2D.T+mypath = + fmap (Graph2D.lineSpec $ + LineSpec.title "blaht" $ + LineSpec.lineWidth 3.0 $ + LineSpec.pointSize 3.0 $ + LineSpec.deflt) $ + fmap (Graph2D.typ Graph2D.linesPoints) $+ Plot2D.path [(0,0), (1,1), (3,2)]++spec :: LineSpec.T+spec = LineSpec.title "blah" LineSpec.deflt++myoverlay :: Frame.T Graph2D.T+myoverlay =+ --Graph2D.lineSpec (LineSpec.title "blah" LineSpec.deflt) $ + Frame.cons (Opts.deflt) $+ mypath --(Graph2D.lineSpec spec mypath)+ `mappend`+ circle2d+++++--x11 = terminal Terminal.X11.cons+--x11 = terminal cons+--x11 = terminal Graphics.Gnuplot.Terminal.X11.cons+--x11 = terminal X11.cons++--------------------------------------------------------------------------------+-- Let's take a particular interpretation of Enum for pairs:+instance (Enum t1, Enum t2) => Enum (t1,t2) where + succ (a,b) = (succ a, succ b)+ pred (a,b) = (pred a, pred b)+ toEnum n = (toEnum n, toEnum n)+ fromEnum (a,b) = case (fromEnum a, fromEnum b) of+ (x,y) | x == y -> x+ (x,y) -> error$ "fromEnum of pair: nonmatching numbers: " ++ show x ++" and "++ show y+++-- Removes single blanks and separates lines into groups based on double blanks.+sepDoubleBlanks :: [String] -> [[String]]+sepDoubleBlanks ls = loop [] ls + where + loop acc [] = [reverse acc]+ loop acc ("":"":t) = reverse acc : loop [] (stripLeadingBlanks t)+ loop acc ("":t) = loop acc t+ loop acc (h :t) = loop (h:acc) t + stripLeadingBlanks [] = [] + stripLeadingBlanks ("":t) = stripLeadingBlanks t+ stripLeadingBlanks ls = ls+++remComments :: String -> [String] -> [String]+remComments commentchars ls = filter (pred . stripLeadingWhitespace) ls+ where + pred str = not (take (length commentchars) str == commentchars) + stripLeadingWhitespace [] = [] + stripLeadingWhitespace (' ':t) = stripLeadingWhitespace t+ stripLeadingWhitespace ls = ls++--------------------------------------------------------------------------------++-- Here's the schema for the data from my timing tests:+data Entry = Entry { + name :: String,+ variant :: String,+ sched :: Int, + threads :: Int, + hashhack :: Bool, + tmin :: Double,+ tmed :: Double,+ tmax :: Double+}+ deriving Show++instance Pretty Entry where+ --pPrint x = pPrint$ show x+ pPrint Entry { name, variant, sched, threads, tmin, tmed, tmax } = + pPrint ("ENTRY", name, variant, sched, threads, tmin, tmed, tmax)+++parse [a,b,c,d,e,f,g,h] =+ Entry { name = a, + variant = b,+ sched = read c,+ threads = read d,+ hashhack = not (e == "0"),+ tmin = read f,+ tmed = read g,+ tmax = read h+ } +parse other = error$ "Cannot parse, wrong number of fields, "++ show (length other) ++" expected 8: "++ show other++groupSort fn = + (groupBy ((==) `on` fn)) . + (sortBy (compare `on` fn))++-- Add three more levels of list nesting to organize the data:+organize_data :: [Entry] -> [[[[Entry]]]]+organize_data = + (map (map (groupSort sched))) . + (map (groupSort variant)) .+ (groupSort name)+++newtype Mystr = Mystr String++instance Show Mystr where+ show (Mystr s) = s+++-- mypath :: Graph2D.T +--Plot2D.T+--plot_benchmark :: [[[Entry]]] -> IO ()+--plot_benchmark :: [[[Entry]]] -> Plot2D.T+plot_benchmark [io, pure] = + --Plot.plot (X11.title "foobar" X11.cons) $+ Plot.plot X11.cons $+ Frame.cons (Opts.title ("Benchmark: " ++ benchname ++ " normalized to time " ++ show basetime) $ Opts.deflt) plots+ where + benchname = name $ head $ head io + plots = foldl1 mappend (map persched io ++ map persched pure)+ basetime = foldl1 min $ map tmed $+ filter ((== 0) . threads) $+ (concat io ++ concat pure)+ persched :: [Entry] -> Plot2D.T+ persched dat = + let + schd = sched$ head dat+ var = variant$ head dat+ mins = map tmin dat+ meds = map tmed dat+ maxs = map tmax dat+ --zip4 = map$ \ a b c d -> (a,b,c,d)+ zip4 s1 s2 s3 s4 = map (\ ((a,b), (c,d)) -> (a,b,c,d))+ (zip (zip s1 s2) (zip s3 s4))+ pairs = zip4 (map (fromIntegral . threads) dat) + (map (basetime / ) meds)+ (map (basetime / ) mins)+ (map (basetime / ) maxs)+ quads = map (\ (a,b,c,d) -> Mystr (show a ++" "++ show b ++" "++ show d ++" "++ show c))+ pairs + in + fmap (Graph2D.lineSpec $ + LineSpec.title (var ++"/"++ show schd) $ + LineSpec.lineWidth 3.0 $ + LineSpec.pointSize 3.0 $ + LineSpec.deflt) $ + fmap (Graph2D.typ Graph2D.linesPoints) $+ --Plot2D.path pairs+ --Plot2D.path (map ( \ (a,b,c,d) -> (a,b)) pairs)+ --fmap (Graph2D.typ Graph2D.errorBars) $+ Plot2D.list quads+++-- Ok, yuck, giving up on the Cabal gnuplot package and generating the gnuplot output myself.+plot_benchmark2 root [io, pure] = action (io ++ pure)+ where + benchname = name $ head $ head io + -- What was the best single-threaded execution time across variants/schedulers:+ basetime = foldl1 min $ map tmed $+ filter ((== 0) . threads) $+ (concat io ++ concat pure)+ (filebase,_) = break (== '.') $ basename benchname ++ scrub '_' = ' '+ scrub x = x+ -- scrub [] = []+ -- scrub ('_':t) = "\\_"++ scrub t+ -- scrub (h:t) = h : scrub t++ action lines = + do + let scriptfile = root ++ filebase ++ ".gp"+ putStrLn$ "Dumping gnuplot script to: "++ scriptfile+ runIO$ echo "set terminal postscript enhanced color\n" -|- appendTo scriptfile+ runIO$ echo ("set output \""++filebase++".eps\"\n") -|- appendTo scriptfile+ runIO$ echo ("set title \"Benchmark: "++ map scrub filebase +++ ", speedup relative to serial time " ++ show basetime ++" seconds\"\n") -|- appendTo scriptfile+ runIO$ echo ("set xlabel \"Number of Threads\"\n") -|- appendTo scriptfile+ runIO$ echo ("set ylabel \"Parallel Speedup\"\n") -|- appendTo scriptfile+ runIO$ echo ("plot \\\n") -|- appendTo scriptfile+ -- In this loop lets do the errorbars:+ forM_ (zip [1..] lines) $ \(i,points) -> do + let datfile = root ++ filebase ++ show i ++".dat"+ runIO$ echo (" \""++ basename datfile ++"\" using 1:2:3:4 with errorbars title \"\", \\\n") -|- appendTo scriptfile++ -- Now a second loop for the lines themselves and to dump the actual data:+ forM_ (zip [1..] lines) $ \(i,points) -> do + let datfile = root ++ filebase ++ show i ++".dat" + let schd = sched$ head points+ let var = variant$ head points+ let nickname = var ++"/"++ show schd+ runIO$ echo ("# Data for variant "++ nickname ++"\n") -|- appendTo datfile+ forM_ points $ \x -> do + runIO$ echo (show (fromIntegral (threads x)) ++" "+++ show (basetime / tmed x) ++" "+++ show (basetime / tmax x) ++" "++ + show (basetime / tmin x) ++" \n") -|- appendTo datfile++ let comma = if i == length lines then "" else ",\\"+ runIO$ echo (" \""++ basename datfile +++ "\" using 1:2 with lines linewidth 4.0 lt "++ show i ++" title \""++nickname++"\" "++comma++"\n")+ -|- appendTo scriptfile++ putStrLn$ "Finally, running gnuplot..."+ -- runIO$ "(cd "++root++"; gnuplot "++basename scriptfile++")"+ -- runIO$ "(cd "++root++"; ps2pdf "++ filebase ++".eps )"+++plot_benchmark2 root _ = putStrLn "plot_benchmark2: Unexpected input" ++isMatch rg str = case matchRegex rg str of { Nothing -> False; _ -> True }++main = do + dat <- run$ catFrom ["results.dat"] -|- remComments "#" ++ let parsed = map (parse . splitRegex (mkRegex "[ \t]+")) + (filter (not . isMatch (mkRegex "ERR")) $+ filter (not . null) dat)+ let organized = organize_data$ filter ((`elem` ["io","pure"]) . variant) parsed+++ -- let chunked = sepDoubleBlanks dat + -- let chopped = map (parse . splitRegex (mkRegex "[ \t]+"))+ -- (chunked !! 0)+ -- let bysched = groupBy ((==) `on` sched) $+ -- sortBy (compare `on` sched) + -- chopped+ -- putStrLn$ show (pPrint (map length chopped))+ -- putStrLn$ show (pPrint (map parse chopped))++ putStrLn$ renderStyle (style { lineLength=150 }) (pPrint organized)++ --Plot.plot X11.cons myoverlay+ --Simple.plotList [Simple.LineStyle 0 [Simple.LineTitle "foobar"]] [0,5..100]++ let root = "./graph_temp/"+ -- For hygiene, completely anhilate output directory:+ system$ "rm -rf " ++root+ system$ "mkdir -p "++root+ forM_ organized $ \ perbenchmark -> do + plot_benchmark2 root perbenchmark+ forM_ perbenchmark $ \ pervariant -> + forM_ pervariant $ \ persched -> + do let mins = map tmin persched+ let pairs = (zip (map (fromIntegral . threads) persched) mins)+ putStrLn$ show pairs+ --plot Graphics.Gnuplot.Terminal.X11.cons (path pairs)+ --System.exitWith ExitSuccess+ --plot x11 (path pairs)+ + return ()++ --forM_ organized $ \ perbenchmark -> +++ --plotLists [x11] [dat, [50..25]]+ --plotLists [x11] [dat, [100,95..0]]++ --plotDots [x11, Size$ Scale 3.0] dat+ --plotDots [x11, LineStyle 0 [PointSize 5.0]] dat+ putStrLn$ "Plotted list"++