LogicGrowsOnTrees-MPI 1.0.0 → 1.0.0.1
raw patch · 4 files changed
+120/−48 lines, 4 filesdep ~LogicGrowsOnTreesdep ~cerealdep ~stmnew-component:exe:count-all-trivial-tree-leavesl
Dependency ranges changed: LogicGrowsOnTrees, cereal, stm
Files
- LogicGrowsOnTrees-MPI.cabal +31/−9
- examples/count-all-trivial-tree-leaves.hs +24/−0
- sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs +64/−38
- tests/test-trivial.hs +1/−1
LogicGrowsOnTrees-MPI.cabal view
@@ -1,5 +1,5 @@ Name: LogicGrowsOnTrees-MPI-Version: 1.0.0+Version: 1.0.0.1 License: BSD3 License-file: LICENSE Author: Gregory Crosswhite@@ -36,13 +36,13 @@ Source-Repository this Type: git Location: git://github.com/gcross/LogicGrowsOnTrees-MPI.git- Tag: 1.0.0+ Tag: 1.0.0.1 Library Build-depends: base > 4 && < 5, bytestring >= 0.9 && < 0.11,- cereal == 0.3.*,+ cereal >= 0.3 && < 0.5, cmdtheline == 0.2.*, containers >= 0.4 && < 0.6, data-ivar >= 0.30 && < 1.0,@@ -50,9 +50,9 @@ hslogger == 1.2.*, hslogger-template == 2.0.*, MonadCatchIO-transformers == 0.3.*,- stm == 2.4.*,+ stm >= 2.3 && < 2.5, transformers >= 0.2 && < 0.4,- LogicGrowsOnTrees == 1.0.*+ LogicGrowsOnTrees >= 1.0 && < 1.2 Hs-source-dirs: sources Extra-libraries: mpi C-sources: c-sources/LogicGrowsOnTrees-MPI.c@@ -65,17 +65,39 @@ Description: Enables most warnings. Default: False +Flag examples+ Description: Enable building the example executables.+ Default: False+ Flag tests- Description: Enable building the n-queens executables.+ Description: Enable building the test executables. Default: False +Executable count-all-trivial-tree-leavesl+ Main-is: count-all-trivial-tree-leaves.hs+ Hs-source-dirs: examples+ Build-depends:+ base > 4 && < 5,+ cmdtheline == 0.2.*,+ hslogger == 1.2.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2,+ LogicGrowsOnTrees-MPI+ Extra-libraries: mpi+ C-sources: c-sources/LogicGrowsOnTrees-MPI.c+ if flag(examples)+ Buildable: True+ else+ Buildable: False+ if flag(warnings)+ GHC-Options: -Wall -fno-warn-name-shadowing+ Executable test-trivial Main-is: test-trivial.hs Hs-source-dirs: tests Build-depends: base > 4 && < 5, hslogger == 1.2.*,- LogicGrowsOnTrees == 1.0.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2, LogicGrowsOnTrees-MPI Extra-libraries: mpi C-sources: c-sources/LogicGrowsOnTrees-MPI.c@@ -91,10 +113,10 @@ Hs-source-dirs: tests Build-depends: base > 4 && < 5,- cereal == 0.3.*,+ cereal >= 0.3 && < 0.5, cmdtheline == 0.2.*, hslogger == 1.2.*,- LogicGrowsOnTrees == 1.0.*,+ LogicGrowsOnTrees >= 1.0 && < 1.2, LogicGrowsOnTrees-MPI Extra-libraries: mpi C-sources: c-sources/LogicGrowsOnTrees-MPI.c
+ examples/count-all-trivial-tree-leaves.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++import Control.Applicative++import System.Console.CmdTheLine++import LogicGrowsOnTrees.Parallel.Main+import LogicGrowsOnTrees.Parallel.Adapter.MPI+import LogicGrowsOnTrees.Utils.PerfectTree+import LogicGrowsOnTrees.Utils.WordSum++main =+ mainForExploreTree+ driver+ (makeArityAndDepthTermAtPositions 0 1)+ (defTI { termDoc = "count the leaves of a tree" })+ (\_ (RunOutcome _ termination_reason) → do+ case termination_reason of+ Aborted _ → error "search aborted"+ Completed (WordSum count) → print count+ Failure _ message → error $ "error: " ++ message+ )+ (trivialPerfectTree <$> arity <*> depth)
sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -36,8 +39,8 @@ , driverMPI -- * MPI -- ** Monad and runner- , MPI- , runMPI+ , MPI()+ , withMPI -- ** Information and communication , getMPIInformation , receiveBroadcastMessage@@ -50,6 +53,8 @@ , fork , getCurrentProgressAsync , getCurrentProgress+ , getCurrentStatisticsAsync+ , getCurrentStatistics , getNumberOfWorkersAsync , getNumberOfWorkers , requestProgressUpdateAsync@@ -73,8 +78,7 @@ import Control.Concurrent (threadDelay) import Control.Exception (onException) import Control.Monad (liftM2,unless)-import Control.Monad.CatchIO (MonadCatchIO(..),finally)-import Control.Monad.Fix (MonadFix())+import Control.Monad.CatchIO (MonadCatchIO(..),bracket) import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.ByteString (packCStringLen)@@ -98,7 +102,14 @@ import qualified LogicGrowsOnTrees.Parallel.Common.Process as Process import LogicGrowsOnTrees.Parallel.Common.Message import LogicGrowsOnTrees.Parallel.Common.RequestQueue-import LogicGrowsOnTrees.Parallel.Common.Supervisor hiding (getCurrentProgress,getNumberOfWorkers,runSupervisor,setWorkloadBufferSize)+import LogicGrowsOnTrees.Parallel.Common.Supervisor+ hiding+ (getCurrentProgress+ ,getCurrentStatistics+ ,getNumberOfWorkers+ ,runSupervisor+ ,setWorkloadBufferSize+ ) import LogicGrowsOnTrees.Parallel.ExplorationMode import LogicGrowsOnTrees.Parallel.Purity @@ -127,17 +138,21 @@ ) ⇒ Driver IO shared_configuration supervisor_configuration m n exploration_mode -- Note: The Monoid constraint should not have been necessary, but the type-checker complains without it. driver =- case (driverMPI :: Driver MPI shared_configuration supervisor_configuration m n exploration_mode) of- Driver runDriver → Driver (runMPI . runDriver)-{-| The same as 'driver', but runs in the 'MPI' monad; use this driver if you- want to do other things within 'MPI' (such as starting a subsequent parallel- exploration) after the run completes.+ let ?mpi_secret = MPISecret+ in case (driverMPI :: Driver IO shared_configuration supervisor_configuration m n exploration_mode) of+ Driver runDriver → Driver (\x → withMPI (runDriver x))+{-# INLINE driver #-}++{-| This is the same as 'driver', but it has the 'Network' constraint. Use this + driver if you want to do other things within MPI (such as starting a+ subseqent parallel exploration) after the run completes. -} driverMPI :: ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)- ) ⇒ Driver MPI shared_configuration supervisor_configuration m n exploration_mode+ , MPI+ ) ⇒ Driver IO shared_configuration supervisor_configuration m n exploration_mode -- Note: The Monoid constraint should not have been necessary, but the type-checker complains without it. driverMPI = Driver $ \DriverParameters{..} → runExplorer@@ -150,26 +165,31 @@ constructController >>= maybe (return ()) (liftIO . (notifyTerminated <$> fst . fst <*> snd . fst <*> snd))+{-# INLINE driverMPI #-} -------------------------------------------------------------------------------- ------------------------------------- MPI ------------------------------------- -------------------------------------------------------------------------------- -{-| This monad exists in order to ensure that the MPI system is initialized+data MPISecret = MPISecret {- This is *not* meant to be exported. -}++{-| This constraint exists in order to ensure that the MPI system is initialized before it is used and finalized when we are done; all MPI operations are- run within it, and it itself is run by using the 'runMPI' function.+ run with it, and it itself is run by using the 'withMPI' function. -}-newtype MPI α = MPI { unwrapMPI :: IO α } deriving (Applicative,Functor,Monad,MonadCatchIO,MonadFix,MonadIO)+type MPI = ?mpi_secret :: MPISecret -{-| Initilizes MPI, runs the 'MPI' action, and then finalizes MPI. -}-runMPI :: MPI α → IO α-runMPI action = unwrapMPI $ ((initializeMPI >> action) `finally` finalizeMPI)+{-| Initilizes MPI, runs the given action, and then finalizes MPI. -}+withMPI :: (MPI ⇒ IO α) → IO α+withMPI action =+ let ?mpi_secret = MPISecret+ in bracket initializeMPI (const finalizeMPI) (const action) {-| Gets the total number of processes and whether this process is process 0. -}-getMPIInformation :: MPI (Bool,CInt)+getMPIInformation :: MPI ⇒ IO (Bool,CInt) foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_getMPIInformation" c_getMPIInformation :: Ptr CInt → Ptr CInt → IO () getMPIInformation = do- (i_am_supervisor,number_of_workers) ← liftIO $+ (i_am_supervisor,number_of_workers) ← alloca $ \p_i_am_supervisor → alloca $ \p_number_of_workers → do c_getMPIInformation p_i_am_supervisor p_number_of_workers@@ -181,9 +201,9 @@ return (i_am_supervisor,number_of_workers) {-| Receves a message broadcast from process 0 (which must not be this process). -}-receiveBroadcastMessage :: Serialize α ⇒ MPI α+receiveBroadcastMessage :: (Serialize α, MPI) ⇒ IO α foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_receiveBroadcastMessage" c_receiveBroadcastMessage :: Ptr (Ptr CChar) → Ptr CInt → IO ()-receiveBroadcastMessage = liftIO $+receiveBroadcastMessage = alloca $ \p_p_message → alloca $ \p_size → do c_receiveBroadcastMessage p_p_message p_size@@ -194,16 +214,16 @@ return . either error id . decode $ message {-| Sends a message broadcast from this process, which must be process 0. -}-sendBroadcastMessage :: Serialize α ⇒ α → MPI ()+sendBroadcastMessage :: (Serialize α, MPI) ⇒ α → IO () foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_sendBroadcastMessage" c_sendBroadcastMessage :: Ptr CChar → CInt → IO ()-sendBroadcastMessage message = liftIO $+sendBroadcastMessage message = unsafeUseAsCStringLen (encode message) $ \(p_message,size) → c_sendBroadcastMessage p_message (fromIntegral size) {-| Sends a message to another process. -}-sendMessage :: Serialize α ⇒ α → CInt → MPI ()+sendMessage :: (Serialize α, MPI) ⇒ α → CInt → IO () foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_sendMessage" c_sendMessage :: Ptr CChar → CInt → CInt → IO ()-sendMessage message destination = liftIO $+sendMessage message destination = unsafeUseAsCStringLen (encode message) $ \(p_message,size) → c_sendMessage p_message (fromIntegral size) destination @@ -211,7 +231,7 @@ be received; this function will not block if there are no messages available. -}-tryReceiveMessage :: Serialize α ⇒ MPI (Maybe (CInt,α))+tryReceiveMessage :: (Serialize α, MPI) ⇒ IO (Maybe (CInt,α)) foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_tryReceiveMessage" c_tryReceiveMessage :: Ptr CInt → Ptr (Ptr CChar) → Ptr CInt → IO () tryReceiveMessage = liftIO $ alloca $ \p_source →@@ -232,11 +252,11 @@ --------------------------------- Internal MPI --------------------------------- -------------------------------------------------------------------------------- -finalizeMPI :: MPI ()+finalizeMPI :: MPI ⇒ IO () foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_finalizeMPI" c_finalizeMPI :: IO () finalizeMPI = liftIO c_finalizeMPI -initializeMPI :: MPI ()+initializeMPI :: MPI ⇒ IO () foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_initializeMPI" c_initializeMPI :: IO () initializeMPI = liftIO c_initializeMPI @@ -246,7 +266,7 @@ {-| This is the monad in which the MPI controller will run. -} newtype MPIControllerMonad exploration_mode α =- C (RequestQueueReader exploration_mode CInt MPI α)+ C (RequestQueueReader exploration_mode CInt IO α) deriving (Applicative,Functor,Monad,MonadCatchIO,MonadIO,RequestQueueMonad) instance HasExplorationMode (MPIControllerMonad exploration_mode) where@@ -270,19 +290,20 @@ warning in the documentation for this module for more details. -} -type MPIMonad exploration_mode = SupervisorMonad exploration_mode CInt MPI+type MPIMonad exploration_mode = SupervisorMonad exploration_mode CInt IO {-| This runs the supervisor; it must be called in process 0. -} runSupervisor :: ∀ exploration_mode. ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , MPI ) ⇒ CInt {-^ the number of workers -} → ExplorationMode exploration_mode {-^ the exploration mode -} → ProgressFor exploration_mode {-^ the initial progress of the run -} → MPIControllerMonad exploration_mode () {-^ the controller of the supervisor -} →- MPI (RunOutcomeFor exploration_mode) {-^ the outcome of the run -}+ IO (RunOutcomeFor exploration_mode) {-^ the outcome of the run -} runSupervisor number_of_workers exploration_mode@@ -300,7 +321,7 @@ sendWorkloadToWorker = sendMessage . StartWorkload - tryGetRequest :: MPI (Maybe (Either (MPIMonad exploration_mode ()) (CInt,MessageForSupervisorFor exploration_mode)))+ tryGetRequest :: IO (Maybe (Either (MPIMonad exploration_mode ()) (CInt,MessageForSupervisorFor exploration_mode))) tryGetRequest = do maybe_message ← tryReceiveMessage case maybe_message of@@ -340,7 +361,7 @@ let confirmShutdown remaining_workers | Set.null remaining_workers = return () | otherwise =- (tryReceiveMessage :: MPI (Maybe (CInt,MessageForSupervisorFor exploration_mode))) >>=+ (tryReceiveMessage :: IO (Maybe (CInt,MessageForSupervisorFor exploration_mode))) >>= maybe (confirmShutdown remaining_workers) (\(worker_id,message) → case message of WorkerQuit → confirmShutdown (Set.delete worker_id remaining_workers)@@ -348,16 +369,18 @@ ) confirmShutdown $ Set.fromList [1..number_of_workers] return $ extractRunOutcomeFromSupervisorOutcome supervisor_outcome+{-# INLINE runSupervisor #-} {-| Runs a worker; it must be called in all processes other than process 0. -} runWorker :: ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , MPI ) ⇒ ExplorationMode exploration_mode {-^ the mode in to explore the tree -} → Purity m n {-^ the purity of the tree -} → TreeT m (ResultFor exploration_mode) {-^ the tree -} →- MPI ()+ IO () runWorker exploration_mode purity@@ -368,9 +391,10 @@ exploration_mode purity tree- (fix $ \receiveMessage → unwrapMPI tryReceiveMessage >>= maybe (threadDelay 1 >> receiveMessage) (return . snd))- (unwrapMPI . flip sendMessage 0)+ (fix $ \receiveMessage → tryReceiveMessage >>= maybe (threadDelay 1 >> receiveMessage) (return . snd))+ (flip sendMessage 0) debugM "Exited worker loop."+{-# INLINE runWorker #-} {-| Explores the given tree using MPI to achieve parallelism. @@ -384,6 +408,7 @@ ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode)+ , MPI ) ⇒ (shared_configuration → ExplorationMode exploration_mode) {-^ a function that constructs the exploration mode given the shared@@ -411,7 +436,7 @@ must at least set the number of workers to be non-zero (called only on the supervisor) -} →- MPI (Maybe ((shared_configuration,supervisor_configuration),RunOutcomeFor exploration_mode))+ IO (Maybe ((shared_configuration,supervisor_configuration),RunOutcomeFor exploration_mode)) {-^ if this process is the supervisor, then the outcome of the run as well as the configuration information wrapped in 'Just'; otherwise 'Nothing'@@ -432,7 +457,7 @@ debugM "I am the supervisor process." debugM "Getting configuration..." configuration@(shared_configuration,supervisor_configuration) ←- liftIO (getConfiguration `onException` unwrapMPI (sendBroadcastMessage (Nothing :: Maybe shared_configuration)))+ getConfiguration `onException` sendBroadcastMessage (Nothing :: Maybe shared_configuration) debugM "Broacasting shared configuration..." sendBroadcastMessage (Just shared_configuration) debugM "Initializing global state..."@@ -461,3 +486,4 @@ purity (constructTree shared_configuration) return Nothing+{-# INLINE runExplorer #-}
tests/test-trivial.hs view
@@ -13,7 +13,7 @@ main = -- updateGlobalLogger rootLoggerName (setLevel DEBUG) >>- (runMPI $+ (withMPI $ runExplorer (const AllMode) Pure