haskell-cnc 0.1.3.1 → 0.1.3.200
raw patch · 31 files changed
+1520/−971 lines, 31 filesdep +bytestringdep +unixsetup-changed
Dependencies added: bytestring, unix
Files
- Intel/Cnc.Header.hs +46/−32
- Intel/Cnc.hs +23/−21
- Intel/Cnc10.hs +72/−0
- Intel/Cnc3.hs +4/−1
- Intel/Cnc4.hs +96/−0
- Intel/Cnc5.hs +8/−14
- Intel/Cnc6.hs +11/−16
- Intel/Cnc7.hs +101/−0
- Intel/Cnc8.hs +10/−4
- Intel/CncPure.hs +37/−41
- Intel/CncUtil.hs +276/−62
- Intel/shared_5_6.hs +95/−41
- LICENSE +26/−497
- Makefile +100/−22
- README.txt +68/−4
- Setup.hs +22/−3
- default_opt_settings.sh +13/−4
- examples/embarrassingly_par.hs +9/−9
- examples/fib.hs +3/−1
- examples/mandel.hs +31/−22
- examples/mandel_opt.hs +10/−8
- examples/nbody.hs +88/−27
- examples/primes.hs +15/−9
- haskell-cnc.cabal +16/−8
- install_environment_vars.sh +1/−0
- ntimes +22/−7
- runAllTests.hs +2/−0
- run_all_examples.sh +116/−49
- runcnc +14/−8
- scaling.hs +178/−56
- timeout.hs +7/−5
Intel/Cnc.Header.hs view
@@ -7,27 +7,10 @@ , OverlappingInstances , DeriveDataTypeable , MultiParamTypeClasses+ , RankNTypes #-} -- 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 @@ -35,6 +18,8 @@ -- probability of duplicating stolen work. -- #define REPEAT_PUT_ALLOWED +-- [2010.06.13] If NOT memoizing... need to turn on REPEAT_PUT_ALLOWED for replay implementations.+ {-| This module implements the Intel Concurrent Collections (CnC) programming model. The variations of this module ("Intel.Cnc3", "Intel.Cnc5", "Intel.Cnc6", and "Intel.Cnc8")@@ -65,17 +50,18 @@ -- |The @StepCode@ monad represents computations -- running inside individual nodes of CnC graphs (in parallel). StepCode(..), - newItemCol, newTagCol, prescribe, + newItemCol, newTagCol, prescribe, prescribeNT, putt, put, get, initialize, finalize, runGraph, itemsToList, stepPutStr, cncPutStr, cncVariant,+ stepUnsafeIO, cncUnsafeIO, -- Undocumented experimental features: Item, newItem, readItem, putItem,- cncFor, cncFor2D,+ cncFor, cncFor2D, graphInStep, tests, -- * Example Program@@ -130,13 +116,23 @@ import qualified Data.Set as Set import qualified Data.HashTable as HT import qualified Data.Map as Map+import qualified System.Posix+import qualified Data.Sequence as Seq+import qualified Data.Array as Array++import qualified System.Random as Random+ import Data.Int import Data.IORef import Data.Word import Data.Typeable import Control.Monad import Control.Monad.Trans+import Control.Monad.Cont as C import qualified Control.Monad.State.Strict as S ++import qualified Control.Monad.Reader as R+ --import qualified Control.Monad.State.Lazy as S import Control.Concurrent.MVar import Control.Concurrent.Chan@@ -186,6 +182,10 @@ -- |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 () +-- |Convenience: Generate a new tag collection and prescribe several steps in one call.+prescribeNT :: [Step tag] -> GraphCode (TagCol tag)+prescribeNT ls = do nt <- newTagCol; forM_ ls (prescribe nt); return nt+ -- |Put-Tag. Push a control tag out into the computation graph. #ifdef MEMOIZE putt :: Ord tag => TagCol tag -> tag -> StepCode ()@@ -200,10 +200,11 @@ -- |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+initialize :: StepCode () -> GraphCode () -- |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+--finalize :: StepCode a -> GraphCode () -- |Construct a new tag collection. newTagCol :: GraphCode (TagCol tag)@@ -260,7 +261,7 @@ 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.+-- It is common to all the scheduler variants. -- -- FIXME: Consider a trampoline. Some schedulers may stack leak. --proto_putt :: Ord a => ([Step a] -> a -> StepCode b) -> TagCol a -> a -> StepCode b@@ -305,6 +306,9 @@ runGraph x = unsafePerformIO x #endif +-- Currently these are undocumented and unofficial:+stepUnsafeIO :: IO a -> StepCode a +cncUnsafeIO :: IO a -> GraphCode a stepUnsafeIO io = STEPLIFT io cncUnsafeIO io = GRAPHLIFT io @@ -374,7 +378,7 @@ putt t1 'b' putt t1 'a' - let incrStep d1 (t2,d2) tag = + let incrStep d1 (t2,d2) (tag::Char) = do n <- get d1 tag put d2 tag (n+1) putt t2 tag@@ -391,6 +395,7 @@ tests = TestList [ smalltest ] #endif + -------------------------------------------------------------------------------- -- EXPERIMENTAL: --------------------------------------------------------------------------------@@ -400,14 +405,18 @@ readItem :: Item a -> StepCode a putItem :: Item a -> a -> StepCode () -#if CNC_SCHEDULER != 3 && CNC_SCHEDULER != 5+-- #if CNC_SCHEDULER != 3 && CNC_SCHEDULER != 5+#ifndef DEFINED_free_items 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 +-- [2010.10.07] New, more dynamic step API+forkStep :: StepCode () -> StepCode () + -- Internal function. We may allow extending the graph from within a -- step. I'm not sure what the best name for this is. graphInStep :: GraphCode a -> StepCode a@@ -431,19 +440,21 @@ -- -- It may be nice under some schedulers to use forkOnIO to explicitly -- disseminate the ranges to processors. This alas wouldn't work well--- with nested cncFor loops. But if we disencourage those and+-- with nested cncFor loops. But if we discourage those and -- explicitly provide cncFor2D etc... -- cncFor start end body = - do ts <- graphInStep newTagCol- --stepPutStr$ "Performing cncFor on range " ++ show (start,end) ++ "\n"- graphInStep$ prescribe ts$ \(x,y) -> - do --stepPutStr$ " Executing range segment: "++ show (x,y) ++ "\n"- for_ x (y+1) body+ do --stepPutStr$ "Performing cncFor on range " ++ show (start,end) ++ "\n"+ let run (x,y) = do --stepPutStr$ " Executing range segment: "++ show (x,y) ++ "\n"+ for_ x (y+1) body+ range_segments = splitInclusiveRange (4*numCapabilities) (start,end) --stepPutStr$ "Desired segments "++ show (4*numCapabilities) ++ " putting first segment...\n"- let range_segments = splitInclusiveRange (4*numCapabilities) (start,end)+ -- [2010.10.07] Updating this to use forkStep:+ --ts <- graphInStep newTagCol+ --graphInStep$ prescribe ts run --stepPutStr$ "PUTTING RANGES "++ show (length range_segments) ++" "++ show range_segments ++"\n"- forM_ range_segments (putt ts)+ --forM_ range_segments (putt ts)+ forM_ range_segments (\ pr -> forkStep (run pr)) #endif #ifndef SUPPRESS_cncFor2D@@ -463,6 +474,9 @@ -- for_ s2 (e2+1) (body i) #endif ++-- instance Show (StepCode ()) where +-- show ref = "<StepCode () action>" --------------------------------------------------------------------------------
Intel/Cnc.hs view
@@ -7,44 +7,46 @@ , OverlappingInstances , DeriveDataTypeable , MultiParamTypeClasses+ , NamedFieldPuns+ , RankNTypes #-} {-# 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+#warning "Cnc.hs -- CNC_SCHEDULER unset, defaulting to scheduler 7 "+#define CNC_SCHEDULER 7 #endif #if CNC_SCHEDULER == 3 #include "Cnc3.hs"+#elif CNC_SCHEDULER == 4+#include "Cnc4.hs" #elif CNC_SCHEDULER == 5 #include "Cnc5.hs" #elif CNC_SCHEDULER == 6 #include "Cnc6.hs"+#elif CNC_SCHEDULER == 7+#include "Cnc7.hs" #elif CNC_SCHEDULER == 8 #include "Cnc8.hs"+#elif CNC_SCHEDULER == 9+#include "Cnc9.hs"++#elif CNC_SCHEDULER == 10+#include "Cnc10.hs"++#elif CNC_SCHEDULER == 11+#include "Cnc11.hs"++-- TEMP:+#elif CNC_SCHEDULER == 99+#include "Cnc10ver1.hs"+ #else-#error "Cnc.hs -- CNC_SCHEDULER is not set to a support scheduler: {3,4,5,6,8}"+#error "Cnc.hs -- CNC_SCHEDULER is not set to a support scheduler: {3,4,5,6,7,8,10,11}" #endif
+ Intel/Cnc10.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , RankNTypes+ #-}++#ifndef MODNAME+#define MODNAME Intel.Cnc10+#endif+#define CNC_SCHEDULER 10+#define STEPLIFT C.liftIO$ R.liftIO$+#define GRAPHLIFT C.liftIO$ R.liftIO$++#define SUPPRESS_put+#define SUPPRESS_newItemCol+#define SUPPRESS_newTagCol+#define SUPPRESS_itemsToList+#define SUPPRESS_runGraph+++#warning "Loading new split version..."++#include "Cnc.Header.hs"++-----------------------------------------------------------------------------++-- This version uses a simple shared workpool (like 4,5,6,7).++data Sched = Sched + { workpool :: HotVar [StepCode ()],+ myid :: Int+ }+ deriving Show++defaultState = do+ pool <- newHotVar []+ return$ Sched { workpool=pool, myid = -999 }+++finalize finalAction = + proto_finalize $ \ joiner -> do+ -- Wait till all workers complete.+ GRAPHLIFT forM_ [1.. numCapabilities] $ \_ -> readChan joiner+ --cncPutStr$ " *** Workers returned, now finalize action:\n"+ finalAction ++itemsToList col = + do + m <- STEPLIFT readHotVar col+ let ls = Map.toList m + return$ map (\ (k,either) -> + case either of + Left b -> (k,b)+ Right _ -> error$ "itemsToList: no value for tag: " ++ show k+ ) ls++ --error "itemstolist not implemented yet for this scheduler" -- XXX++quiescence_support=True++numWorkers = numCapabilities++-----------------------------------------------------------------------------++-- Load the work sharing task-pool:+#include "simple_stack.hs"++-- Load the core of the new ContT implementation (Simon's):+#include "CncSM.hs"
Intel/Cnc3.hs view
@@ -16,6 +16,7 @@ #define CNC_SCHEDULER 3 #define STEPLIFT id$ #define GRAPHLIFT id$+#define DEFINED_free_items -- #define SUPPRESS_cncFor -- #define SUPPRESS_cncFor2D #include "Cnc.Header.hs"@@ -30,11 +31,13 @@ -- Version 3: Here we try for forked parallelism: ------------------------------------------------------------ +forkStep s = do forkIO s; return ()+ 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 ())+ foldM (\ () step -> do forkStep (step tag); return ()) () steps )
+ Intel/Cnc4.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , TypeFamilies + , UndecidableInstances+ , OverlappingInstances+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , NamedFieldPuns+ #-}+-- State monad transformer is needed for both step & graph:+#ifndef MODNAME+#define MODNAME Intel.Cnc4+#endif+#define CNC_SCHEDULER 4+#define STEPLIFT S.lift$+#define GRAPHLIFT S.lift$+#define SUPPRESS_runGraph+#define DEFINED_free_items+#include "Cnc.Header.hs"++------------------------------------------------------------+-- Version 4: Global work queue and worker threads that spin until+-- execution is finished. Note, this ALSO includes the mortal threads+-- business from version 6.++#include "shared_5_6.hs"+++-- FIXME: TODO: This version needs the Mortal threads mechanism in version 6...+-- Otherwise it creates extra threads that SPIN, which is terrible.++----------------------------------------------------------------------------------------------------+ +get col tag = ver5_6_core_get (return ()) col tag++-- get col tag = +-- do (HiddenState5 { stack, mortal }) <- S.get+-- let io = do myId <- myThreadId +-- modifyHotVar_ mortal (Set.insert myId)+-- ver5_6_core_get io col tag+++-- At finalize time we set up the workers and run them.+finalize userFinalAction = + do (state @ HiddenState5 { stack, numworkers, mortal } ) <- S.get+ + let worker id = + do x <- STEPLIFT tryPop stack+ let lifecheck = + do myId <- STEPLIFT myThreadId+ set <- STEPLIFT readHotVar mortal+ return (Set.notMember myId set)+ case x of + Nothing -> do n <- STEPLIFT readHotVar numworkers+ --STEPLIFT putStrLn$ "NUM WORKERS IS " ++ show n++"\n"+ -- numWorkers == 0 implies a message to shutdown.+ if n == 0 + then do --STEPLIFT putStrLn$ "================ SHUTTING DOWN "++ show id ++"=============="+ return () + else do -- A mortal thread should never spin:+ b <- lifecheck+ if b + -- Should we be cooperative by sleeping a little?+ --System.Posix.usleep 1000+ then do STEPLIFT yield+ worker id+ else return ()+ Just action -> do action+ b <- lifecheck+ if b then worker id else return ()++ let finalAction = + do S.modify$ \stt -> stt { myid = numCapabilities-1 }++ val <- userFinalAction+ -- UGLY Convention: reusing numworkers variable that's already in the type:+ -- This variable becomes a "command" rather than diagnosing the current state. Zero means stop working.+ STEPLIFT writeHotVar numworkers 0 -- Shut workers down (eventually).+ --STEPLIFT putStrLn$ " ..............>>>>>>>>>>>>>>>>>>> Initiated shutdown...........\n"+ return val++ -- The final action will itself be one of the threads and it+ -- will replace itself when it blocks on a get. Therefore we+ -- request one fewer worker:+ --ver5_6_core_finalize joiner finalAction worker False (numCapabilities-1)+ -- + -- FIXME: TODO: Currently having inexplicable problems on embarassingly_par with the N-1 approach.+ -- For now oversubscribing intentionally as the lesser of evils:+ ver5_6_core_finalize (error "joiner unused") finalAction worker False numCapabilities (\_ -> return ())++------------------------------------------------------------++quiescence_support = False+
Intel/Cnc5.hs view
@@ -7,6 +7,7 @@ , OverlappingInstances , DeriveDataTypeable , MultiParamTypeClasses+ , NamedFieldPuns #-} -- State monad transformer is needed for both step & graph: #ifndef MODNAME@@ -16,6 +17,7 @@ #define STEPLIFT S.lift$ #define GRAPHLIFT S.lift$ #define SUPPRESS_runGraph+#define DEFINED_free_items #include "Cnc.Header.hs" ------------------------------------------------------------@@ -32,29 +34,21 @@ -- 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+get col tag = ver5_6_core_get (return ()) col tag -- At finalize time we set up the workers and run them. finalize finalAction = - do (HiddenState5 (stack, _, _, _)) <- S.get+ do (HiddenState5 { stack }) <- S.get joiner <- GRAPHLIFT newChan - let worker = + let worker id = do x <- STEPLIFT tryPop stack case x of - Nothing -> STEPLIFT writeChan joiner ()+ Nothing -> STEPLIFT writeChan joiner id Just action -> do action- worker - ver5_6_core_finalize joiner finalAction worker + worker id + ver5_6_core_finalize joiner finalAction worker True numCapabilities (\_ -> return ()) ------------------------------------------------------------ quiescence_support = True--type Item = MVar-newItem = STEPLIFT newEmptyMVar-readItem = grabWithBackup (return ())-putItem mv x = - do b <- STEPLIFT tryPutMVar mv x- if b then return ()- else error "Violation of single assignment rule; second put on Item!"
Intel/Cnc6.hs view
@@ -7,6 +7,7 @@ , OverlappingInstances , DeriveDataTypeable , MultiParamTypeClasses+ , NamedFieldPuns #-} -- State monad transformer is needed for both step & graph: #ifndef MODNAME@@ -16,6 +17,7 @@ #define STEPLIFT S.lift$ #define GRAPHLIFT S.lift$ #define SUPPRESS_runGraph+#define DEFINED_free_items #include "Cnc.Header.hs" ------------------------------------------------------------@@ -36,32 +38,25 @@ -- Then at finalize time we set up the workers and run them. finalize finalAction = do joiner <- GRAPHLIFT newChan - (HiddenState5 (stack, _, _, mortalthreads)) <- S.get- let worker :: StepCode () = + (HiddenState5 { stack, mortal }) <- S.get+ let worker id = do x <- STEPLIFT tryPop stack case x of - Nothing -> STEPLIFT writeChan joiner ()+ Nothing -> STEPLIFT writeChan joiner id Just action -> do action myId <- STEPLIFT myThreadId- set <- STEPLIFT readIORef mortalthreads+ set <- STEPLIFT readHotVar mortal if Set.notMember myId set- then worker -- keep going- else STEPLIFT writeChan joiner ()- ver5_6_core_finalize joiner finalAction worker+ then worker id -- keep going+ else STEPLIFT writeChan joiner id+ ver5_6_core_finalize joiner finalAction worker True numCapabilities (\_ -> return ()) get col tag = - do (HiddenState5 (stack, _, _, mortalthreads)) <- S.get+ do (HiddenState5 { stack, mortal }) <- S.get let io = do myId <- myThreadId - atomicModifyIORef mortalthreads (\s -> (Set.insert myId s, ()))+ modifyHotVar_ mortal (Set.insert myId) ver5_6_core_get io col tag quiescence_support = True------------------------------------------------------------------ Version 7: Now with healing -- bring back worker threads that died--- prematurely.---- TODO: Improve on 6 by correcting premature deaths.
+ Intel/Cnc7.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE FlexibleInstances+ , BangPatterns+ , MagicHash + , ScopedTypeVariables+ , TypeFamilies + , UndecidableInstances+ , OverlappingInstances+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , NamedFieldPuns+ #-}+-- State monad transformer is needed for both step & graph:+#ifndef MODNAME+#define MODNAME Intel.Cnc7+#endif+#define CNC_SCHEDULER 7+#define STEPLIFT S.lift$+#define GRAPHLIFT S.lift$+#define SUPPRESS_runGraph+#define DEFINED_free_items+#include "Cnc.Header.hs"++------------------------------------------------------------+-- Version 7: Now with healing -- bring back worker threads that died+-- prematurely. Specifically, in this version we use a global work+-- queue but we heal workers when we put into an empty queue.+++#define SUPPRESS_HiddenState5+#include "shared_5_6.hs"++-- We extend the type with the "deadset" field:+data HiddenState5 = + HiddenState5 { stack :: HotVar [StepCode ()], + numworkers :: HotVar Int, + makeworker :: Int -> IO (), + mortal :: HotVar (Set.Set ThreadId),+ myid :: Int,+ deadset :: HotVar [Int]+ }+ deriving Show++defaultState = + do hv <- newHotVar []+ hv2 <- newHotVar 0+ hv3 <- newHotVar Set.empty+ hv4 <- newHotVar []+ let msg = "Intel.Cnc"++ show CNC_SCHEDULER ++" internal error: makeworker thunk used before initalized"+ return$ HiddenState5 { stack = hv, numworkers = hv2, makeworker= error msg, + mortal = hv3, myid = -1, + deadset = hv4 }++-- A push that also wakes the dead.+stepcode_push :: HotVar [a] -> a -> StepCode ()+stepcode_push stack val = + -- If push onto an empty stack, wake up deadset. + do old <- STEPLIFT modifyHotVar stack (\ls -> (val:ls, ls))+ if null old+ -- Wake up the dead:+ then do (HiddenState5 { numworkers, makeworker, deadset }) <- S.get+ dead <- STEPLIFT modifyHotVar deadset (\old -> ([], old))+ let len = length dead+ --STEPLIFT putStrLn$ " ********** Waking the dead: " ++ show dead + if len > 0 + then do STEPLIFT modifyHotVar_ numworkers (+ len)+ STEPLIFT forM_ dead (forkIO . makeworker)+ else return ()+ else return () ++putt = proto_putt+ (\ steps tag -> + do (HiddenState5 { stack }) <- S.get+ foldM (\ () step -> stepcode_push stack (step tag))+ () steps)++-- New, more dynamic API:+forkStep s = + do (HiddenState5 { stack }) <- S.get+ stepcode_push stack s++get col tag = ver5_6_core_get (return ()) col tag++-- At finalize time we set up the workers and run them.+finalize userFinalAction = + do (HiddenState5 { stack, deadset }) <- S.get+ joiner <- GRAPHLIFT newChan + let worker id = + do x <- STEPLIFT tryPop stack+ case x of + Nothing -> STEPLIFT writeChan joiner id+ Just action -> do action+ worker id++ let joinerHook id = modifyHotVar_ deadset (id:)++ ver5_6_core_finalize joiner userFinalAction worker True numCapabilities joinerHook++------------------------------------------------------------++quiescence_support = True+
Intel/Cnc8.hs view
@@ -81,9 +81,13 @@ -- parallel and then blocking on the result. launch_steps :: [StepCode ()] -> StepCode () launch_steps mls = - foldM (\ () m -> spawn (do try_stepcode m m; return ()))+-- foldM (\ () m -> spawn (do try_stepcode m m; return ()))+ foldM (\ () m -> forkStep m) () mls +-- New, more dynamic API:+forkStep s = + spawn (do try_stepcode s s; return ()) -- 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@@ -161,6 +165,8 @@ -- 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 @@ -176,9 +182,9 @@ 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+initfin str m = do + x <- try_stepcode (error str) m+ case x of Nothing -> (error str) Just v -> return v initialize = initfin "Get failed within initialize action!"
Intel/CncPure.hs view
@@ -4,31 +4,13 @@ , 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, + newItemCol, newTagCol, prescribe, prescribeNT, putt, put, get, initialize, finalize, @@ -40,7 +22,7 @@ where #endif -import Data.Array as Array+import qualified Data.Array as Array import Data.List as List import Data.Set as Set@@ -88,6 +70,10 @@ -- Below you will see two interfaces, the "raw" functional interface -- (functions prefixed with "_") and a nicer monadic interface. +-- TODO: It is likely that this can be much simplified by using a+-- separate library for heterogenously typed collections... I believe+-- I saw such a thing on hackage.+ ------------------------------------------------------------ -- Toggles @@ -537,7 +523,7 @@ work_queues <- mapM (\_ -> newChan) [1..10] -- For fast indexing:- let queue_arr = listArray (0,length work_queues-1) work_queues+ let queue_arr = Array.listArray (0,length work_queues-1) work_queues ------------------------------------------------------------ let --perms = let p = permutations work_queues in listArray (0,length p - 1) p@@ -604,23 +590,23 @@ readIORef worldref - runSomeSteps2 :: Graph -> Collections -> Int -> Chan NewTag -> Bundle () -> [PrimedStep] -> IO (Bundle ())-runSomeSteps2 g w n c (rec @ B{..}) primed = +runSomeSteps2 g w n c (record@(B{..})) primed = +--runSomeSteps2 g w n c record primed = let (B{..}) = record in 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 n <= 0 then return record else -- If we run out of (readily available) work we have to stop: do b <- isEmptyChan c- if b then return rec else+ if b then return record 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)+ runSomeSteps2 g w n c record (callSteps g id tag) -- In this case we have primed steps and just need to do the real work: pstep:tl ->@@ -628,13 +614,13 @@ -- Accumulate blocked tokens: newb@(Block _ _) -> runSomeSteps2 g w (n-1) c - rec{blocked= newb:blocked, bsteps= pstep:bsteps} tl+ record{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+ record{outtags=newtags++outtags, items=newitems++items} tl -- ==============================================================================@@ -760,7 +746,7 @@ 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+runSomeSteps _ _ n (record @ B{intags=[]}) [] = record --trace ("Out of work.. stopping blocked: "++ show (length blocked)) $ --(blocked,bsteps,[],items) @@ -770,26 +756,26 @@ -- 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}) [] = +runSomeSteps graph w n (record @ B{intags = hd:tl}) [] = case hd of NT id tag ->- runSomeSteps graph w n rec{intags=tl} (callSteps graph id tag)+ runSomeSteps graph w n record{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) = +runSomeSteps g w n (record @ 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+ record{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+ record{outtags=newtags++outtags, items=newitems++items} tl --------------------------------------------------------------------------------@@ -837,6 +823,14 @@ \ w tags items -> (Just (), Done (_putt col tag : tags) items) +-- UNFINISHED:+-- HACK: send a tag to the "universal" tag/step collection to do a forkStep+-- forkStep stp = CC $ +-- \ w tags items -> +-- (Just (), Done (NT (TCID 0) stp : tags) items)+--forkStep stp = error "forkStep not implemented yet in CnCPure.hs"+-- This just does it in serial:+forkStep stp = do stp; return () -- The graph monad captures code that builds graphs: instance Monad GraphCode where @@ -960,17 +954,17 @@ -- stepPutStr' msg = -- CC$ \w nt ni -> trace msg (Just (), Done nt ni) -cncUnsafeIO :: IO () -> GraphCode ()+cncUnsafeIO :: IO a -> GraphCode a cncUnsafeIO action = GC$ \w g it -> - seq (unsafePerformIO action)- (w,g,it,())+ let v = unsafePerformIO action+ in seq v (w,g,it,v) -stepUnsafeIO :: IO () -> StepCode ()+stepUnsafeIO :: IO a -> StepCode a stepUnsafeIO action = CC$ \w nt ni -> - seq (unsafePerformIO action)- (Just (), Done nt ni)+ let v = unsafePerformIO action+ in seq v (Just v, Done nt ni) stepPutStr str = stepUnsafeIO (putStr str) cncPutStr str = cncUnsafeIO (putStr str)@@ -998,7 +992,9 @@ cncFor s1 e1 $ \ i -> cncFor s2 e2 (body i) -+-- prescribe :: Ord a => TagCol a -> (a -> StepCode ()) -> GraphCode ()+prescribeNT :: Ord tag => [tag -> StepCode ()] -> GraphCode (TagCol tag)+prescribeNT ls = do nt <- newTagCol; forM_ ls (prescribe nt); return nt -------------------------------------------------------------------------------- -- Testing:
Intel/CncUtil.hs view
@@ -6,26 +6,9 @@ , UndecidableInstances , OverlappingInstances , MultiParamTypeClasses+ , FunctionalDependencies #-} {-# 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@@ -35,12 +18,17 @@ GMapKey (..), Hashable (..), (!),+ testCase, tests, MutableMap, newMutableMap, assureMvar, mmToList,- HotVar, newHotVar, modifyHotVar, modifyHotVar_,+ HotVar, newHotVar, readHotVar, writeHotVar, modifyHotVar, modifyHotVar_, + hotVarTransaction, readHotVarRaw, writeHotVarRaw, + ChoosePairRepr, + ChooseRepr, + ) where #else@@ -49,6 +37,7 @@ import GHC.Conc import Control.Concurrent+import Control.Concurrent.QSem import Data.Time.Clock -- Not in 6.10 import qualified Data.Map as DM import qualified Data.IntMap as DI@@ -63,6 +52,7 @@ import Debug.Trace import Test.HUnit+ -- import Test.QuickCheck (quickCheck, (==>)) --------------------------------------------------------------------------------@@ -157,18 +147,33 @@ -- for item collections (in the IO-based Cnc.hs) #ifdef HASHTABLE_TEST-type MutableMap a b = HashTable a (MVar b)++#warning "Enabling HashTable item collections. These are not truly thread safe (yet)."+-- TODO -- try it with a global lock to make it safe.+safe_hashtables = True++withSem lock action = + do waitQSem lock+ x <- action+ signalQSem lock+ return x++type MutableMap a b = (QSem, HT.HashTable a (MVar b)) newMutableMap :: (Eq tag, Hashable tag) => IO (MutableMap tag b)-newMutableMap = HT.new (==) hash-assureMvar col tag = +newMutableMap = do lock <- newQSem 1 + ht <- HT.new (==) hash+ return (lock, ht)+assureMvar (lock,col) tag = + if safe_hashtables then withSem lock lkup else lkup + where + lkup = 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)."+mmToList (lock,ht) = withSem lock$ HT.toList ht #else #ifdef USE_GMAP@@ -232,7 +237,9 @@ -- We want to experiment with all three of these. -#define HOTVAR 1+#ifndef HOTVAR+#define HOTVAR 3+#endif newHotVar :: a -> IO (HotVar a) modifyHotVar :: HotVar a -> (a -> (a,b)) -> IO b modifyHotVar_ :: HotVar a -> (a -> a) -> IO ()@@ -242,14 +249,37 @@ newHotVar = newIORef modifyHotVar = atomicModifyIORef modifyHotVar_ v fn = atomicModifyIORef v (\a -> (fn a, ()))+readHotVar = readIORef+writeHotVar = writeIORef+instance Show (IORef a) where + show ref = "<ioref>" +-- hotVarTransaction = id+hotVarTransaction = error "Transactions not currently possible for IO refs"+readHotVarRaw = readHotVar+writeHotVarRaw = writeHotVar++ #elif HOTVAR == 2 #warning "Using MVars for hot atomic variables."+-- This uses MVars that are always full with *something* type HotVar a = MVar a-newHotVar = newMVar+newHotVar x = do v <- newMVar; putMVar v x; return v modifyHotVar v fn = modifyMVar v (return . fn) modifyHotVar_ v fn = modifyMVar_ v (return . fn)+readHotVar = readMVar+writeHotVar v x = do swapMVar v x; return ()+instance Show (MVar a) where + show ref = "<mvar>" +-- hotVarTransaction = id+-- We could in theory do this by taking the mvar to grab the lock.+-- But we'd need some temporary storage....+hotVarTransaction = error "Transactions not currently possible for MVars"+readHotVarRaw = readHotVar+writeHotVarRaw = writeHotVar++ #elif HOTVAR == 3 #warning "Using TVars for hot atomic variables." -- Simon Marlow said he saw better scaling with TVars (surprise to me):@@ -260,8 +290,19 @@ writeTVar tv x2 return b) modifyHotVar_ tv fn = atomically (do x <- readTVar tv; writeTVar tv (fn x))+readHotVar x = atomically $ readTVar x+writeHotVar v x = atomically $ writeTVar v x+instance Show (TVar a) where + show ref = "<tvar>"++hotVarTransaction = atomically+readHotVarRaw = readTVar+writeHotVarRaw = writeTVar+ #endif +instance Show (IO a) where + show ref = "<io>" --------------------------------------------------------------------------------@@ -279,6 +320,10 @@ instance Hashable Int where hash = HT.hashInt++instance Hashable Int16 where+ hash = HT.hashInt . fromIntegral+ instance Hashable Char where hash = HT.hashInt . fromEnum instance Hashable Word16 where@@ -300,8 +345,6 @@ -- hash = hashInt . fromEnum -- -------------------------------------------------------------------------------- -- Class of types that fit in a machine word. --------------------------------------------------------------------------------@@ -366,14 +409,135 @@ fromIntegral$ n .&. 0xFFFF) +--------------------------------------------------------------------------------+-- A better representation for pair keys+-------------------------------------------------------------------------------- +-- Now we wish to define optimized instances of GMapKey for+-- pairs of items that fit within a word.+-- The following answers Ryan Newton's question++-- Define our own product type, to avoid overlapping instances with the+-- general GMapKey for pairs+-- It's a newtype: it has no run-time overhead+newtype OptimalPair a b = OptimalPair (a,b)+ deriving (Eq,Ord,Show)+-- deriving instance MonadState Int Foo++--instance (Ord (a,b)) => Ord (OptimalPair a b) where +-- compare (OptimalPair t) = compare t++-- Auxiliary class to choose the appropriate pair+class ChoosePairRepr a b pr | a b -> pr where+ choose_pair :: (a,b) -> pr+ choosen_pair :: pr -> (a,b)+++instance ChoosePairRepr Int16 Int16 (OptimalPair Int16 Int16) where+ choose_pair = OptimalPair+ choosen_pair (OptimalPair p) = p++-- Choose a generic pair for all other pairs of values+instance pr ~ (a,b) => ChoosePairRepr a b pr where+ choose_pair = id+ choosen_pair = id+++--prlookup = GM.lookup . choosen_pair -- monomorphism+prlookup x = lookup (choosen_pair x)+++#if 0+-- A specific instance is chosen+test1_choosepair = + let m = empty in+ (m, lookup (choose_pair (1::Int16,2::Int16)) m)+-- Nothing++test2_choosepair = + let m = empty in+ (m, lookup (choose_pair (1::Int64,2::Int64)) m)++#else +test1_choosepair = + let m = empty in+ (m, lookup (pack_repr (1::Int16,2::Int16)) m)++test2_choosepair = + let m = empty in+ (m, lookup (pack_repr (1::Int64,2::Int64)) m)++#endif+ --------------------------------------------------------------------------------+-- Testing a more ambitious option:+--------------------------------------------------------------------------------++--newtype OptimalRepr t = OptimalRepr t deriving (Eq,Ord,Show)++-- It could dispatch to one of these:+-- Only packed would FitInWord+--newtype NormalRepr t = NormalRepr t deriving (Eq,Ord,Show)+newtype OrdOnlyRepr t = OrdOnlyRepr t deriving (Eq,Ord,Show)++newtype PackedRepr t = PackedRepr t deriving (Eq,Ord,Show)++-- Auxiliary class to choose the appropriate pair+class ChooseRepr a b | a -> b where+ pack_repr :: a -> b+ unpack_repr :: b -> a++instance ChooseRepr (Int16,Int16) (PackedRepr (Int16,Int16)) where+ pack_repr = PackedRepr+ unpack_repr (PackedRepr p) = p++--instance (Ord a, b ~ a) => ChooseRepr a (b) where+instance (b ~ a) => ChooseRepr a (b) where+ pack_repr = id+ unpack_repr = id+++-- CONFLICT IN FUNCTIONAL DEPS HERE:+-- Otherwise fall through to a normal representation:+-- --instance ChooseRepr a (NormalRepr b) where+-- instance (Ord b, Ord a, b ~ a) => ChooseRepr a (OrdOnlyRepr b) where+-- pack_repr = OrdOnlyRepr+-- unpack_repr (OrdOnlyRepr p) = p++++--------------------------------------------------------------------------------+-- Types that are simplifiable to other types+--------------------------------------------------------------------------------++-- Same problem with overlaps:+{-+class Simplifyable a b where + simplify :: a -> b+ complicate :: b -> a++instance Simplifyable (a,b,c) (a,(b,c)) where + simplify (a,b,c) = (a,(b,c))+ complicate (a,(b,c)) = (a,b,c)++instance (Simplifyable a b, GMapKey a) => GMapKey b where+ data GMap b v = GMapSmpl (GMap b v) deriving Show+ empty = GMapSmpl empty+ lookup k (GMapSmpl m) = lookup (simplify k) m+ insert k v (GMapSmpl m) = GMapSmpl (insert (simplify k) v m)+ alter fn k (GMapSmpl m) = GMapSmpl (alter fn (simplify k) m)+ toList (GMapSmpl m) = map (\ (i,v) -> (complicate i, v)) $ + toList m+-}+ +-------------------------------------------------------------------------------- -- ADT definition for generic Maps:+-- TODO: Factor into a separate module: -------------------------------------------------------------------------------- -- |Class for generic map key types. By using indexed type families,--- |each key type may correspond to a different data structure that--- |implements it.+-- 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@@ -384,6 +548,29 @@ -------------------------------------------------------------------------------- +#if 0+instance (Show a, Show b, Ord a, Ord b, FitInWord (a,b)) + => GMapKey (OptimalPair a b) where+ data GMap (OptimalPair a b) v = GMapOP (DI.IntMap v) deriving Show+ empty = GMapOP DI.empty+ lookup (OptimalPair k) (GMapOP m) = DI.lookup (fromIntegral$ toWord k) m+ insert (OptimalPair k) v (GMapOP m) = GMapOP (DI.insert (wordToInt$ toWord k) v m)+ alter fn (OptimalPair k) (GMapOP m) = GMapOP (DI.alter fn (wordToInt$ toWord k) m)+ toList (GMapOP m) = map (\ (i,v) -> (OptimalPair$ fromWord$ intToWord i, v)) $ + DI.toList m+#else+instance (Show a, Show b, Ord a, Ord b, FitInWord (a,b)) + => GMapKey (PackedRepr (a,b)) where+ data GMap (PackedRepr (a,b)) v = GMapPR (DI.IntMap v) deriving Show+ empty = GMapPR DI.empty+ lookup (PackedRepr k) (GMapPR m) = DI.lookup (fromIntegral$ toWord k) m+ insert (PackedRepr k) v (GMapPR m) = GMapPR (DI.insert (wordToInt$ toWord k) v m)+ alter fn (PackedRepr k) (GMapPR m) = GMapPR (DI.alter fn (wordToInt$ toWord k) m)+ toList (GMapPR m) = map (\ (i,v) -> (PackedRepr$ fromWord$ intToWord i, v)) $ + DI.toList m+#endif++ -- What problems was I running into here: -- It's hard to avoid conflicting instances, for example with the tuple instance. -- I think I may need a NotFitInWord class constraint..@@ -426,6 +613,11 @@ toList (GMapBool (Just a) (Just b)) = [(True,a),(False,b)] ------------------------------------------------------------ ++------------------------------------------------------------+-- All keys that can be represented by INTS:+------------------------------------------------------------+ -- GMaps on Int keys become Data.IntMaps: instance GMapKey Int where data GMap Int v = GMapInt (DI.IntMap v) deriving Show@@ -485,18 +677,19 @@ 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!!+-- TODO: Int64 + Word64 -- Can't get past the "Conflicting family instance declarations" -- instance GMapKey (Int16, Int16) where--- data GMap (Int16,Int16) v = GMapInt16Pair (GMap Int v) deriving Show--- empty = trace "<<< Constructing Double-Int16 GMAP (Intmap) >>>> " $ --- GMapInt16Pair empty--- lookup k (GMapInt16Pair m) = lookup (fromIntegral k) m--- insert k v (GMapInt16Pair m) = GMapInt16Pair (insert (fromIntegral k) v m)--- alter fn k (GMapInt16Pair m) = GMapInt16Pair (alter fn (fromIntegral k) m)--- toList (GMapInt16Pair m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)-+#if 0+ data GMap (Int16,Int16) v = GMapInt16Pair (GMap Int v) deriving Show+ empty = trace "<<< Constructing Double-Int16 GMAP (Intmap) >>>> " $ + GMapInt16Pair empty+ lookup k (GMapInt16Pair m) = lookup (fromIntegral k) m+ insert k v (GMapInt16Pair m) = GMapInt16Pair (insert (fromIntegral k) v m)+ alter fn k (GMapInt16Pair m) = GMapInt16Pair (alter fn (fromIntegral k) m)+ toList (GMapInt16Pair m) = map (\ (i,v) -> (fromIntegral i,v)) (toList m)+#endif #endif @@ -523,21 +716,7 @@ 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)@@ -552,8 +731,23 @@ map (\ (a,v) -> (Left a, v)) (toList gm1) ++ map (\ (b,v) -> (Right b, v)) (toList gm2) ++-- TODO: Use template haskell to generalize this strategy to other tuples:+-- For now here's a hack:+-- Could simplify to nested binary tuples....+instance (GMapKey a, GMapKey b, GMapKey c) => GMapKey (a,b,c) where+ data GMap (a,b,c) v = GMapTriple (DM.Map (a,b,c) v) deriving Show+ empty = GMapTriple DM.empty+ lookup k (GMapTriple m) = DM.lookup k m+ insert k v (GMapTriple m) = GMapTriple (DM.insert k v m)+ alter fn k (GMapTriple m) = GMapTriple (DM.alter fn k m)+ toList (GMapTriple m) = DM.toList m++++ -- |GMaps with list indices could be treated like tuples (nested--- |maps). Instead, we put them in a regular Data.Map.+-- 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@@ -563,7 +757,30 @@ toList (GMapList m) = DM.toList m +-------------------------------------------------------------------------------- +-- We would love to just do this -- fall through for any old Ord representation:+-- instance Ord a => GMapKey a where+-- data GMap a v = GMapOrd (DM.Map a v) deriving Show+-- empty = GMapOrd DM.empty+-- lookup k (GMapOrd m) = DM.lookup k m+-- insert k v (GMapOrd m) = GMapOrd (DM.insert k v m)+-- alter fn k (GMapOrd m) = GMapOrd (DM.alter fn k m)+-- toList (GMapOrd m) = DM.toList m+++instance GMapKey Int64 where+ data GMap Int64 v = GMapInt64 (DM.Map Int64 v) deriving Show+ empty = GMapInt64 DM.empty+ lookup k (GMapInt64 m) = DM.lookup k m+ insert k v (GMapInt64 m) = GMapInt64 (DM.insert k v m)+ alter fn k (GMapInt64 m) = GMapInt64 (DM.alter fn k m)+ toList (GMapInt64 m) = DM.toList m++++--------------------------------------------------------------------------------+ (!) :: (GMapKey k) => GMap k v -> k -> v (!) m k = case lookup k m of@@ -615,16 +832,16 @@ -- [2010.05.19] TEMPTOGGLE uncommenting to compile on laptop: {- instance FitInWord t => J.JE t where- toWord = undefined- fromWord = undefined+ toWord = + fromWord = -- 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+ lookup2 = + insert2 = -- empty2 = do x <- J.new -- return $ GMapInt2 x -- lookup2 k (GMapInt2 r) = do m <- readIORef r@@ -643,9 +860,6 @@ -- 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 @@ -655,7 +869,6 @@ test1 = testCase "Spot check list lengths"$ assertEqual "splitN" [[1,2], [3,4,5]] (splitN 2 [1..5]) - -- [2010.05.31] I don't have quickcheck working under 6.13.xx -- test2 = testCase "Quickcheck splitN - varying split size"$ -- quickCheck$ (\ (n::Int) -> n>0 ==> @@ -664,3 +877,4 @@ -- tests = TestList [test1, test2] tests = TestList [test1]+
@@ -2,6 +2,7 @@ -- Pieces that are common to version 5 and 6 ------------------------------------------------------------ +#ifndef SUPPRESS_AllTypes type TagCol a = (IORef (Set.Set a), IORef [Step a]) type ItemCol a b = MutableMap a b @@ -11,24 +12,53 @@ -- In this version we need to thread the state through the graph code as well: type GraphCode a = StepCode a+#endif +-- Individual threads have numeric IDs. -- 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+-- (3) the "make worker" function to spawn new threads (given ID as input) -- (4) the set of "mortal threads"-newtype HiddenState5 = HiddenState5 (HotVar [StepCode ()], HotVar Int, IO (), HotVar (Set.Set ThreadId))+-- (5) the ID of the current thread+#ifndef SUPPRESS_HiddenState5+data HiddenState5 = + HiddenState5 { stack :: HotVar [StepCode ()], + numworkers :: HotVar Int, + makeworker :: Int -> IO (), + mortal :: HotVar (Set.Set ThreadId),+ myid :: Int + } deriving Show+defaultState = + do hv <- newHotVar []+ hv2 <- newHotVar 0+ hv3 <- newHotVar Set.empty+ let msg = "Intel.Cnc"++ show CNC_SCHEDULER ++" internal error: makeworker thunk used before initalized"+ return$ HiddenState5 { stack = hv, numworkers = hv2, makeworker= error msg, + mortal = hv3, myid = -1 }+putt = proto_putt+ (\ steps tag -> + do (HiddenState5 { stack }) <- S.get+ foldM (\ () step -> STEPLIFT push stack (step tag))+ () steps) -instance Show (IORef a) where - show ref = "<ioref>"-instance Show (IO a) where - show ref = "<io>"+-- New, more dynamic API:+forkStep s = + do (HiddenState5 { stack }) <- S.get+ STEPLIFT push stack s -atomicIncr x = atomicModifyIORef x (\n -> (n+1, ()))-atomicDecr x = atomicModifyIORef x (\n -> (n-1, ()))+#endif +instance Show (Int -> IO ()) where+ show _ = "<int to IO unit function>" +atomicIncr :: Num n => HotVar n -> IO ()+atomicDecr :: Num n => HotVar n -> IO ()+atomicIncr x = modifyHotVar_ x (+ 1)+atomicDecr x = modifyHotVar_ x (\n -> n-1)++ -- A simple stack interface: ---------------------------------------- push :: HotVar [a] -> a -> IO ()@@ -40,7 +70,19 @@ tryfirst (a:b) = (b, Just a) ---------------------------------------- +issueReplacement = + do (HiddenState5 { numworkers, makeworker, myid }) <- S.get+ STEPLIFT atomicIncr numworkers + -- If this were CPS then we would just give our+ -- continuation to the forked thread. Alas, no.+-- #define PIN_THREADS+#ifdef PIN_THREADS+#warning "Experimenting with forkonIO rather than forkIO for spawning."+ STEPLIFT forkOnIO myid (makeworker myid)+#else+ STEPLIFT forkIO (makeworker myid)+#endif -- FIXME: [2010.05.05] I believe this has a problem. -- tryTakeMVar can fail spuriously if there's a collision with another@@ -52,14 +94,7 @@ -- good reason). When the code below falls back to readMVar that -- should succeed. -issueReplacement = - do (HiddenState5 (stack, numworkers, makeworker, _)) <- S.get- STEPLIFT atomicIncr 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-+-- Grab an mvar, but bring in reinforcements if we need to go down: grabWithBackup hook mvar = do hopeful <- STEPLIFT tryTakeMVar mvar case hopeful of @@ -76,50 +111,69 @@ ver5_6_core_get hook (col) tag = - do (HiddenState5 (stack, numworkers, makeworker, _)) <- S.get+ do --(HiddenState5 { stack, 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, _, mortal)) <- S.get- --GRAPHLIFT writeIORef global_makeworker makeworker- let mkwrkr = do S.runStateT worker state2; return ()- state2 = HiddenState5 (stack, numworkers, mkwrkr, mortal) - GRAPHLIFT atomicModifyIORef numworkers (\n -> (n + numCapabilities, ()))+ver5_6_core_finalize :: Chan Int -> + StepCode b -> + (Int -> StepCode ()) -> + Bool -> + Int -> + (Int -> IO ()) + -> GraphCode b+ver5_6_core_finalize joiner finalAction worker shouldWait numDesired joinerHook = + do (state1 @ HiddenState5 { numworkers, myid }) <- S.get++ -- Here we install the makeworker funciton in the monad state:+ let mkwrkr id = do S.runStateT (worker id) (state2 id); return ()+ state2 id = state1 { makeworker = mkwrkr, myid = id }+ -- Write it back for the "finalAction" below:+ S.put (state2 myid)+ GRAPHLIFT modifyHotVar_ numworkers (+ numDesired)+ -- Fork one worker per thread: #ifdef DEBUG_HASKELL_CNC- S.lift$ putStrLn$ "Forking "++ show numCapabilities ++" threads"+ GRAPHLIFT putStrLn$ "Forking "++ show numDesired ++" threads"+#endif +#ifdef PIN_THREADS+ GRAPHLIFT forM_ [0..numDesired-1] (\n -> forkOnIO n (mkwrkr n)) +#else+ GRAPHLIFT forM_ [0..numDesired-1] (\n -> forkIO (mkwrkr n)) #endif- S.lift$ mapM (\n -> forkIO mkwrkr) [0..numCapabilities-1] - -- This waits for quiescense:- let waitloop = do num <- readIORef numworkers++ -- This waits for quiescense BEFORE doing the final action+ let waitloop = do num <- readHotVar numworkers if num == 0 then return () else do #ifdef DEBUG_HASKELL_CNC putStrLn ("=== Waiting on workers: "++ show num ++" left") #endif- readChan joiner+ id <- readChan joiner -- A return message.+ joinerHook id+ atomicDecr numworkers waitloop- S.lift$ waitloop+ if shouldWait then GRAPHLIFT waitloop else return () finalAction -putt = proto_putt- (\ steps tag -> - do (HiddenState5 (stack, _, _, _)) <- S.get- foldM (\ () step -> STEPLIFT push stack (step tag))- () steps)- runGraph x = unsafePerformIO (runState x) runState x =- do hv <- newHotVar []- hv2 <- newHotVar 0- hv3 <- newHotVar Set.empty- (a,_) <- S.runStateT x (HiddenState5 (hv,hv2, error "Intel.Cnc6 internal error: makeworker thunk used before initalized", hv3))+ do state <- defaultState + (a,_) <- S.runStateT x state return a++------------------------------------------------------------+-- Experimental: Free floating items:++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!"
LICENSE view
@@ -1,502 +1,31 @@- GNU LESSER GENERAL PUBLIC LICENSE- Version 2.1, February 1999-- Copyright (C) 1991, 1999 Free Software Foundation, Inc.- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.--[This is the first released version of the Lesser GPL. It also counts- as the successor of the GNU Library Public License, version 2, hence- the version number 2.1.]-- Preamble-- The licenses for most software are designed to take away your-freedom to share and change it. By contrast, the GNU General Public-Licenses are intended to guarantee your freedom to share and change-free software--to make sure the software is free for all its users.-- This license, the Lesser General Public License, applies to some-specially designated software packages--typically libraries--of the-Free Software Foundation and other authors who decide to use it. You-can use it too, but we suggest you first think carefully about whether-this license or the ordinary General Public License is the better-strategy to use in any particular case, based on the explanations below.-- When we speak of free software, we are referring to freedom of use,-not price. Our General Public Licenses are designed to make sure that-you have the freedom to distribute copies of free software (and charge-for this service if you wish); that you receive source code or can get-it if you want it; that you can change the software and use pieces of-it in new free programs; and that you are informed that you can do-these things.-- To protect your rights, we need to make restrictions that forbid-distributors to deny you these rights or to ask you to surrender these-rights. These restrictions translate to certain responsibilities for-you if you distribute copies of the library or if you modify it.-- For example, if you distribute copies of the library, whether gratis-or for a fee, you must give the recipients all the rights that we gave-you. You must make sure that they, too, receive or can get the source-code. If you link other code with the library, you must provide-complete object files to the recipients, so that they can relink them-with the library after making changes to the library and recompiling-it. And you must show them these terms so they know their rights.-- We protect your rights with a two-step method: (1) we copyright the-library, and (2) we offer you this license, which gives you legal-permission to copy, distribute and/or modify the library.-- To protect each distributor, we want to make it very clear that-there is no warranty for the free library. Also, if the library is-modified by someone else and passed on, the recipients should know-that what they have is not the original version, so that the original-author's reputation will not be affected by problems that might be-introduced by others.-- Finally, software patents pose a constant threat to the existence of-any free program. We wish to make sure that a company cannot-effectively restrict the users of a free program by obtaining a-restrictive license from a patent holder. Therefore, we insist that-any patent license obtained for a version of the library must be-consistent with the full freedom of use specified in this license.-- Most GNU software, including some libraries, is covered by the-ordinary GNU General Public License. This license, the GNU Lesser-General Public License, applies to certain designated libraries, and-is quite different from the ordinary General Public License. We use-this license for certain libraries in order to permit linking those-libraries into non-free programs.-- When a program is linked with a library, whether statically or using-a shared library, the combination of the two is legally speaking a-combined work, a derivative of the original library. The ordinary-General Public License therefore permits such linking only if the-entire combination fits its criteria of freedom. The Lesser General-Public License permits more lax criteria for linking other code with-the library.-- We call this license the "Lesser" General Public License because it-does Less to protect the user's freedom than the ordinary General-Public License. It also provides other free software developers Less-of an advantage over competing non-free programs. These disadvantages-are the reason we use the ordinary General Public License for many-libraries. However, the Lesser license provides advantages in certain-special circumstances.-- For example, on rare occasions, there may be a special need to-encourage the widest possible use of a certain library, so that it becomes-a de-facto standard. To achieve this, non-free programs must be-allowed to use the library. A more frequent case is that a free-library does the same job as widely used non-free libraries. In this-case, there is little to gain by limiting the free library to free-software only, so we use the Lesser General Public License.-- In other cases, permission to use a particular library in non-free-programs enables a greater number of people to use a large body of-free software. For example, permission to use the GNU C Library in-non-free programs enables many more people to use the whole GNU-operating system, as well as its variant, the GNU/Linux operating-system.-- Although the Lesser General Public License is Less protective of the-users' freedom, it does ensure that the user of a program that is-linked with the Library has the freedom and the wherewithal to run-that program using a modified version of the Library.-- The precise terms and conditions for copying, distribution and-modification follow. Pay close attention to the difference between a-"work based on the library" and a "work that uses the library". The-former contains code derived from the library, whereas the latter must-be combined with the library in order to run.-- GNU LESSER GENERAL PUBLIC LICENSE- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION-- 0. This License Agreement applies to any software library or other-program which contains a notice placed by the copyright holder or-other authorized party saying it may be distributed under the terms of-this Lesser General Public License (also called "this License").-Each licensee is addressed as "you".-- A "library" means a collection of software functions and/or data-prepared so as to be conveniently linked with application programs-(which use some of those functions and data) to form executables.-- The "Library", below, refers to any such software library or work-which has been distributed under these terms. A "work based on the-Library" means either the Library or any derivative work under-copyright law: that is to say, a work containing the Library or a-portion of it, either verbatim or with modifications and/or translated-straightforwardly into another language. (Hereinafter, translation is-included without limitation in the term "modification".)-- "Source code" for a work means the preferred form of the work for-making modifications to it. For a library, complete source code means-all the source code for all modules it contains, plus any associated-interface definition files, plus the scripts used to control compilation-and installation of the library.-- Activities other than copying, distribution and modification are not-covered by this License; they are outside its scope. The act of-running a program using the Library is not restricted, and output from-such a program is covered only if its contents constitute a work based-on the Library (independent of the use of the Library in a tool for-writing it). Whether that is true depends on what the Library does-and what the program that uses the Library does.-- 1. You may copy and distribute verbatim copies of the Library's-complete source code as you receive it, in any medium, provided that-you conspicuously and appropriately publish on each copy an-appropriate copyright notice and disclaimer of warranty; keep intact-all the notices that refer to this License and to the absence of any-warranty; and distribute a copy of this License along with the-Library.-- You may charge a fee for the physical act of transferring a copy,-and you may at your option offer warranty protection in exchange for a-fee.-- 2. You may modify your copy or copies of the Library or any portion-of it, thus forming a work based on the Library, and copy and-distribute such modifications or work under the terms of Section 1-above, provided that you also meet all of these conditions:-- a) The modified work must itself be a software library.-- b) You must cause the files modified to carry prominent notices- stating that you changed the files and the date of any change.-- c) You must cause the whole of the work to be licensed at no- charge to all third parties under the terms of this License.-- d) If a facility in the modified Library refers to a function or a- table of data to be supplied by an application program that uses- the facility, other than as an argument passed when the facility- is invoked, then you must make a good faith effort to ensure that,- in the event an application does not supply such function or- table, the facility still operates, and performs whatever part of- its purpose remains meaningful.-- (For example, a function in a library to compute square roots has- a purpose that is entirely well-defined independent of the- application. Therefore, Subsection 2d requires that any- application-supplied function or table used by this function must- be optional: if the application does not supply it, the square- root function must still compute square roots.)--These requirements apply to the modified work as a whole. If-identifiable sections of that work are not derived from the Library,-and can be reasonably considered independent and separate works in-themselves, then this License, and its terms, do not apply to those-sections when you distribute them as separate works. But when you-distribute the same sections as part of a whole which is a work based-on the Library, the distribution of the whole must be on the terms of-this License, whose permissions for other licensees extend to the-entire whole, and thus to each and every part regardless of who wrote-it.--Thus, it is not the intent of this section to claim rights or contest-your rights to work written entirely by you; rather, the intent is to-exercise the right to control the distribution of derivative or-collective works based on the Library.--In addition, mere aggregation of another work not based on the Library-with the Library (or with a work based on the Library) on a volume of-a storage or distribution medium does not bring the other work under-the scope of this License.-- 3. You may opt to apply the terms of the ordinary GNU General Public-License instead of this License to a given copy of the Library. To do-this, you must alter all the notices that refer to this License, so-that they refer to the ordinary GNU General Public License, version 2,-instead of to this License. (If a newer version than version 2 of the-ordinary GNU General Public License has appeared, then you can specify-that version instead if you wish.) Do not make any other change in-these notices.-- Once this change is made in a given copy, it is irreversible for-that copy, so the ordinary GNU General Public License applies to all-subsequent copies and derivative works made from that copy.-- This option is useful when you wish to copy part of the code of-the Library into a program that is not a library.-- 4. You may copy and distribute the Library (or a portion or-derivative of it, under Section 2) in object code or executable form-under the terms of Sections 1 and 2 above provided that you accompany-it with the complete corresponding machine-readable source code, which-must be distributed under the terms of Sections 1 and 2 above on a-medium customarily used for software interchange.-- If distribution of object code is made by offering access to copy-from a designated place, then offering equivalent access to copy the-source code from the same place satisfies the requirement to-distribute the source code, even though third parties are not-compelled to copy the source along with the object code.-- 5. A program that contains no derivative of any portion of the-Library, but is designed to work with the Library by being compiled or-linked with it, is called a "work that uses the Library". Such a-work, in isolation, is not a derivative work of the Library, and-therefore falls outside the scope of this License.-- However, linking a "work that uses the Library" with the Library-creates an executable that is a derivative of the Library (because it-contains portions of the Library), rather than a "work that uses the-library". The executable is therefore covered by this License.-Section 6 states terms for distribution of such executables.-- When a "work that uses the Library" uses material from a header file-that is part of the Library, the object code for the work may be a-derivative work of the Library even though the source code is not.-Whether this is true is especially significant if the work can be-linked without the Library, or if the work is itself a library. The-threshold for this to be true is not precisely defined by law.-- If such an object file uses only numerical parameters, data-structure layouts and accessors, and small macros and small inline-functions (ten lines or less in length), then the use of the object-file is unrestricted, regardless of whether it is legally a derivative-work. (Executables containing this object code plus portions of the-Library will still fall under Section 6.)-- Otherwise, if the work is a derivative of the Library, you may-distribute the object code for the work under the terms of Section 6.-Any executables containing that work also fall under Section 6,-whether or not they are linked directly with the Library itself.-- 6. As an exception to the Sections above, you may also combine or-link a "work that uses the Library" with the Library to produce a-work containing portions of the Library, and distribute that work-under terms of your choice, provided that the terms permit-modification of the work for the customer's own use and reverse-engineering for debugging such modifications.-- You must give prominent notice with each copy of the work that the-Library is used in it and that the Library and its use are covered by-this License. You must supply a copy of this License. If the work-during execution displays copyright notices, you must include the-copyright notice for the Library among them, as well as a reference-directing the user to the copy of this License. Also, you must do one-of these things:-- a) Accompany the work with the complete corresponding- machine-readable source code for the Library including whatever- changes were used in the work (which must be distributed under- Sections 1 and 2 above); and, if the work is an executable linked- with the Library, with the complete machine-readable "work that- uses the Library", as object code and/or source code, so that the- user can modify the Library and then relink to produce a modified- executable containing the modified Library. (It is understood- that the user who changes the contents of definitions files in the- Library will not necessarily be able to recompile the application- to use the modified definitions.)-- b) Use a suitable shared library mechanism for linking with the- Library. A suitable mechanism is one that (1) uses at run time a- copy of the library already present on the user's computer system,- rather than copying library functions into the executable, and (2)- will operate properly with a modified version of the library, if- the user installs one, as long as the modified version is- interface-compatible with the version that the work was made with.-- c) Accompany the work with a written offer, valid for at- least three years, to give the same user the materials- specified in Subsection 6a, above, for a charge no more- than the cost of performing this distribution.-- d) If distribution of the work is made by offering access to copy- from a designated place, offer equivalent access to copy the above- specified materials from the same place.-- e) Verify that the user has already received a copy of these- materials or that you have already sent this user a copy.-- For an executable, the required form of the "work that uses the-Library" must include any data and utility programs needed for-reproducing the executable from it. However, as a special exception,-the materials to be distributed need not include anything that is-normally distributed (in either source or binary form) with the major-components (compiler, kernel, and so on) of the operating system on-which the executable runs, unless that component itself accompanies-the executable.-- It may happen that this requirement contradicts the license-restrictions of other proprietary libraries that do not normally-accompany the operating system. Such a contradiction means you cannot-use both them and the Library together in an executable that you-distribute.-- 7. You may place library facilities that are a work based on the-Library side-by-side in a single library together with other library-facilities not covered by this License, and distribute such a combined-library, provided that the separate distribution of the work based on-the Library and of the other library facilities is otherwise-permitted, and provided that you do these two things:-- a) Accompany the combined library with a copy of the same work- based on the Library, uncombined with any other library- facilities. This must be distributed under the terms of the- Sections above.-- b) Give prominent notice with the combined library of the fact- that part of it is a work based on the Library, and explaining- where to find the accompanying uncombined form of the same work.-- 8. You may not copy, modify, sublicense, link with, or distribute-the Library except as expressly provided under this License. Any-attempt otherwise to copy, modify, sublicense, link with, or-distribute the Library is void, and will automatically terminate your-rights under this License. However, parties who have received copies,-or rights, from you under this License will not have their licenses-terminated so long as such parties remain in full compliance.-- 9. You are not required to accept this License, since you have not-signed it. However, nothing else grants you permission to modify or-distribute the Library or its derivative works. These actions are-prohibited by law if you do not accept this License. Therefore, by-modifying or distributing the Library (or any work based on the-Library), you indicate your acceptance of this License to do so, and-all its terms and conditions for copying, distributing or modifying-the Library or works based on it.-- 10. Each time you redistribute the Library (or any work based on the-Library), the recipient automatically receives a license from the-original licensor to copy, distribute, link with or modify the Library-subject to these terms and conditions. You may not impose any further-restrictions on the recipients' exercise of the rights granted herein.-You are not responsible for enforcing compliance by third parties with-this License.-- 11. If, as a consequence of a court judgment or allegation of patent-infringement or for any other reason (not limited to patent issues),-conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License. If you cannot-distribute so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you-may not distribute the Library at all. For example, if a patent-license would not permit royalty-free redistribution of the Library by-all those who receive copies directly or indirectly through you, then-the only way you could satisfy both it and this License would be to-refrain entirely from distribution of the Library.--If any portion of this section is held invalid or unenforceable under any-particular circumstance, the balance of the section is intended to apply,-and the section as a whole is intended to apply in other circumstances.--It is not the purpose of this section to induce you to infringe any-patents or other property right claims or to contest validity of any-such claims; this section has the sole purpose of protecting the-integrity of the free software distribution system which is-implemented by public license practices. Many people have made-generous contributions to the wide range of software distributed-through that system in reliance on consistent application of that-system; it is up to the author/donor to decide if he or she is willing-to distribute software through any other system and a licensee cannot-impose that choice.--This section is intended to make thoroughly clear what is believed to-be a consequence of the rest of this License.-- 12. If the distribution and/or use of the Library is restricted in-certain countries either by patents or by copyrighted interfaces, the-original copyright holder who places the Library under this License may add-an explicit geographical distribution limitation excluding those countries,-so that distribution is permitted only in or among countries not thus-excluded. In such case, this License incorporates the limitation as if-written in the body of this License.-- 13. The Free Software Foundation may publish revised and/or new-versions of the Lesser General Public License from time to time.-Such new versions will be similar in spirit to the present version,-but may differ in detail to address new problems or concerns.--Each version is given a distinguishing version number. If the Library-specifies a version number of this License which applies to it and-"any later version", you have the option of following the terms and-conditions either of that version or of any later version published by-the Free Software Foundation. If the Library does not specify a-license version number, you may choose any version ever published by-the Free Software Foundation.-- 14. If you wish to incorporate parts of the Library into other free-programs whose distribution conditions are incompatible with these,-write to the author to ask for permission. For software which is-copyrighted by the Free Software Foundation, write to the Free-Software Foundation; we sometimes make exceptions for this. Our-decision will be guided by the two goals of preserving the free status-of all derivatives of our free software and of promoting the sharing-and reuse of software generally.-- NO WARRANTY-- 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO-WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.-EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR-OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY-KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR-PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE-LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME-THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.-- 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN-WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY-AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU-FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR-CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE-LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING-RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A-FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF-SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH-DAMAGES.-- END OF TERMS AND CONDITIONS-- How to Apply These Terms to Your New Libraries-- If you develop a new library, and you want it to be of the greatest-possible use to the public, we recommend making it free software that-everyone can redistribute and change. You can do so by permitting-redistribution under these terms (or, alternatively, under the terms of the-ordinary General Public License).-- To apply these terms, attach the following notices to the library. It is-safest to attach them to the start of each source file to most effectively-convey the exclusion of warranty; and each file should have at least the-"copyright" line and a pointer to where the full notice is found.-- <one line to give the library's name and a brief idea of what it does.>- Copyright (C) <year> <name of author>-- This library is free software; you can redistribute it and/or- modify it under the terms of the GNU Lesser General Public- License as published by the Free Software Foundation; either- version 2.1 of the License, or (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU- Lesser General Public License for more details.-- You should have received a copy of the GNU Lesser General Public- License along with this library; if not, write to the Free Software- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+NOTE: This License applies to all files in the "Haskell CnC"+distribution, irrespective of whether the license is appended at the+top of each file. -Also add information on how to contact you by electronic and paper mail.+ BSD STANDARD THREE CLAUSE LICENSE ("New BSD License") -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:+Copyright (c) 2010, Intel Corporation.+All rights reserved. - Yoyodyne, Inc., hereby disclaims all copyright interest in the- library `Frob' (a library for tweaking knobs) written by James Random Hacker.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission. - <signature of Ty Coon>, 1 April 1990- Ty Coon, President of Vice+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -That's all there is to it!
Makefile view
@@ -1,33 +1,71 @@ +# WARNING: This Makefile is largely redundant with the .cabal file and will be deleted at some point.++# It has some crufty shortcuts used by the developers.++#====================================================================================================++all: runtime +#all: runtime trans++ifeq (,$(GHC))+ GHC= ghc+endif++#====================================================================================================+# First, some entrypoints that help build the runtime+#====================================================================================================+ # PARGHCOPTS=-feager-blackholing default: # This target builds CnC as precompiled modules: # Pick default schedulers as well:- ghc --make -c -cpp Intel/CncUtil.hs- ghc --make -c -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs- ghc --make -c -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs+ $(GHC) --make -c -cpp Intel/CncUtil.hs+ $(GHC) --make -c -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs+ $(GHC) --make -c -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs -all:- cabal configure- cabal build- cabal haddock- ./Setup.hs test+runtime:+ runhaskell ./Setup.hs configure+ runhaskell ./Setup.hs build+ @echo +# TEMP [2010.10.06] Disabling doc build+# $(MAKE) setup_doc+# $(MAKE) setup_test +setup_doc:+ @echo ================================================================================+ @echo Building Documentation+ @echo ================================================================================+ runhaskell ./Setup.hs haddock++setup_test:+ @echo + @echo ================================================================================+ @echo Running Test executable in the cabal distribution package+ @echo ================================================================================+ runhaskell ./Setup.hs test++ interact: ghci -cpp -DCNC_SCHEDULER=2 Intel/CncPure.hs -interactio:+interactIO: ghci -cpp -DCNC_SCHEDULER=5 Intel/Cnc.hs test: - THREADS=1 ./run_all_tests.sh+ THREADS=1 ./run_all_examples.sh longtest: - NONSTRICT=1 LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh &> /dev/stdout | tee all_tests.log+ TRIALS=3 NONSTRICT=1 LONGRUN=1 THREADSETTINGS=="0 1 2 3 4 8" ./run_all_examples.sh &> /dev/stdout | tee all_tests.log+# TRIALS=3 NONSTRICT=1 LONGRUN=1 THREADSETTINGS=="0 1 2 3 4 8" ./run_all_examples.sh &> /dev/stdout | tee all_tests.log # LONGRUN=1 THREADSETTINGS="0 1 2 3 4 8" ./run_all_tests.sh &> /dev/stdout | tee all_tests.log ++# TRIALS=3 NONSTRICT=1 LONGRUN=1 THREADSETTINGS="0 1 2 3 4 6 7 8 10 11 12 16 20 24 28 32 36 38 42 46 47 48 " ./run_all_FROMPACKED.sh &> /dev/stdout | tee all_tests.log++ distro: pkg pkg: ./build_distro.sh@@ -44,18 +82,58 @@ 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 +distclean: clean+ rm -rf distro_20* -clean:- rm -f Intel/*.o Intel/*.hi Intel/*~ +pkgtest:+ rm -rf dist/haskell-cnc-*+ cabal sdist+ (cd dist; tar xzvf haskell-cnc-*.tar.gz)+ (cd dist/haskell-cnc-*/ && cabal install)+++#====================================================================================================+# For benchmark test runs:++cleanrun:+ rm -f uname.txt cpuinfo issue all_tests*.log results.dat++mvrun:+ mkdir -p last_run+ cp uname.txt cpuinfo issue all_tests*.log results.dat last_run/++UNAME=$(shell uname -n )+BENCHPACK="benchpack_$(UNAME)"++# Make a separate directory for running benchmarks.+benchpack:+ mkdir -p "$(BENCHPACK)/examples/"+ mkdir -p "$(BENCHPACK)/Intel/"+ cp -a *big_run*.sh default_opt_settings.sh ntimes ntimes_minmedmax ntimes_binsearch.sh binsearch_throughput timeout.sh timeout.hs \+ benchlist*.txt install_environment_vars.sh runcnc run_all_shared.sh run_all_examples.sh haskell_cnc.h "$(BENCHPACK)/"+ cp -a Intel/*.hs "$(BENCHPACK)/Intel/"+ cp -a examples/*.hs "$(BENCHPACK)/examples/"+ cp -a examples/*.dat "$(BENCHPACK)/examples/"+++#====================================================================================================++clean: cleanruntime cleantests+ runhaskell ./Setup.hs clean++cleanruntime:+ rm -f ./Intel/*.o ./Intel/*.hi Intel/*~ + rm -f ./Intel/Cnc/*.o Intel/Cnc/*.hi + rm -f $(BUILDDIR)/Intel/*.o $(BUILDDIR)/Intel/*.hi + rm -f $(BUILDDIR)/Intel/Cnc/*.o $(BUILDDIR)/Intel/Cnc/*.hi rm -f *.aux little*.log (cd examples; $(MAKE) clean) -distclean: clean- rm -rf distro_20*-# DO NOT DELETE: Beginning of Haskell dependencies-Intel/CncUtil.o : Intel/CncUtil.hs-Intel/Cnc3.o : Intel/Cnc3.hs-Intel/Cnc3.o : Intel/CncUtil.hi-examples/test_parfor.o : examples/test_parfor.hs-examples/test_parfor.o : Intel/Cnc3.hi-# DO NOT DELETE: End of Haskell dependencies+cleantests:+ (cd tests_spec; $(MAKE) clean)+++#====================================================================================================++# Prevent odd make builtin rules re: cnc.sh+.SUFFIXES:
README.txt view
@@ -27,15 +27,59 @@ -------------------------------------------------------------+-------------------------------------------------------------------------------- Installing Haskell CnC -------------------------------------------------------------+-------------------------------------------------------------------------------- +You need a working installation of "ghc" and "cabal". The easiest way+to accomplish this is with the Haskell Platform. With those+prerequisites you should be able to install Haskell CnC directly from+the web with:+ cabal install haskell-cnc -------------------------------------------------------------a+Building from source, including installing all dependencies:++ git clone git://github.com/rrnewton/Haskell-CnC.git++ cd Haskell-CnC+ cabal update+ cabal install+ +That will cause cabal to install a number of packages from "Hackage"+and then build Haskell CnC. If any of these dependencies break (don't+build with your version of GHC).++If you are running as root you may have an easier time with:++ cabal install --global++Otherwise make sure that ~/.cabal/bin/ is in your path.+++ cabal install happy+ cabal install ++ ------------------------------------+ A GUIDE TO CABAL DEPENDENCY PROBLEMS+ ------------------------------------++Because the Haskell CnC package exists in an ecosystem of+ever-changing packages and compiler versions (cabal), and itself has+many dependencies. Often these will get broken. However, the+intrepid hacker can usually work around most problems. Here, I will+try to make an account of the hacks that are needed to overcome+obstacles.+++ [2011.02.14] DRBG dependency broke on hackage due to tagged-0.2+ Fixed now.+ +++-------------------------------------------------------------------------------- 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.@@ -74,4 +118,24 @@ INCLUDEMETHOD ignore this, it's internal and is used for switching between schedulers-as-modules or schedulers-as-includes++++------------------------------------------------------------+ Testing and Benchmarking+------------------------------------------------------------++Notes on running a full benchmark suite:++To compile with profiling support (for threadscope)++ GHC_DEFAULT_FLAGS="-eventlog" NORUN=1 runcnc mandel.hs ++To run and generate a .eventlog:++ ./mandel.exe 300 300 80000 +RTS -ls -N31++Will generate mandel.exe.eventlog++
Setup.hs view
@@ -1,6 +1,7 @@ #!/usr/bin/env runhaskell import Distribution.Simple+import Distribution.Simple.PreProcess import Distribution.PackageDescription import Distribution.Simple.LocalBuildInfo import System.Cmd(system) @@ -9,14 +10,32 @@ --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}) + let hooks = simpleUserHooks + defaultMainWithHooks + (hooks {runTests = myTests+ --, hookedPreProcessors= (mypp : hookedPreProcessors hooks) + }) +++-- mypp :: PPSuffixHandler+-- mypp = (".y.pp", \ _ _ -> ppTestHandler)++-- ppTestHandler :: PreProcessor+-- ppTestHandler =+-- PreProcessor {+-- platformIndependent = True,+-- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->+-- do putStrLn$ (inFile++" has been preprocessed to "++outFile)+-- stuff <- readFile inFile+-- writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)+-- return ()+-- }+ myTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () myTests _ _ _ _ = do code <- system "./dist/build/haskell-cnc-runTests/haskell-cnc-runTests"
default_opt_settings.sh view
@@ -9,12 +9,21 @@ # For 6.13: -if [ "`ghc -V`" == "The Glorious Glasgow Haskell Compilation System, version 6.12.1" ];-then GHC_DEFAULT_FLAGS=" -O2"+# TOGGLE+#GMAP=+GMAP="-DUSE_GMAP"++if [ "$CNCOPT" == "" ];+then CNCOPT="-O2"+fi++# [2010.10.06] Allow user to start with their own GHC_DEFAULT_FLAGS+if [ "`$GHC -V`" == "The Glorious Glasgow Haskell Compilation System, version 6.12.1" ];+then GHC_DEFAULT_FLAGS="$GHC_DEFAULT_FLAGS $CNCOPT $GMAP " #then GHC_DEFAULT_FLAGS=" "-else GHC_DEFAULT_FLAGS=" -rtsopts -O2"+else GHC_DEFAULT_FLAGS="$GHC_DEFAULT_FLAGS -rtsopts $CNCOPT $GMAP " fi # Affinity is pretty much always good.-GHC_DEFAULT_RTS=" -qa " +GHC_DEFAULT_RTS="$GHC_DEFAULT_RTS -qa "
examples/embarrassingly_par.hs view
@@ -40,17 +40,11 @@ work offset (!i) (!n) = work offset (i-1) (n + 1 / fromIntegral (i+offset)) runit total = runGraph graph `pseq` return ()- where+ 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+ tid <- stepUnsafeIO myThreadId 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 @@ -60,6 +54,8 @@ do items <- newItemCol tags <- newTagCol cncPutStr$ "Running embarassingly parallel benchmark. CnC Variant: "++ show cncVariant ++"\n"+ cncPutStr$ "Running "++ show total ++" total iterations\n"+ prescribe tags (mystep items) initialize $ do stepPutStr$ "Begin initialize. Splitting work into "++show numCapabilities++" pieces\n"@@ -83,5 +79,9 @@ loop args = case args of [] -> runit $ 50*1000*1000- [n] -> runit $ round (10 ** read n)+ [n] -> runit $ let num = read n in + -- Here's a bit of a hack, if the input is inexact treat it as an exponent. Otherwise as a plain scalar.+ if num == fromIntegral (round num)+ then round num+ else round (10 ** read n) -- [trials, n] -> doTrials (read trials) (loop [n])
examples/fib.hs view
@@ -24,6 +24,9 @@ #include "haskell_cnc.h" +-- This is a SERIAL benchmark, but it demonstrates how item+-- collections can be used for something like dynamic programming.+ run n = runGraph $ do tags :: TagCol Int <- newTagCol items :: ItemCol Int Int64 <- newItemCol@@ -34,7 +37,6 @@ 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 $
examples/mandel.hs view
@@ -28,49 +28,57 @@ #include <haskell_cnc.h> mandel :: Int -> Complex Double -> Int-mandel max_depth c = loop 0 0 0+mandel max_depth c = loop 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)+ loop i z + | i == max_depth = i+ | fn(z) >= 2.0 = i+ | otherwise = loop (i+1) (z*z + c) --- A pair will fit in a word: type Pair = (Int16, Int16) +dynAPI = True -- TEMPTOGGLE+ mandelProg :: Int -> Int -> Int -> GraphCode Int mandelProg max_row max_col max_depth = - do position :: TagCol Pair <- newTagCol- dat :: ItemCol Pair (Complex Double) <- newItemCol+ do --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 + let mandelStep tag@(i,j) = + let z = (r_scale * (fromIntegral j) + r_origin) :+ + (c_scale * (fromIntegral i) + c_origin) in+ do tid <- stepUnsafeIO myThreadId+ --stepPutStr$ "["++ show tid ++"] Mandel Step executing: "++ show tag ++ "\n"+ --cplx <- get dat tag+ put pixel tag (mandel max_depth z) + position :: TagCol Pair <- prescribeNT [mandelStep] initialize $ - forM_ [0..max_row] $ \i -> - forM_ [0..max_col] $ \j ->+ forM_ [0..max_row-1] $ \i -> + forM_ [0..max_col-1] $ \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)+ do -- put dat (_i,_j) z+ if dynAPI+ then forkStep$ mandelStep (_i,_j)+ else putt position (_i,_j) -- Final result, count coordinates of the pixels with a certain value:- finalize $ + finalize $ do + --stepPutStr$ "Finalize action begun...\n" foldM (\acc i -> foldM (\acc j -> - do p <- get pixel (fromIntegral i, fromIntegral j)+ do --stepPutStr$ " ... try get pixel "++ show (i,j) ++"\n "+ p <- get pixel (fromIntegral i, fromIntegral j)+ --stepPutStr$ " GET PIXEL SUCCESSFUL "++ show (i,j) ++"\n " if p == max_depth then return (acc + (i*max_col + j)) else return acc)- acc [0..max_col]- ) 0 [0..max_row] + acc [0..max_col-1]+ ) 0 [0..max_row-1] where r_origin = -2 :: Double@@ -85,5 +93,6 @@ main = do args <- getArgs case args of- [] -> runMandel 3 3 3 -- Should output 24.+ --[] -> runMandel 1 1 3 -- Should output 57.+ [] -> runMandel 4 4 3 -- Should output 57. [a,b,c] -> runMandel (read a) (read b) (read c)
examples/mandel_opt.hs view
@@ -1,9 +1,7 @@ -- Author: Ryan Newton -- In this version we flatten our (x,y) positions into a single integer.--- To that end, we FIX the grid size statically to 300x300. - -- In this improved version, we look at three different optimizations. -- First: enable GMaps and pack -- Second: use cncFor to structure the spewing of the inital workload.@@ -30,14 +28,16 @@ unpack n = (fromIntegral$ shiftR n 16, fromIntegral$ n .&. 0xFFFF) mandel :: Int -> Complex Double -> Int-mandel max_depth c = loop 0 0 0+mandel max_depth c = loop 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)+ loop i z + | i == max_depth = i+ | fn(z) >= 2.0 = i+ | otherwise = loop (i+1) (z*z + c) +dynAPI = True+ mandelProg :: Int -> Int -> Int -> Int -> GraphCode Int mandelProg optlvl max_row max_col max_depth = do position :: TagCol Int <- newTagCol@@ -57,7 +57,9 @@ let kernel i j = do let (packed,z) = packit i j put dat packed z- putt position packed+ if dynAPI + then forkStep$ mandelStep packed+ else putt position packed let init1 = forM_ [0..max_row] $ \i -> forM_ [0..max_col] $ \j ->
examples/nbody.hs view
@@ -16,6 +16,7 @@ - 51 Franklin St - Fifth Floor, Boston, MA 02110-1301 USA. - -}+{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE ExistentialQuantification , ScopedTypeVariables , BangPatterns@@ -23,7 +24,9 @@ , RecordWildCards , FlexibleInstances , DeriveDataTypeable+ , MagicHash #-}+-- This is INCOMPATIBLE with CncPure.. -- Author: Chih-Ping Chen @@ -31,56 +34,114 @@ import System.Environment import Data.Int-import Data.List +import GHC.Exts++import qualified Data.List as List+import qualified Data.Array as Array+ #include "haskell_cnc.h" +type Float3D = (Float, Float, Float)++type UFloat3D = (# Float#, Float#, Float# #)++ -- 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+genVector tag = (tag' * 1.0, tag' * 0.2, tag' * 30.0)+ where tag' = fromIntegral tag +-- Only doing the O(N^2) part in parallel: -- 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+compute vecList accels tag =+ do --let myvector = vecList !! (tag-1)+ let myvector = vecList Array.! (tag-1)+ put accels tag (accel myvector vecList)+ where --vecList = elems vecArr+ g = 9.8++-- multTriple :: Float# -> UFloat3D -> UFloat3D+-- multTriple c (# x,y,z #) = (# c*x,c*y,c*z #)++ multTriple :: Float -> Float3D -> Float3D+ multTriple c ( x,y,z ) = ( c*x,c*y,c*z )++ pairWiseAccel :: Float3D -> Float3D -> Float3D 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)+ -- Performance degredation here:+ distanceSq = dx*dx + dy*dy + dz*dz + eps+ factor = 1/sqrt(distanceSq * distanceSq * distanceSq)++-- in multTriple factor (dx,dy,dz) in multTriple factor (dx,dy,dz)+-- #define OLD_VER+#ifdef OLD_VER 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+ accel vector vecList = multTriple g $ sumTriples $ List.map (pairWiseAccel vector) vecList+#else+-- Making this much leCss haskell like to avoid allocation:+ (strt,end) = Array.bounds vecList + accel :: Float3D -> (Array.Array Int Float3D) -> Float3D+ accel vector vecList = ++ -- Manually inlining to see if the tuples unbox:+ let (# sx,sy,sz #) = loop strt 0 0 0+ loop !i !ax !ay !az+ | i == end = (# ax,ay,az #)+ | otherwise = + let ( x,y,z ) = vector+ ( x',y',z' ) = vecList Array.! i++ (# dx,dy,dz #) = (# x'-x, y'-y, z'-z #)+ eps = 0.005+ distanceSq = dx*dx + dy*dy + dz*dz + eps+ factor = 1/sqrt(distanceSq * distanceSq * distanceSq)++ (# px,py,pz #) = (# factor * dx, factor * dy, factor *dz #)++ in loop (i+1) (ax+px) (ay+py) (az+pz)+ in ( g*sx, g*sy, g*sz )+#endif++ -- This describes the graph-- The same tag collection prescribes the two step collections. +run :: Int -> [Float3D] run n = runGraph $ do tags <- newTagCol- vectors <- newItemCol accels <- newItemCol- prescribe tags (genVectors vectors)- prescribe tags (compute vectors accels n)++#ifdef OLD_VER+ let initVecs = List.map genVector [1..n]+#else+ let initVecs = Array.array (0,n-1) [ (i, genVector i) | i <- [0..n-1] ]+#endif++ prescribe tags (compute initVecs accels)+ initialize $- do sequence_ (List.map (putt tags) [1..n])+ --do sequence_ (List.map (putt tags) [1..n])+ --do forM_ [1..n] $ \ t -> putt tags t+ do forM_ [1..n] $ \ t -> forkStep (compute initVecs accels t)+ -- [2010.10.07] Considering this, but need to test it:+ -- Ack, it seems to hang with sched 11... blocked mvar sched 7+ --cncFor 1 (n-1) $ \ t -> compute initVecs accels t+ finalize $ do stepPutStr "Begin finalize action.\n"- vecList <- itemsToList vectors- accList <- itemsToList accels- return (vecList, accList)+ accList <- sequence (List.map (get accels) [1..n])+ return accList main = do args <- getArgs - let (vecList, accList) = case args of - [] -> run 3- [s] -> run (read s)- --putStrLn $ show vecList; putStrLn $ show accList;+ let accList = case args of + [] -> run (3::Int)+ [s] -> run (read s)+ --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)+ putStrLn $ show (foldl (\sum (x,y,z) -> if x>0 then sum+1 else sum) 0 accList)
examples/primes.hs view
@@ -42,18 +42,24 @@ primes n = do primes :: ItemCol Int Int <- newItemCol- tags <- newTagCol- prescribe tags (\t -> if isPrime (t) - then put primes t t- else return ())+ tags <- prescribeNT [\t -> if isPrime (t) + then put primes t t+ else return ()] +#if 0 let loop i | i >= n = return ()- loop i = do putt tags i - loop (i+2)+ loop i = do putt tags i + loop (i+2) initialize $- do put primes 2 2+ do put primes 2 2 loop 3 -+#else+ initialize $+ do put primes 2 2+ cncFor 0 ((n - 1) `quot` 2 - 1) $ \i -> do+ --stepPutStr$ "putting " ++ show i ++ "\n"+ putt tags (3 + i*2)+#endif finalize $ do result <- itemsToList primes return (length result) @@ -73,4 +79,4 @@ case args of [] -> run 1000 -- Should output 168 [n] -> run (read n)- [trials, n] -> doTrials (read trials) (run (read n))+-- [trials, n] -> doTrials (read trials) (run (read n))
haskell-cnc.cabal view
@@ -1,6 +1,9 @@ Name: haskell-cnc-Version: 0.1.3.1-License: LGPL++Version: 0.1.3.200+-- [2011.08.12] 0.1.3.200 Bumped after removing translator / spec compiler.++License: BSD3 License-file: LICENSE Stability: Beta Author: Ryan Newton <rrnewton@gmail.com>@@ -12,19 +15,22 @@ deterministic parallel programming model, similar to stream-processing but in which nodes in the computation graph share data in tables. -Category: system, concurrent+Category: Control, Parallelism Cabal-Version: >=1.6 build-type: Simple source-repository head- type: darcs- location: http://code.haskell.org/haskell-cnc/+ type: git+ location: git://github.com/rrnewton/Haskell-CnC.git --Data-Files: ntimes ntimes_minmedmax README.txt haskell_cnc.h Makefile install_environment_vars.sh + library- build-depends: base, mtl, containers, time, random, array, ghc-prim, extensible-exceptions, HUnit, MissingH, HSH+ build-depends: base, mtl, containers, time, random, array, ghc-prim, + extensible-exceptions, HUnit, MissingH, HSH, unix,+ bytestring -- QuickCheck -- I haven't got quickcheck working under 6.13.xx right now. -- Needed for the scaling.hs plotting script: -- HSH, gnuplot@@ -51,8 +57,9 @@ examples/embarrassingly_par.hs examples/fib.hs examples/nbody.hs Intel/Cnc.Header.hs Intel/shared_5_6.hs Intel/CncUtil.hs- Intel/Cnc.hs Intel/CncPure.hs Intel/Cnc3.hs Intel/Cnc5.hs Intel/Cnc6.hs Intel/Cnc8.hs-+ Intel/Cnc.hs Intel/CncPure.hs Intel/Cnc3.hs Intel/Cnc4.hs Intel/Cnc5.hs Intel/Cnc6.hs Intel/Cnc7.hs+ Intel/Cnc8.hs Intel/Cnc10.hs+ -- This seems to be completly ignored by cabal currently: -- Test testit -- type: library-1@@ -65,3 +72,4 @@ extensions: CPP GHC-Options: -O2 -threaded -- cpp-options: -DUSE_GMAP+
install_environment_vars.sh view
@@ -5,3 +5,4 @@ export HASKELLCNC=`pwd` export PATH="$HASKELLCNC:$PATH"+
ntimes view
@@ -33,8 +33,8 @@ # Also responds to NOTIME which turns off the timing. -# Time out processes after two minutes.-TIMEOUT=120+# Time out processes after three minutes.+TIMEOUT=1000 # Unfortunately 'tempfile' is not a standard command: function mytempfile {@@ -75,14 +75,16 @@ EXITCODE=0 for ((i=1; i <= $N; i++)); do- # Stores the executable output:+ # Stores just this one executable's output: TMP2=`mytempfile 2` # [2009.12.17] I need to get a good cross-platform process time-out system:- if [ -e ./timeout ];+ # HACK: Sometimes I run this on systems WITHOUT a working GHC:+ if [ -e ./timeout.sh ];+ then TIMEOUTRUN="./timeout.sh -t $TIMEOUT"+ elif [ -e ./timeout ]; # [2010.06.03] --RTS is a hack for working around a problem with +RTS flags: then TIMEOUTRUN="./timeout $TIMEOUT --RTS "- #then TIMEOUTRUN="./timeout -t $TIMEOUT" else TIMEOUTRUN= fi @@ -108,7 +110,20 @@ # 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++ # SUPERHACK terrain... Here's a special symbol that the script can+ # use to override the external timing and use internal timing+ # mechinasms.+ selftime=`grep SELFTIME $TMP2`+ if [ "$selftime" != "" ]; then + echo " +++ Executable appears self-timed!!:" >> $MYOUT+ echo "$selftime" >> $MYOUT+ cat $TMP2 | grep -v "real" | sed 's/SELFTIMED/real/' >> $TMP1+ else+ cat $TMP2 >> $TMP1+ fi++ # [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@@ -123,7 +138,7 @@ # Stores the times: TMP3=`mytempfile 3` - # Hack: this assumes the string "real" doesn't occur in the test output.+ # HACK 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:
runAllTests.hs view
@@ -1,4 +1,6 @@ +-- Run all tests for the Haskell CnC Runtime System.+ import System.Directory import qualified Intel.Cnc import qualified Intel.CncPure
run_all_examples.sh view
@@ -28,7 +28,7 @@ # 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 THREADSETTINGS="1 2 4" to run with # threads = 1, 2, or 4. # Call it with NONSTRICT=1 to keep going after the first error. @@ -42,20 +42,29 @@ #export GHC=ghc-6.13.20100511 #export GHC=~/bin/Linux-i686/bin/ghc-6.13.20100511 unset HASKELLCNC-+export HASKELLCNC=`pwd` # Which subset of schedures should we test:-PURESCHEDS="2"-#IOSCHEDS="3"-IOSCHEDS="3 5 6 8"+PURESCHEDS="2 3"+#PURESCHEDS="" +IOSCHEDS="4 7 8 3 10 11"++#SEPARATESCHEDS="6"+SEPARATESCHEDS=""+ if [ "$THREADSETTINGS" == "" ] then THREADSETTINGS="4" #then THREADSETTINGS="0 1 2 3 4" fi +if [ "$GHC" == "" ]; then GHC=ghc; fi source default_opt_settings.sh +# HACK: with all the intermachine syncing and different version control systems I run into permissions problems sometimes.+chmod +x ./ntime* ./*.sh++ # Where to put the timing results: RESULTS=results.dat if [ -e $RESULTS ];@@ -80,17 +89,12 @@ 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 "# "`uname -a` >> $RESULTS-echo "# "`ghc -V` >> $RESULTS+echo "# "`$GHC -V` >> $RESULTS echo "# " echo "# Running each test for $TRIALS trials." >> $RESULTS echo "# ... with default compiler options: $GHC_DEFAULT_FLAGS" >> $RESULTS@@ -98,22 +102,7 @@ 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-}+source run_all_shared.sh # Dynamic scoping. Lame. This uses $test. function runit() @@ -124,6 +113,7 @@ echo " Running Config $cnt: $test variant $CNC_VARIANT sched $CNC_SCHEDULER threads $NUMTHREADS $hashtab" echo "--------------------------------------------------------------------------------" echo + echo "(In directory `pwd`)" if [ "$NUMTHREADS" != "0" ] && [ "$NUMTHREADS" != "" ] then export RTS=" $GHC_DEFAULT_RTS -s -N$NUMTHREADS " else export RTS=""@@ -138,16 +128,28 @@ CODE=$? check_error $CODE "ERROR: compilation failed." - echo "Executing ./ntimes_minmedmax "$TRIALS" ./examples/$test.exe $ARGS +RTS $RTS -RTS "+ echo "Executing $NTIMES $TRIALS ./examples/$test.exe $ARGS +RTS $RTS -RTS " if [ "$LONGRUN" == "" ]; then export HIDEOUTPUT=1; fi- times=`./ntimes_minmedmax "$TRIALS" ./examples/$test.exe $ARGS +RTS $RTS -RTS`++ # Hack, don't bother running the multiple trials under a threshold:+ if [ "TRIALSTHRESHOLD" == "" ]+ # TODO: IMPLEMENT THIS POLICY+ then thistrials=$TRIALS+ else thistrials=$TRIALS+ fi+ # Another option woud be dynamic feedback where if the first one+ # takes a long time we don't bother doing more trials.++ times=`$NTIMES "$thistrials" ./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" ];+ if [ "$CODE" == "143" ];+ then echo "$test.exe" "$CNC_VARIANT" "$CNC_SCHEDULER" "$NUMTHREADS" "$HASH" "TIMEOUT TIMEOUT TIMEOUT" >> $RESULTS+ elif [ "$CODE" != "0" ] ; 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@@ -170,12 +172,9 @@ # Hygiene: rm -f examples/*.exe -# This specifies the list of tests and their arguments for a "long" run:--#for line in "mandel_opt 1 300 300 4000" "mandel_opt 2 300 300 4000" "mandel_opt 3 300 300 4000" "mandel 300 300 4000"; do--for line in "embarrassingly_par 9.2" "threadring 50000000 503" "sched_tree 18" "primes2 200000" "fib 20000" "mandel 300 300 4000" "mandel_opt 1 300 300 4000"; do+#==================================================================================================== +function run_benchmark() { set -- $line test=$1; shift @@ -192,39 +191,107 @@ echo "# *** Config [$cnt ..], testing with command/args: $test.exe $ARGS " >> $RESULTS - export CNC_VARIANT=pure- # Currently running the pure scheduler only in single threaded mode:- export NUMTHREADS=0- 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++ # This one is serial right now:+ if [ "$sched" == "100" ]; then + NUMTHREADS=1+ export hashtab=""+ runit+ else+ 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++ done # threads+ fi echo >> $RESULTS; done # schedulers + export CNC_VARIANT=pure+ # Currently running the pure scheduler only in single threaded mode:+ export NUMTHREADS=0++ for sched in $PURESCHEDS; do+ export CNC_SCHEDULER=$sched+ unset hashtab+ if [ "$sched" == "2" ]; then + export NUMTHREADS=0+ runit+ else + for NUMTHREADS in $THREADSETTINGS; do+ runit+ done # threads+ fi+ echo >> $RESULTS;+ done+ # 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=6- export NUMTHREADS=4- runit+ for sched in $SEPARATESCHEDS; do+ export CNC_SCHEDULER=$sched+ export NUMTHREADS=4+ runit+ done echo >> $RESULTS; echo >> $RESULTS;++}++# Read $line and do the benchmark with ntimes_binsearch.sh+function run_binsearch_benchmark() {+ NTIMES=./ntimes_binsearch.sh+ run_benchmark+ NTIMES=UNSET+}++# Read $line and do the benchmark with ntimes_minmedmax+function run_normal_benchmark() {+ NTIMES=./ntimes_minmedmax+ run_benchmark+ NTIMES=UNSET+}+++#====================================================================================================++++# This specifies the list of tests and their arguments for a "long" run:++#for line in "mandel_opt 1 300 300 4000" "mandel_opt 2 300 300 4000" "mandel_opt 3 300 300 4000" "mandel 300 300 4000"; do++# Even wasp could handle this one, right:+# +#for line in "par_seq_par_seq 8.5" "embarrassingly_par 9.2" "primes2 200000" "mandel 300 300 4000" "mandel_opt 1 300 300 4000" "sched_tree 18" "fib 20000" "threadring 50000000 503" "nbody 1200" "primes 200000"; do++# Parallel benchmarks only:+#for line in "blackscholes 10000 15000000" "nbody 5000" "cholesky 1000 50 m1000.in" "par_seq_par_seq 8.5" "embarrassingly_par 9.2" "primes2 200000" "mandel 300 300 4000" "mandel_opt2 1 300 300 4000" "sched_tree 18" "primes 200000"; +++# FOR BIG machines, copied back from run_all_FROMPACKED+# for line in "nbody 10000" "blackscholes 10000 50000000" "mandel 150 150 160000" "mandel_opt2 2 150 150 160000" "cholesky 1000 50 cholesky_matrix1000.dat" "primes 1000000" "embarrassingly_par 9.8" "par_seq_par_seq 9.2" "sched_tree 19" ; ++if [ "$BENCHLIST" == "" ];+then BENCHLIST="./benchlist.txt"+fi++echo Reading benchmarks from $BENCHLIST ...+cat $BENCHLIST | grep -v "\#" | +while read line+do+ if [ "$line" == "" ]; then continue; fi+ echo RUNNING BENCH: $line+ run_normal_benchmark done echo "Finished with all test configurations."
runcnc view
@@ -28,27 +28,31 @@ # -------------------------------------------------------------------------------- # NUMTHREADS -- if this is "0" the program is compiled without threading +# NORUN -- compile but do not run+ # CNC_VARIANT -- which implementation? "pure" or "io" # CNC_SCHEDULER -- which (numbered) scheduler, 1-N?-# FLAGS -- flags for ghc+# GHC_DEFAULT_FLAGS -- flags for ghc+# GHC_DEFAULT_RTS -- flags for ghc # GHC -- command to call ghc compiler # INTERACTIVE -- set to non-empty value to call ghci instead of ghc++# CNCOPT -- set to -O0 -O2 -to control optimization level [default -O2] # -------------------------------------------------------------------------------- +if [ "$GHC" == "" ]; then + GHC=ghc+fi+ #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@@ -57,8 +61,10 @@ # [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 -XTypeFamilies -XUndecidableInstances -XOverlappingInstances -XMultiParamTypeClasses $TEMPEXT"+# glasgow-exts actually CAUSES problems (cncpure wont build):+#TEMPEXT="-XFlexibleContexts -XTypeSynonymInstances -XRankNTypes -fglasgow-exts "+TEMPEXT="-XFlexibleContexts -XTypeSynonymInstances -XRankNTypes "+EXTENSIONS=" -XExistentialQuantification -XScopedTypeVariables -XBangPatterns -XNamedFieldPuns -XRecordWildCards -XFlexibleInstances -XDeriveDataTypeable -XTypeFamilies -XUndecidableInstances -XOverlappingInstances -XMultiParamTypeClasses -XFunctionalDependencies $TEMPEXT" # MagicHash # If the user has not set $HASKELLCNC we try the current directory.
scaling.hs view
@@ -2,12 +2,19 @@ {-# LANGUAGE NamedFieldPuns #-} +-- This script generates gnuplot plots.+-- Give it a .dat file as input... (or it will try to open results.dat)++ import Text.PrettyPrint.HughesPJClass import Text.Regex import Data.List import Data.Function import Control.Monad import System+import System.IO+import System.FilePath +import System.Environment import HSH @@ -23,28 +30,46 @@ -import qualified Graphics.Gnuplot.Simple as Simple+-- 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.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.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.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 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 Debug.Trace ---import qualified Graphics.Gnuplot.Private.LineSpecification as LineSpec-import qualified Graphics.Gnuplot.LineSpecification as LineSpec +-- linewidth = "4.0"+linewidth = "5.0"++-- Schedulers that we don't care to graph right now.+-- This happens BEFORE rename+--scheduler_MASK = [5,6,99,10]+scheduler_MASK = []++-- Ok, gunplot line type 6 is YELLOW... that's not to smart:+line_types = [0..5] ++ [7..]++-- Rename for the paper:+--translate 10 = 99+--translate 100 = 10+translate n = n++{-+--import qualified Graphics.Gnuplot.LineSpecification as LineSpec+ simple2d :: Plot2D.T simple2d = Plot2D.function (linearScale 100 (-10,10::Double)) sin@@ -86,7 +111,10 @@ `mappend` circle2d +-} +round_2digits :: Double -> Double+round_2digits n = (fromIntegral $round (n * 100)) / 100 --x11 = terminal Terminal.X11.cons@@ -137,14 +165,16 @@ hashhack :: Bool, tmin :: Double, tmed :: Double,- tmax :: Double+ tmax :: Double,+ normfactor :: 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)+ pPrint Entry { name, variant, sched, threads, tmin, tmed, tmax, normfactor } = + pPrint ("ENTRY", name, variant, sched, threads, (tmin, tmed, tmax), normfactor )+-- pPrint ("ENTRY", name, variant, sched, threads, tmin, tmed, tmax, normfactor) parse [a,b,c,d,e,f,g,h] =@@ -155,10 +185,15 @@ 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+ tmax = read h,+ normfactor = 1.0+ } +parse [a,b,c,d,e,f,g,h,i] = +-- trace ("Got line with norm factor: "++ show [a,b,c,d,e,f,g,h,i])+ (parse [a,b,c,d,e,f,g,h]) { normfactor = read i }+parse other = error$ "Cannot parse, wrong number of fields, "++ show (length other) ++" expected 8 or 9: "++ show other+ groupSort fn = (groupBy ((==) `on` fn)) . (sortBy (compare `on` fn))@@ -176,7 +211,8 @@ instance Show Mystr where show (Mystr s) = s -+{-+-- I ended up giving up on using the gnuplot package on hackage: -- mypath :: Graph2D.T --Plot2D.T --plot_benchmark :: [[[Entry]]] -> IO ()@@ -219,18 +255,52 @@ --Plot2D.path (map ( \ (a,b,c,d) -> (a,b)) pairs) --fmap (Graph2D.typ Graph2D.errorBars) $ Plot2D.list quads+-} +-- Name, Scheduler, Threads, BestTime, Speedup+data Best = Best (String, Int, Int, Double, Double) --- Ok, yuck, giving up on the Cabal gnuplot package and generating the gnuplot output myself.-plot_benchmark2 root [io, pure] = action (io ++ pure)+-- Plot a single benchmark as a gnuplot script:+plot_benchmark2 root [io, pure] = + do action $ filter goodSched (io ++ pure)+ return$ Best (benchname, bestsched, bestthreads, best, basetime / best) 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)++ goodSched [] = error "Empty block of data entries..."+ goodSched (h:t) = not $ (sched h) `elem` scheduler_MASK++ cat = concat io ++ concat pure+ threads0 = filter ((== 0) . threads) cat+ threads1 = filter ((== 1) . threads) cat++ map_normalized_time = map (\x -> tmed x / normfactor x)++ times0 = map_normalized_time threads0+ times1 = map_normalized_time threads1++ basetime = if not$ null times0 + then foldl1 min times0+ else if not$ null times1 + then foldl1 min times1+ else error$ "\nFor benchmark "++ show benchname ++ " could not find either 1-thread or 0-thread run.\n" +++ --"ALL entries: "++ show (pPrint cat) ++"\n"+ "\nALL entries threads: "++ show (map threads cat)++ best = foldl1 min $ map_normalized_time cat+ Just best_index = elemIndex best $ map_normalized_time cat+ bestsched = sched$ cat !! best_index+ bestthreads = threads$ cat !! best_index+ (filebase,_) = break (== '.') $ basename benchname + -- If all normfactors are the default 1.0 we print a different message:+ --let is_norm = not$ all (== 1.0) $ map normfactor ponits+ norms = map normfactor (concat io ++ concat pure)+ default_norms = all (== 1.0) $ norms+ max_norm = foldl1 max norms+ scrub '_' = ' ' scrub x = x -- scrub [] = []@@ -241,54 +311,82 @@ do let scriptfile = root ++ filebase ++ ".gp" putStrLn$ "Dumping gnuplot script to: "++ scriptfile++ putStrLn$ "NORM FACTORS "++ show norms++ 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+ ", speedup relative to serial time " ++ show (round_2digits $ basetime * max_norm) ++" seconds "++ +-- "for input size " ++ show (round_2digits max_norm)+ (if default_norms then "" else "for input size " ++ show (round max_norm))+ --if is_norm then "normalized to work unit"+ --if default_norms then "" else " per unit benchmark input"+ ++"\"\n") -|- appendTo scriptfile runIO$ echo ("set xlabel \"Number of Threads\"\n") -|- appendTo scriptfile runIO$ echo ("set ylabel \"Parallel Speedup\"\n") -|- appendTo scriptfile+++ runIO$ echo ("set xrange [1:]\n") -|- appendTo scriptfile+ runIO$ echo ("set key left top\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+ runIO$ echo (" \""++ basename datfile ++"\" using 1:2:3:4 with errorbars lt "+++ show (line_types !! i) + ++" title \"\", \\\n") -|- appendTo scriptfile - -- Now a second loop for the lines themselves and to dump the actual data:+ -- Now a second loop for the lines themselves and to dump the actual data to the .dat file: 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+ let schd = sched$ head points -- should be the same across all point+ let var = variant$ head points -- should be the same across all point+ let nickname = var ++"/"++ show (translate schd) runIO$ echo ("# Data for variant "++ nickname ++"\n") -|- appendTo datfile forM_ points $ \x -> do ++ -- Here we print a line of output: runIO$ echo (show (fromIntegral (threads x)) ++" "++- show (basetime / tmed x) ++" "++- show (basetime / tmax x) ++" "++ - show (basetime / tmin x) ++" \n") -|- appendTo datfile+ show (basetime / (tmed x / normfactor x)) ++" "+++ show (basetime / (tmax x / normfactor x)) ++" "++ + show (basetime / (tmin x / normfactor 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")+ "\" using 1:2 with lines linewidth "++linewidth++" lt "++ + show (line_types !! i) ++" title \""++nickname++"\" "++comma++"\n") -|- appendTo scriptfile - putStrLn$ "Finally, running gnuplot..."- -- runIO$ "(cd "++root++"; gnuplot "++basename scriptfile++")"- -- runIO$ "(cd "++root++"; ps2pdf "++ filebase ++".eps )"+ --putStrLn$ "Finally, running gnuplot..."+ --runIO$ "(cd "++root++"; gnuplot "++basename scriptfile++")"+ --runIO$ "(cd "++root++"; ps2pdf "++ filebase ++".eps )" -plot_benchmark2 root _ = putStrLn "plot_benchmark2: Unexpected input" +--plot_benchmark2 root ls = putStrLn$ "plot_benchmark2: Unexpected input, list len: "++ show (length ls)+plot_benchmark2 root [io] = plot_benchmark2 root [io,[]] ++ isMatch rg str = case matchRegex rg str of { Nothing -> False; _ -> True } main = do - dat <- run$ catFrom ["results.dat"] -|- remComments "#" + args <- getArgs + let file = case args of + [f] -> f + [] -> "results.dat"+ dat <- run$ catFrom [file] -|- remComments "#" - let parsed = map (parse . splitRegex (mkRegex "[ \t]+")) +-- let parsed = map (parse . filter (not (== "")) . splitRegex (mkRegex "[ \t]+")) + let parsed = map (parse . filter (not . (== "")) . splitRegex (mkRegex "[ \t]+")) (filter (not . isMatch (mkRegex "ERR")) $+ filter (not . isMatch (mkRegex "TIMEOUT")) $ filter (not . null) dat) let organized = organize_data$ filter ((`elem` ["io","pure"]) . variant) parsed -+-- Notdoing this anymore.. treat it as one big bag -- let chunked = sepDoubleBlanks dat -- let chopped = map (parse . splitRegex (mkRegex "[ \t]+")) -- (chunked !! 0)@@ -298,27 +396,34 @@ -- putStrLn$ show (pPrint (map length chopped)) -- putStrLn$ show (pPrint (map parse chopped)) +-- print "parsed:"; print parsed+ --print "Organized:"; print organized++{- 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/"+ --let root = "./graph_temp/"+ let root = "./" ++ dropExtension file ++ "_graphs/" -- For hygiene, completely anhilate output directory:- system$ "rm -rf " ++root+ 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 ()+ bests <- + forM organized $ \ perbenchmark -> do + best <- 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 ()+ return best --forM_ organized $ \ perbenchmark -> @@ -328,6 +433,23 @@ --plotDots [x11, Size$ Scale 3.0] dat --plotDots [x11, LineStyle 0 [PointSize 5.0]] dat- putStrLn$ "Plotted list"+ putStrLn$ "Plotted list\n\n" + let summarize hnd = do + hPutStrLn hnd $ "# Benchmark, scheduler, best #threads, best median time, max parallel speedup: "+ hPutStrLn hnd $ "# Summary for " ++ file++ let pads n s = take (n - length s) $ repeat ' '+ let pad n x = " " ++ (pads n (show x))++ forM_ bests $ \ (Best(name, sched, threads, best, speed)) ->+ hPutStrLn hnd$ " "++ name++ (pads 25 name) ++ + show sched++ (pad 5 sched) ++ + show threads++ (pad 5 threads)++ + show best ++ (pad 15 best) +++ show speed + hPutStrLn hnd$ "\n\n"++ summarize stdout+ withFile (dropExtension file `addExtension` "summary") WriteMode $ summarize
timeout.hs view
@@ -9,7 +9,7 @@ import Control.Concurrent -polltime = 2 -- in seconds+polltime = 10 -- in seconds main = do args <- getArgs @@ -28,7 +28,9 @@ let loop acc = if acc > (timeout :: Int) then do putStrLn$ "\nERROR: TIMED OUT!"- exitWith (ExitFailure 88)+ putMVar sync (ExitFailure 88)+ --exitWith (ExitFailure 88)+ else do sleep polltime x <- getProcessExitCode pid case x of @@ -38,10 +40,10 @@ Just code -> putMVar sync code let poll_thread = loop 0 let wait_thread = - do waitForProcess pid+ do code <- waitForProcess pid writeIORef ref True- putStrLn "++ Command completed without timing out."- putMVar sync ExitSuccess+ putStrLn$ "++ Command completed without timing out, exit code: "++ show code+ putMVar sync code forkIO wait_thread forkIO poll_thread final <- readMVar sync