diff --git a/Intel/Cnc.Header.hs b/Intel/Cnc.Header.hs --- a/Intel/Cnc.Header.hs +++ b/Intel/Cnc.Header.hs @@ -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 = "" -------------------------------------------------------------------------------- diff --git a/Intel/Cnc.hs b/Intel/Cnc.hs --- a/Intel/Cnc.hs +++ b/Intel/Cnc.hs @@ -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 diff --git a/Intel/Cnc10.hs b/Intel/Cnc10.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc10.hs @@ -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" diff --git a/Intel/Cnc3.hs b/Intel/Cnc3.hs --- a/Intel/Cnc3.hs +++ b/Intel/Cnc3.hs @@ -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 ) diff --git a/Intel/Cnc4.hs b/Intel/Cnc4.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc4.hs @@ -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 + diff --git a/Intel/Cnc5.hs b/Intel/Cnc5.hs --- a/Intel/Cnc5.hs +++ b/Intel/Cnc5.hs @@ -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!" diff --git a/Intel/Cnc6.hs b/Intel/Cnc6.hs --- a/Intel/Cnc6.hs +++ b/Intel/Cnc6.hs @@ -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. diff --git a/Intel/Cnc7.hs b/Intel/Cnc7.hs new file mode 100644 --- /dev/null +++ b/Intel/Cnc7.hs @@ -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 + diff --git a/Intel/Cnc8.hs b/Intel/Cnc8.hs --- a/Intel/Cnc8.hs +++ b/Intel/Cnc8.hs @@ -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!" diff --git a/Intel/CncPure.hs b/Intel/CncPure.hs --- a/Intel/CncPure.hs +++ b/Intel/CncPure.hs @@ -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: diff --git a/Intel/CncUtil.hs b/Intel/CncUtil.hs --- a/Intel/CncUtil.hs +++ b/Intel/CncUtil.hs @@ -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 = "" +-- 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 = "" +-- 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 = "" + +hotVarTransaction = atomically +readHotVarRaw = readTVar +writeHotVarRaw = writeTVar + #endif +instance Show (IO a) where + show ref = "" -------------------------------------------------------------------------------- @@ -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] + diff --git a/Intel/shared_5_6.hs b/Intel/shared_5_6.hs --- a/Intel/shared_5_6.hs +++ b/Intel/shared_5_6.hs @@ -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 = "" -instance Show (IO a) where - show ref = "" +-- 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 _ = "" +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!" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +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 nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. - , 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 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! diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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: diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -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 + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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" diff --git a/default_opt_settings.sh b/default_opt_settings.sh --- a/default_opt_settings.sh +++ b/default_opt_settings.sh @@ -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 " diff --git a/examples/embarrassingly_par.hs b/examples/embarrassingly_par.hs --- a/examples/embarrassingly_par.hs +++ b/examples/embarrassingly_par.hs @@ -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]) diff --git a/examples/fib.hs b/examples/fib.hs --- a/examples/fib.hs +++ b/examples/fib.hs @@ -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 $ diff --git a/examples/mandel.hs b/examples/mandel.hs --- a/examples/mandel.hs +++ b/examples/mandel.hs @@ -28,49 +28,57 @@ #include 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) diff --git a/examples/mandel_opt.hs b/examples/mandel_opt.hs --- a/examples/mandel_opt.hs +++ b/examples/mandel_opt.hs @@ -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 -> diff --git a/examples/nbody.hs b/examples/nbody.hs --- a/examples/nbody.hs +++ b/examples/nbody.hs @@ -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) diff --git a/examples/primes.hs b/examples/primes.hs --- a/examples/primes.hs +++ b/examples/primes.hs @@ -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)) diff --git a/haskell-cnc.cabal b/haskell-cnc.cabal --- a/haskell-cnc.cabal +++ b/haskell-cnc.cabal @@ -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 @@ -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 + diff --git a/install_environment_vars.sh b/install_environment_vars.sh --- a/install_environment_vars.sh +++ b/install_environment_vars.sh @@ -5,3 +5,4 @@ export HASKELLCNC=`pwd` export PATH="$HASKELLCNC:$PATH" + diff --git a/ntimes b/ntimes --- a/ntimes +++ b/ntimes @@ -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: diff --git a/runAllTests.hs b/runAllTests.hs --- a/runAllTests.hs +++ b/runAllTests.hs @@ -1,4 +1,6 @@ +-- Run all tests for the Haskell CnC Runtime System. + import System.Directory import qualified Intel.Cnc import qualified Intel.CncPure diff --git a/run_all_examples.sh b/run_all_examples.sh --- a/run_all_examples.sh +++ b/run_all_examples.sh @@ -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." diff --git a/runcnc b/runcnc --- a/runcnc +++ b/runcnc @@ -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. diff --git a/scaling.hs b/scaling.hs --- a/scaling.hs +++ b/scaling.hs @@ -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 diff --git a/timeout.hs b/timeout.hs --- a/timeout.hs +++ b/timeout.hs @@ -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