diff --git a/Intel/Cnc.Header.hs b/Intel/Cnc.Header.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc.Header.hs @@ -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 . + General documentation on the CnC model can be found at + . + + -} +#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. + +-------------------------------------------------------------------------------- + + + + +-- *** This file will be included into the per-scheduler implementations. *** diff --git a/Intel/Cnc.hs b/Intel/Cnc.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc.hs @@ -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 diff --git a/Intel/Cnc3.hs b/Intel/Cnc3.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc3.hs @@ -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!" diff --git a/Intel/Cnc5.hs b/Intel/Cnc5.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc5.hs @@ -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!" diff --git a/Intel/Cnc6.hs b/Intel/Cnc6.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc6.hs @@ -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. + diff --git a/Intel/Cnc8.hs b/Intel/Cnc8.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc8.hs @@ -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) diff --git a/Intel/CncPure.hs b/Intel/CncPure.hs new file mode 100644 --- /dev/null +++ b/Intel/CncPure.hs @@ -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 " " + 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] diff --git a/Intel/CncUtil.hs b/Intel/CncUtil.hs new file mode 100644 --- /dev/null +++ b/Intel/CncUtil.hs @@ -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] diff --git a/Intel/shared_5_6.hs b/Intel/shared_5_6.hs new file mode 100644 --- /dev/null +++ b/Intel/shared_5_6.hs @@ -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 = "" +instance Show (IO a) where + show ref = "" + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + 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. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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* diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 + diff --git a/default_opt_settings.sh b/default_opt_settings.sh new file mode 100644 --- /dev/null +++ b/default_opt_settings.sh @@ -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 " + diff --git a/examples/embarrassingly_par.hs b/examples/embarrassingly_par.hs new file mode 100644 --- /dev/null +++ b/examples/embarrassingly_par.hs @@ -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 + +-- 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]) diff --git a/examples/fib.hs b/examples/fib.hs new file mode 100644 --- /dev/null +++ b/examples/fib.hs @@ -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) + diff --git a/examples/hello_world.hs b/examples/hello_world.hs new file mode 100644 --- /dev/null +++ b/examples/hello_world.hs @@ -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 + +-- 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) diff --git a/examples/mandel.hs b/examples/mandel.hs new file mode 100644 --- /dev/null +++ b/examples/mandel.hs @@ -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 + +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) diff --git a/examples/nbody.hs b/examples/nbody.hs new file mode 100644 --- /dev/null +++ b/examples/nbody.hs @@ -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) + diff --git a/examples/primes.hs b/examples/primes.hs new file mode 100644 --- /dev/null +++ b/examples/primes.hs @@ -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 +---------------------------------------- + +-- 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)) diff --git a/examples/primes2.hs b/examples/primes2.hs new file mode 100644 --- /dev/null +++ b/examples/primes2.hs @@ -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 +---------------------------------------- + +-- 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) diff --git a/examples/sched_tree.hs b/examples/sched_tree.hs new file mode 100644 --- /dev/null +++ b/examples/sched_tree.hs @@ -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 + + +-- 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) diff --git a/examples/threadring.hs b/examples/threadring.hs new file mode 100644 --- /dev/null +++ b/examples/threadring.hs @@ -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 + +-- 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) diff --git a/examples/threadring_onestep.hs b/examples/threadring_onestep.hs new file mode 100644 --- /dev/null +++ b/examples/threadring_onestep.hs @@ -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 + + +-- 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.) + + + -} diff --git a/haskell-cnc.cabal b/haskell-cnc.cabal new file mode 100644 --- /dev/null +++ b/haskell-cnc.cabal @@ -0,0 +1,57 @@ +Name: haskell-cnc +Version: 0.1 +License: LGPL +License-file: LICENSE +Stability: Beta +Author: Ryan Newton +Maintainer: Ryan Newton +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 diff --git a/haskell_cnc.h b/haskell_cnc.h new file mode 100644 --- /dev/null +++ b/haskell_cnc.h @@ -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 diff --git a/install_environment_vars.sh b/install_environment_vars.sh new file mode 100644 --- /dev/null +++ b/install_environment_vars.sh @@ -0,0 +1,7 @@ +#!/bin/sh + +# Instructions: +# 'source' me from my containing directory. + +export HASKELLCNC=`pwd` +export PATH="$HASKELLCNC:$PATH" diff --git a/ntimes b/ntimes new file mode 100644 --- /dev/null +++ b/ntimes @@ -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 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 ..." + 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 diff --git a/ntimes_minmedmax b/ntimes_minmedmax new file mode 100644 --- /dev/null +++ b/ntimes_minmedmax @@ -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 diff --git a/runAllTests.hs b/runAllTests.hs new file mode 100644 --- /dev/null +++ b/runAllTests.hs @@ -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) diff --git a/run_all_examples.sh b/run_all_examples.sh new file mode 100644 --- /dev/null +++ b/run_all_examples.sh @@ -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." diff --git a/runcnc b/runcnc new file mode 100644 --- /dev/null +++ b/runcnc @@ -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 + diff --git a/scaling.hs b/scaling.hs new file mode 100644 --- /dev/null +++ b/scaling.hs @@ -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" + +