LogicGrowsOnTrees-MPI (empty) → 1.0.0
raw patch · 8 files changed
+718/−0 lines, 8 filesdep +LogicGrowsOnTreesdep +LogicGrowsOnTrees-MPIdep +MonadCatchIO-transformerssetup-changed
Dependencies added: LogicGrowsOnTrees, LogicGrowsOnTrees-MPI, MonadCatchIO-transformers, base, bytestring, cereal, cmdtheline, containers, data-ivar, derive, hslogger, hslogger-template, stm, transformers
Files
- LICENSE +22/−0
- LogicGrowsOnTrees-MPI.cabal +106/−0
- Setup.hs +2/−0
- c-sources/LogicGrowsOnTrees-MPI.c +50/−0
- c-sources/LogicGrowsOnTrees-MPI.h +12/−0
- sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs +463/−0
- tests/test-nqueens.hs +33/−0
- tests/test-trivial.hs +30/−0
+ LICENSE view
@@ -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.
+ LogicGrowsOnTrees-MPI.cabal view
@@ -0,0 +1,106 @@+Name: LogicGrowsOnTrees-MPI+Version: 1.0.0+License: BSD3+License-file: LICENSE+Author: Gregory Crosswhite+Maintainer: Gregory Crosswhite <gcrosswhite@gmail.com>+Synopsis: an adapter for LogicGrowsOnTrees that uses MPI+Cabal-version: >=1.8+Build-type: Simple+Category: Control, Distributed Computing, Logic, Parallelism+Description:+ <http://gcross.github.io/LogicGrowsOnTrees-MPI IF YOU ARE READING THIS ON HACKAGE then click here to browse the package reference documentation.>+ (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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ c-sources/LogicGrowsOnTrees-MPI.c view
@@ -0,0 +1,50 @@+#include <mpi.h>+#include <stdlib.h>++#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;+ }+}}}
+ c-sources/LogicGrowsOnTrees-MPI.h view
@@ -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
+ sources/LogicGrowsOnTrees/Parallel/Adapter/MPI.hs view
@@ -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
+ tests/test-nqueens.hs view
@@ -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
+ tests/test-trivial.hs view
@@ -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 ++ "."