diff --git a/LogicGrowsOnTrees-MPI.cabal b/LogicGrowsOnTrees-MPI.cabal --- a/LogicGrowsOnTrees-MPI.cabal +++ b/LogicGrowsOnTrees-MPI.cabal @@ -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 diff --git a/examples/count-all-trivial-tree-leaves.hs b/examples/count-all-trivial-tree-leaves.hs new file mode 100644 --- /dev/null +++ b/examples/count-all-trivial-tree-leaves.hs @@ -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) diff --git a/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs b/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs --- a/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs @@ -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 #-} diff --git a/tests/test-trivial.hs b/tests/test-trivial.hs --- a/tests/test-trivial.hs +++ b/tests/test-trivial.hs @@ -13,7 +13,7 @@ main = -- updateGlobalLogger rootLoggerName (setLevel DEBUG) >> - (runMPI $ + (withMPI $ runExplorer (const AllMode) Pure