diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2012, Gregory Crosswhite +All rights reserved. + +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. + +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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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. diff --git a/LogicGrowsOnTrees-MPI.cabal b/LogicGrowsOnTrees-MPI.cabal new file mode 100644 --- /dev/null +++ b/LogicGrowsOnTrees-MPI.cabal @@ -0,0 +1,106 @@ +Name: LogicGrowsOnTrees-MPI +Version: 1.0.0 +License: BSD3 +License-file: LICENSE +Author: Gregory Crosswhite +Maintainer: Gregory Crosswhite +Synopsis: an adapter for LogicGrowsOnTrees that uses MPI +Cabal-version: >=1.8 +Build-type: Simple +Category: Control, Distributed Computing, Logic, Parallelism +Description: + + (The package unfortunately cannot be built on the Hackage server because + MPI is not installed on it.) + . + This package provides a adapter for the LogicGrowsOnTrees package that uses + MPI for parallelism. See the module documentation for more details. + . + NOTE: You need to have an MPI implementation installed to use the package; + no thread support is required, and it only uses very simple + functionality so MPI 1.0 or 1.1 should suffice. Also, @mpi.h@ needs + to be in the include path and a library named @mpi@ (@libmpi@ in + unix) in the library path; if these files are not in their respective + paths, you can add their directories to their respective search paths + for this package by using Cabal's respective + @--extra-include-dirs=...@ and @--extra-lib-dirs=...@ options. + +Extra-source-files: c-sources/LogicGrowsOnTrees-MPI.c c-sources/LogicGrowsOnTrees-MPI.h + +Bug-reports: https://github.com/gcross/LogicGrowsOnTrees-MPI/issues + +Source-Repository head + Type: git + Location: git://github.com/gcross/LogicGrowsOnTrees-MPI.git + +Source-Repository this + Type: git + Location: git://github.com/gcross/LogicGrowsOnTrees-MPI.git + Tag: 1.0.0 + +Library + Build-depends: + base > 4 && < 5, + bytestring >= 0.9 && < 0.11, + cereal == 0.3.*, + cmdtheline == 0.2.*, + containers >= 0.4 && < 0.6, + data-ivar >= 0.30 && < 1.0, + derive >= 2.5.9 && < 2.6, + hslogger == 1.2.*, + hslogger-template == 2.0.*, + MonadCatchIO-transformers == 0.3.*, + stm == 2.4.*, + transformers >= 0.2 && < 0.4, + LogicGrowsOnTrees == 1.0.* + Hs-source-dirs: sources + Extra-libraries: mpi + C-sources: c-sources/LogicGrowsOnTrees-MPI.c + Exposed-modules: + LogicGrowsOnTrees.Parallel.Adapter.MPI + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Flag warnings + Description: Enables most warnings. + Default: False + +Flag tests + Description: Enable building the n-queens executables. + Default: False + +Executable test-trivial + Main-is: test-trivial.hs + Hs-source-dirs: tests + Build-depends: + base > 4 && < 5, + hslogger == 1.2.*, + LogicGrowsOnTrees == 1.0.*, + LogicGrowsOnTrees-MPI + Extra-libraries: mpi + C-sources: c-sources/LogicGrowsOnTrees-MPI.c + if flag(tests) + Buildable: True + else + Buildable: False + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Executable test-nqueens + Main-is: test-nqueens.hs + Hs-source-dirs: tests + Build-depends: + base > 4 && < 5, + cereal == 0.3.*, + cmdtheline == 0.2.*, + hslogger == 1.2.*, + LogicGrowsOnTrees == 1.0.*, + LogicGrowsOnTrees-MPI + Extra-libraries: mpi + C-sources: c-sources/LogicGrowsOnTrees-MPI.c + if flag(tests) + Buildable: True + else + Buildable: False + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/c-sources/LogicGrowsOnTrees-MPI.c b/c-sources/LogicGrowsOnTrees-MPI.c new file mode 100644 --- /dev/null +++ b/c-sources/LogicGrowsOnTrees-MPI.c @@ -0,0 +1,50 @@ +#include +#include + +#include "LogicGrowsOnTrees-MPI.h" + +void LogicGrowsOnTrees_MPI_finalizeMPI() {{{ + MPI_Finalize(); +}}} + +void LogicGrowsOnTrees_MPI_getMPIInformation(int *i_am_supervisor, int *number_of_workers) {{{ + int my_rank; + MPI_Comm_rank(MPI_COMM_WORLD,&my_rank); + *i_am_supervisor = (my_rank == 0); + + MPI_Comm_size(MPI_COMM_WORLD,number_of_workers); + --(*number_of_workers); +}}} + +void LogicGrowsOnTrees_MPI_initializeMPI() {{{ + MPI_Init(NULL,NULL); +}}} + +void LogicGrowsOnTrees_MPI_receiveBroadcastMessage(char **message, int *size) {{{ + MPI_Bcast(size,1,MPI_INT,0,MPI_COMM_WORLD); + *message = (char*)malloc((size_t)*size); + MPI_Bcast(*message,*size,MPI_CHAR,0,MPI_COMM_WORLD); +}}} + +void LogicGrowsOnTrees_MPI_sendBroadcastMessage(char *message, int size) {{{ + MPI_Bcast(&size,1,MPI_INT,0,MPI_COMM_WORLD); + MPI_Bcast(message,size,MPI_CHAR,0,MPI_COMM_WORLD); +}}} + +void LogicGrowsOnTrees_MPI_sendMessage(char *message, int size, int destination) {{{ + MPI_Send(message,size,MPI_CHAR,destination,0,MPI_COMM_WORLD); +}}} + +void LogicGrowsOnTrees_MPI_tryReceiveMessage(int* source, char** message, int *size) {{{ + int flag; + MPI_Status status; + MPI_Iprobe(MPI_ANY_SOURCE,0,MPI_COMM_WORLD,&flag,&status); + if(flag) { + *source = status.MPI_SOURCE; + MPI_Get_count(&status,MPI_CHAR,size); + *message = (char*)malloc((size_t)*size); + MPI_Recv(*message,*size,MPI_CHAR,*source,0,MPI_COMM_WORLD,MPI_STATUS_IGNORE); + } else { + *source = -1; + } +}}} diff --git a/c-sources/LogicGrowsOnTrees-MPI.h b/c-sources/LogicGrowsOnTrees-MPI.h new file mode 100644 --- /dev/null +++ b/c-sources/LogicGrowsOnTrees-MPI.h @@ -0,0 +1,12 @@ +#ifndef VISITOR_MPI +#define VISITOR_MPI + +void LogicGrowsOnTrees_MPI_finalizeMPI(); +void LogicGrowsOnTrees_MPI_getMPIInformation(int *i_am_supervisor, int *number_of_workers); +void LogicGrowsOnTrees_MPI_initializeMPI(); +void LogicGrowsOnTrees_MPI_receiveBroadcastMessage(char **message, int *size); +void LogicGrowsOnTrees_MPI_sendBroadcastMessage(char *message, int size); +void LogicGrowsOnTrees_MPI_sendMessage(char *message, int size, int destination); +void LogicGrowsOnTrees_MPI_tryReceiveMessage(int* source, char** message, int *size); + +#endif diff --git a/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs b/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs new file mode 100644 --- /dev/null +++ b/sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnicodeSyntax #-} + +{-| This adapter implements parallelism by via MPI; process 0 is the + supervisor and the other processes are the workers. (This does mean that one + process is used only for coordination, but this approach simplifies things + and also ensures that worker requests and responses will be handled + promptly.) + + WARNING: Do *NOT* use the threaded runtime with this adapter as it has been + designed with the assumption that the run-time is single-threaded. + This was done because the MPI implementation might not support + having multiple operating system threads (even if only one of them + calls MPI functions), and anyway multiple operating system threads + provide no benefit over lightweight Haskell threads in this case + because the MPI scheduler will assign an MPI process to each CPU + core so multiple threads will not result in better performance but + rather in multiple processes fighting over the same CPU core, as + well as the additional overhead of the threaded runtime compared to + the non-threaded runtime. + -} +module LogicGrowsOnTrees.Parallel.Adapter.MPI + ( + -- * Driver + driver + , driverMPI + -- * MPI + -- ** Monad and runner + , MPI + , runMPI + -- ** Information and communication + , getMPIInformation + , receiveBroadcastMessage + , sendBroadcastMessage + , sendMessage + , tryReceiveMessage + -- * Controller + , MPIControllerMonad + , abort + , fork + , getCurrentProgressAsync + , getCurrentProgress + , getNumberOfWorkersAsync + , getNumberOfWorkers + , requestProgressUpdateAsync + , requestProgressUpdate + , setWorkloadBufferSize + -- * Outcome types + , RunOutcome(..) + , RunStatistics(..) + , TerminationReason(..) + -- * Generic runners + -- $runners + , runSupervisor + , runWorker + , runExplorer + ) where + + +import Prelude hiding (catch) + +import Control.Applicative ((<$>),(<*>),Applicative(),liftA2) +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.IO.Class (MonadIO(liftIO)) + +import Data.ByteString (packCStringLen) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Function (fix) +import Data.Serialize +import qualified Data.Set as Set + +import Foreign.C.Types (CChar,CInt(..)) +import Foreign.Marshal.Alloc (alloca,free) +import Foreign.Marshal.Utils (toBool) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) + +import qualified System.Log.Logger as Logger +import System.Log.Logger (Priority(DEBUG)) +import System.Log.Logger.TH + +import LogicGrowsOnTrees (TreeT) +import LogicGrowsOnTrees.Parallel.Main +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.ExplorationMode +import LogicGrowsOnTrees.Parallel.Purity + +-------------------------------------------------------------------------------- +----------------------------------- Loggers ------------------------------------ +-------------------------------------------------------------------------------- + +deriveLoggers "Logger" [DEBUG] + +-------------------------------------------------------------------------------- +------------------------------------ Driver ------------------------------------ +-------------------------------------------------------------------------------- + +{-| This is the driver for the MPI adapter; process 0 acts as the supervisor + and the other processes act as workers. + + WARNING: Do *NOT* use the threaded runtime with this driver (or 'driverMPI'); + see the warning in the documentation for this module for more + details. + -} +driver :: + ∀ shared_configuration supervisor_configuration m n exploration_mode. + ( Serialize shared_configuration + , Serialize (ProgressFor exploration_mode) + , Serialize (WorkerFinishedProgressFor exploration_mode) + ) ⇒ 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. + -} +driverMPI :: + ( Serialize shared_configuration + , Serialize (ProgressFor exploration_mode) + , Serialize (WorkerFinishedProgressFor exploration_mode) + ) ⇒ Driver MPI 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 + constructExplorationMode + purity + (mainParser (liftA2 (,) shared_configuration_term supervisor_configuration_term) program_info) + initializeGlobalState + constructTree + getStartingProgress + constructController + >>= + maybe (return ()) (liftIO . (notifyTerminated <$> fst . fst <*> snd . fst <*> snd)) + +-------------------------------------------------------------------------------- +------------------------------------- MPI ------------------------------------- +-------------------------------------------------------------------------------- + +{-| This monad 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. + -} +newtype MPI α = MPI { unwrapMPI :: IO α } deriving (Applicative,Functor,Monad,MonadCatchIO,MonadFix,MonadIO) + +{-| Initilizes MPI, runs the 'MPI' action, and then finalizes MPI. -} +runMPI :: MPI α → IO α +runMPI action = unwrapMPI $ ((initializeMPI >> action) `finally` finalizeMPI) + +{-| Gets the total number of processes and whether this process is process 0. -} +getMPIInformation :: MPI (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 $ + alloca $ \p_i_am_supervisor → + alloca $ \p_number_of_workers → do + c_getMPIInformation p_i_am_supervisor p_number_of_workers + liftM2 (,) + (toBool <$> peek p_i_am_supervisor) + (peek p_number_of_workers) + unless (number_of_workers > 0) $ + error "The number of total processes must be at least 2 so there is at least 1 worker." + return (i_am_supervisor,number_of_workers) + +{-| Receves a message broadcast from process 0 (which must not be this process). -} +receiveBroadcastMessage :: Serialize α ⇒ MPI α +foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_receiveBroadcastMessage" c_receiveBroadcastMessage :: Ptr (Ptr CChar) → Ptr CInt → IO () +receiveBroadcastMessage = liftIO $ + alloca $ \p_p_message → + alloca $ \p_size → do + c_receiveBroadcastMessage p_p_message p_size + p_message ← peek p_p_message + size ← peek p_size + message ← packCStringLen (p_message,fromIntegral size) + free p_message + return . either error id . decode $ message + +{-| Sends a message broadcast from this process, which must be process 0. -} +sendBroadcastMessage :: Serialize α ⇒ α → MPI () +foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_sendBroadcastMessage" c_sendBroadcastMessage :: Ptr CChar → CInt → IO () +sendBroadcastMessage message = liftIO $ + unsafeUseAsCStringLen (encode message) $ \(p_message,size) → + c_sendBroadcastMessage p_message (fromIntegral size) + +{-| Sends a message to another process. -} +sendMessage :: Serialize α ⇒ α → CInt → MPI () +foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_sendMessage" c_sendMessage :: Ptr CChar → CInt → CInt → IO () +sendMessage message destination = liftIO $ + unsafeUseAsCStringLen (encode message) $ \(p_message,size) → + c_sendMessage p_message (fromIntegral size) destination + +{-| Receives a message (along with the sending process id) if one is waiting to + be received; this function will not block if there are no messages + available. + -} +tryReceiveMessage :: Serialize α ⇒ MPI (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 → + alloca $ \p_p_message → + alloca $ \p_size → do + c_tryReceiveMessage p_source p_p_message p_size + source ← peek p_source + if source == -1 + then return Nothing + else do + p_message ← peek p_p_message + size ← peek p_size + message ← packCStringLen (p_message,fromIntegral size) + free p_message + return $ Just (source,either error id . decode $ message) + +-------------------------------------------------------------------------------- +--------------------------------- Internal MPI --------------------------------- +-------------------------------------------------------------------------------- + +finalizeMPI :: MPI () +foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_finalizeMPI" c_finalizeMPI :: IO () +finalizeMPI = liftIO c_finalizeMPI + +initializeMPI :: MPI () +foreign import ccall unsafe "LogicGrowsOnTrees-MPI.h LogicGrowsOnTrees_MPI_initializeMPI" c_initializeMPI :: IO () +initializeMPI = liftIO c_initializeMPI + +-------------------------------------------------------------------------------- +---------------------------------- Controller ---------------------------------- +-------------------------------------------------------------------------------- + +{-| This is the monad in which the MPI controller will run. -} +newtype MPIControllerMonad exploration_mode α = + C (RequestQueueReader exploration_mode CInt MPI α) + deriving (Applicative,Functor,Monad,MonadCatchIO,MonadIO,RequestQueueMonad) + +instance HasExplorationMode (MPIControllerMonad exploration_mode) where + type ExplorationModeFor (MPIControllerMonad exploration_mode) = exploration_mode + +-------------------------------------------------------------------------------- +------------------------------- Generic runners -------------------------------- +-------------------------------------------------------------------------------- + +{- $runners +In this section the full functionality of this module is exposed in case one +does not want the restrictions of the driver interface. If you decide to go in +this direction, then you need to decide whether you want to manually handle +factors such as deciding whether a process is the supervisor or a worker and the +propagation of configuration information to the worker or whether you want this +to be done automatically; if you want full control then call 'runSupervisor' +in the supervisor process --- which *must* be process 0! --- and call +'runWorker' in the worker processes, otherwise call 'runExplorer'. + +WARNING: Do *NOT* use the threaded runtime with this adapter; see the + warning in the documentation for this module for more details. + -} + +type MPIMonad exploration_mode = SupervisorMonad exploration_mode CInt MPI + +{-| This runs the supervisor; it must be called in process 0. -} +runSupervisor :: + ∀ exploration_mode. + ( Serialize (ProgressFor exploration_mode) + , Serialize (WorkerFinishedProgressFor exploration_mode) + ) ⇒ + 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 -} +runSupervisor + number_of_workers + exploration_mode + starting_progress + (C controller) + = do + debugM "Creating request queue and forking controller thread..." + request_queue ← newRequestQueue + forkControllerThread request_queue controller + let broadcastProgressUpdateToWorkers = mapM_ (sendMessage RequestProgressUpdate) + + broadcastWorkloadStealToWorkers = mapM_ (sendMessage RequestWorkloadSteal) + + receiveCurrentProgress = receiveProgress request_queue + + sendWorkloadToWorker = sendMessage . StartWorkload + + tryGetRequest :: MPI (Maybe (Either (MPIMonad exploration_mode ()) (CInt,MessageForSupervisorFor exploration_mode))) + tryGetRequest = do + maybe_message ← tryReceiveMessage + case maybe_message of + Just message → return . Just . Right $ message + Nothing → do + maybe_request ← tryDequeueRequest request_queue + case maybe_request of + Just request → return . Just . Left $ request + Nothing → return Nothing + debugM "Entering supervisor loop..." + supervisor_outcome ← + runSupervisorStartingFrom + exploration_mode + starting_progress + (SupervisorCallbacks{..}) + (PollingProgram + (mapM_ addWorker [1..number_of_workers]) + tryGetRequest + . + either id + $ + \(worker_id,message) → case message of + Failed description → + receiveWorkerFailure worker_id description + Finished final_progress → + receiveWorkerFinished worker_id final_progress + ProgressUpdate progress_update → + receiveProgressUpdate worker_id progress_update + StolenWorkload maybe_stolen_workload → + receiveStolenWorkload worker_id maybe_stolen_workload + WorkerQuit → + error $ "Worker " ++ show worker_id ++ " has quit prematurely." + ) + debugM "Exited supervisor loop; shutting down workers..." + killControllerThreads request_queue + mapM_ (sendMessage QuitWorker) [1..number_of_workers] + let confirmShutdown remaining_workers + | Set.null remaining_workers = return () + | otherwise = + (tryReceiveMessage :: MPI (Maybe (CInt,MessageForSupervisorFor exploration_mode))) >>= + maybe (confirmShutdown remaining_workers) (\(worker_id,message) → + case message of + WorkerQuit → confirmShutdown (Set.delete worker_id remaining_workers) + _ → confirmShutdown remaining_workers + ) + confirmShutdown $ Set.fromList [1..number_of_workers] + return $ extractRunOutcomeFromSupervisorOutcome supervisor_outcome + +{-| Runs a worker; it must be called in all processes other than process 0. -} +runWorker :: + ( Serialize (ProgressFor exploration_mode) + , Serialize (WorkerFinishedProgressFor exploration_mode) + ) ⇒ + 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 () +runWorker + exploration_mode + purity + tree + = liftIO $ do + debugM "Entering worker loop..." + Process.runWorker + exploration_mode + purity + tree + (fix $ \receiveMessage → unwrapMPI tryReceiveMessage >>= maybe (threadDelay 1 >> receiveMessage) (return . snd)) + (unwrapMPI . flip sendMessage 0) + debugM "Exited worker loop." + +{-| Explores the given tree using MPI to achieve parallelism. + + This function grants access to all of the functionality of this adapter, + rather than having to go through the more restricted driver interface. The + signature of this function is very complicated because it is meant to be + used in all processes, supervisor and worker alike. + -} +runExplorer :: + ∀ shared_configuration supervisor_configuration exploration_mode m n. + ( Serialize shared_configuration + , Serialize (ProgressFor exploration_mode) + , Serialize (WorkerFinishedProgressFor exploration_mode) + ) ⇒ + (shared_configuration → ExplorationMode exploration_mode) + {-^ a function that constructs the exploration mode given the shared + configuration + -} → + Purity m n {-^ the purity of the tree -} → + IO (shared_configuration,supervisor_configuration) + {-^ an action that gets the shared and supervisor-specific configuration + information (run only on the supervisor) + -} → + (shared_configuration → IO ()) + {-^ an action that initializes the global state of the process given the + shared configuration (run on both supervisor and worker processes) + -} → + (shared_configuration → TreeT m (ResultFor exploration_mode)) + {-^ a function that constructs the tree from the shared configuration + (called only on the worker) + -} → + (shared_configuration → supervisor_configuration → IO (ProgressFor exploration_mode)) + {-^ an action that gets the starting progress given the full + configuration information (run only on the supervisor) + -} → + (shared_configuration → supervisor_configuration → MPIControllerMonad exploration_mode ()) + {-^ a function that constructs the controller for the supervisor, which + 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)) + {-^ if this process is the supervisor, then the outcome of the run as + well as the configuration information wrapped in 'Just'; otherwise + 'Nothing' + -} +runExplorer + constructExplorationMode + purity + getConfiguration + initializeGlobalState + constructTree + getStartingProgress + constructController + = debugM "Fetching number of processes and whether this is the supervisor process..." >> + getMPIInformation >>= + \(i_am_supervisor,number_of_workers) → + if i_am_supervisor + then do + debugM "I am the supervisor process." + debugM "Getting configuration..." + configuration@(shared_configuration,supervisor_configuration) ← + liftIO (getConfiguration `onException` unwrapMPI (sendBroadcastMessage (Nothing :: Maybe shared_configuration))) + debugM "Broacasting shared configuration..." + sendBroadcastMessage (Just shared_configuration) + debugM "Initializing global state..." + liftIO $ initializeGlobalState shared_configuration + debugM "Reading starting progress..." + starting_progress ← liftIO (getStartingProgress shared_configuration supervisor_configuration) + debugM "Running supervisor..." + Just . (configuration,) <$> + runSupervisor + number_of_workers + (constructExplorationMode shared_configuration) + starting_progress + (constructController shared_configuration supervisor_configuration) + else do + debugM "I am the worker process." + debugM "Getting shared configuration from broadcast..." + maybe_shared_configuration ← receiveBroadcastMessage + case maybe_shared_configuration of + Nothing → return Nothing + Just shared_configuration → do + debugM "Initializing global state..." + liftIO $ initializeGlobalState shared_configuration + debugM "Running worker..." + runWorker + (constructExplorationMode shared_configuration) + purity + (constructTree shared_configuration) + return Nothing diff --git a/tests/test-nqueens.hs b/tests/test-nqueens.hs new file mode 100644 --- /dev/null +++ b/tests/test-nqueens.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Data.Functor ((<$>)) + +import System.Console.CmdTheLine +import System.Log.Logger (Priority(..),rootLoggerName,setLevel,updateGlobalLogger) + +import LogicGrowsOnTrees.Examples.Queens (BoardSize(..),nqueensCorrectCount,nqueensCount) +import LogicGrowsOnTrees.Parallel.Adapter.MPI (driver) +import LogicGrowsOnTrees.Parallel.Main (TerminationReason(..),mainForExploreTree,runTerminationReason) +import LogicGrowsOnTrees.Utils.WordSum (WordSum(..)) + +main = do + -- updateGlobalLogger rootLoggerName (setLevel DEBUG) + mainForExploreTree + driver + (getBoardSize <$> required (flip (pos 0) (posInfo + { posName = "BOARD_SIZE" + , posDoc = "board size" + } + ) Nothing)) + (defTI { termDoc = "count the number of n-queens solutions for a given board size" }) + (\n run_outcome → + case runTerminationReason run_outcome of + Aborted progress → error $ "Explorer aborted with progress " ++ show progress ++ "." + Completed (WordSum number_of_solutions) + | nqueensCorrectCount n == number_of_solutions → + putStrLn $ "Correctly found all " ++ show number_of_solutions ++ " solutions for board size " ++ show n ++ "." + | otherwise → + error $ "Found " ++ show number_of_solutions ++ " instead of " ++ show (nqueensCorrectCount n) ++ " solutions for board size " ++ show n ++ "." + Failure progress description → error $ "Explorer failed with progress " ++ show progress ++ " and reason " ++ show description ++ "." + ) + nqueensCount diff --git a/tests/test-trivial.hs b/tests/test-trivial.hs new file mode 100644 --- /dev/null +++ b/tests/test-trivial.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Applicative ((<$>)) + +import Data.Monoid (mempty) + +import System.Log.Logger (Priority(..),rootLoggerName,setLevel,updateGlobalLogger) + +import LogicGrowsOnTrees.Parallel.Adapter.MPI +import LogicGrowsOnTrees.Parallel.ExplorationMode +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +main = + -- updateGlobalLogger rootLoggerName (setLevel DEBUG) >> + (runMPI $ + runExplorer + (const AllMode) + Pure + (return ((),())) + (const $ return ()) + (const $ return [()]) + (const . const $ return mempty) + (const . const $ return ()) + ) >>= \x → case runTerminationReason . snd <$> x of + Nothing → return () + Just (Aborted progress) → error $ "Explorer aborted with progress " ++ show progress ++ "." + Just (Completed [()]) → putStrLn $ "Trivial search completed successfully." + Just (Completed result) → error $ "Result was " ++ show result ++ " not [()]." + Just (Failure progress description) → error $ "Explorer failed with progress " ++ show progress ++ " and reason " ++ show description ++ "."