diff --git a/LogicGrowsOnTrees-network.cabal b/LogicGrowsOnTrees-network.cabal --- a/LogicGrowsOnTrees-network.cabal +++ b/LogicGrowsOnTrees-network.cabal @@ -1,5 +1,5 @@ Name: LogicGrowsOnTrees-network -Version: 1.0.0.0.1 +Version: 1.0.0.1 License: BSD3 License-file: LICENSE Author: Gregory Crosswhite @@ -22,19 +22,19 @@ Source-Repository this Type: git Location: git://github.com/gcross/LogicGrowsOnTrees-network.git - Tag: 1.0.0.0.1 + Tag: 1.0.0.1 Library Build-depends: - LogicGrowsOnTrees == 1.0.*, + LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5, - cereal >= 0.3.5 && < 0.3.6, + cereal >= 0.3 && < 0.5, cmdtheline >= 0.2.2 && < 0.3, composition >= 1.0.1 && < 1.1, containers >= 0.4 && < 0.6, hslogger == 1.2.*, hslogger-template == 2.0.*, - lens >= 3.8.5 && < 3.10, + lens >= 3.8.5 && < 3.11, MonadCatchIO-transformers == 0.3.*, mtl >= 2.1.2 && < 2.2, network >= 2.3 && < 2.5, @@ -59,7 +59,7 @@ Hs-source-dirs: examples Build-depends: LogicGrowsOnTrees-network, - LogicGrowsOnTrees == 1.0.*, + LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5, cmdtheline == 0.2.* if flag(examples) @@ -69,13 +69,29 @@ if flag(warnings) GHC-Options: -Wall -fno-warn-name-shadowing +Executable count-all-trivial-tree-leaves + Main-is: count-all-trivial-tree-leaves.hs + Hs-source-dirs: examples + Build-depends: + LogicGrowsOnTrees-network, + LogicGrowsOnTrees >= 1.0 && < 1.2, + base > 4 && < 5, + cereal >= 0.3 && < 0.5, + cmdtheline == 0.2.* + if flag(examples) + Buildable: True + else + Buildable: False + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + Test-Suite tests Type: exitcode-stdio-1.0 Main-is: tests.hs Hs-source-dirs: tests Build-depends: LogicGrowsOnTrees-network, - LogicGrowsOnTrees == 1.0.*, + LogicGrowsOnTrees >= 1.0 && < 1.2, base > 4 && < 5, hslogger == 1.2.*, hslogger-template == 2.0.*, 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.Network +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/Network.hs b/sources/LogicGrowsOnTrees/Parallel/Adapter/Network.hs --- a/sources/LogicGrowsOnTrees/Parallel/Adapter/Network.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Adapter/Network.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -21,10 +24,9 @@ ( -- * Driver driver - , driverNetwork -- * Network - , Network(..) - , runNetwork + , Network() + , withNetwork -- * Controller , NetworkRequestQueueMonad(..) , NetworkControllerMonad @@ -32,6 +34,8 @@ , fork , getCurrentProgressAsync , getCurrentProgress + , getCurrentStatisticsAsync + , getCurrentStatistics , getNumberOfWorkersAsync , getNumberOfWorkers , requestProgressUpdateAsync @@ -87,7 +91,7 @@ import System.Console.CmdTheLine import System.IO (Handle) import qualified System.Log.Logger as Logger -import System.Log.Logger (Priority(DEBUG,INFO)) +import System.Log.Logger (Priority(DEBUG,INFO,NOTICE)) import System.Log.Logger.TH import Text.PrettyPrint (text) @@ -96,7 +100,14 @@ import LogicGrowsOnTrees.Parallel.Common.Message import qualified LogicGrowsOnTrees.Parallel.Common.Process as Process import LogicGrowsOnTrees.Parallel.Common.RequestQueue -import LogicGrowsOnTrees.Parallel.Common.Supervisor hiding (runSupervisor,getCurrentProgress,getNumberOfWorkers,setWorkloadBufferSize) +import LogicGrowsOnTrees.Parallel.Common.Supervisor + hiding + (runSupervisor + ,getCurrentProgress + ,getCurrentStatistics + ,getNumberOfWorkers + ,setWorkloadBufferSize + ) import LogicGrowsOnTrees.Parallel.ExplorationMode import LogicGrowsOnTrees.Parallel.Main import LogicGrowsOnTrees.Parallel.Purity @@ -106,24 +117,26 @@ ----------------------------------- Loggers ------------------------------------ -------------------------------------------------------------------------------- -deriveLoggers "Logger" [DEBUG,INFO] +deriveLoggers "Logger" [DEBUG,INFO,NOTICE] -------------------------------------------------------------------------------- ----------------------------------- Network ------------------------------------ -------------------------------------------------------------------------------- -{-| This monad exists due to the quirk that on Windows one needs to initialize - the network system before using it via. 'withSocketsDo'; to ensure that this - happens, all computations that use the network are run in the 'Network' - monad which itself is then run using the 'runNetwork' function that is - equivalent to calling 'withSocketsDo'. +data NetworkSecret = NetworkSecret {- This is *not* meant to be exported. -} + +{-| This constraint exists due to the quirk that on Windows one needs to + initialize the network system before using it via. 'withSocketsDo'; to + ensure that this happens, all computations that use the network have the + 'Network' constrant and must be run by calling 'withNetwork'. -} -newtype Network α = Network { unsafeRunNetwork :: IO α } - deriving (Applicative,Functor,Monad,MonadIO) +type Network = ?network_secret :: NetworkSecret {-| Initializes the network subsystem where required (e.g., on Windows). -} -runNetwork :: Network α → IO α -runNetwork = withSocketsDo . unsafeRunNetwork +withNetwork :: (Network ⇒ IO α) → IO α +withNetwork action = + let ?network_secret = NetworkSecret + in withSocketsDo action -------------------------------------------------------------------------------- ---------------------------- Mostly internal types ----------------------------- @@ -177,13 +190,11 @@ type ExplorationModeFor (NetworkControllerMonad exploration_mode) = exploration_mode instance NetworkRequestQueueMonad (NetworkControllerMonad result) where - disconnectWorker worker_id = C $ ask >>= (enqueueRequest $ + disconnectWorker worker_id = C $ ask >>= (enqueueRequest $ do debugM ("Disconnecting worker " ++ show worker_id) - >> - Map.lookup worker_id <$> use workers - >>= - maybe (pending_add %= Set.delete worker_id) - (liftIO . flip send QuitWorker . workerHandle) + Map.lookup worker_id <$> use workers >>= + maybe (pending_add %= Set.delete worker_id) + (liftIO . flip send QuitWorker . workerHandle) ) -------------------------------------------------------------------------------- @@ -268,6 +279,7 @@ ∀ exploration_mode. ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode) + , Network ) ⇒ ExplorationMode exploration_mode {-^ the exploration mode -} → (Handle → IO ()) {-^ an action that writes any information needed by the worker to the given handle -} → @@ -275,7 +287,7 @@ PortID {-^ the port id on which to listen for connections -} → ProgressFor exploration_mode {-^ the initial progress of the run -} → NetworkControllerMonad exploration_mode () {-^ the controller of the supervisor -} → - Network (RunOutcomeFor exploration_mode) {-^ the outcome of the run -} + IO (RunOutcomeFor exploration_mode) {-^ the outcome of the run -} runSupervisor exploration_mode initializeWorker @@ -283,7 +295,7 @@ port_id starting_progress (C controller) - = liftIO $ do + = do request_queue ← newRequestQueue let receiveStolenWorkloadFromWorker = flip enqueueRequest request_queue .* receiveStolenWorkload @@ -304,7 +316,7 @@ pending_quit %= Set.delete worker_id workers %= Map.delete worker_id removeWorkerIfPresent worker_id - liftIO $ notifyDisconnected worker_id + liftIO $ notifyDisconnected_ worker_id sendMessageToWorker message worker_id = do use workers @@ -331,6 +343,10 @@ infoM $ "Activating worker " ++ show worker_id ++ " with workload " ++ show workload sendMessageToWorker (StartWorkload workload) worker_id + notifyDisconnected_ worker_id@WorkerId{..} = do + noticeM $ "Worker " ++ workerHostName ++ ":" ++ show workerPortNumber ++ " has disconnected" + notifyDisconnected worker_id + let port_id_description = showPortID port_id supervisor_thread_id ← myThreadId acceptor_thread_id ← forkIO $ @@ -349,6 +365,7 @@ if allowed_to_connect then do debugM $ identifier ++ " is allowed to connect." + noticeM $ "Received connection from " ++ identifier initializeWorker workerHandle workerThreadId ← forkIO ( receiveAndProcessMessagesFromWorkerUsingHandle @@ -361,7 +378,7 @@ Just UserInterrupt → sendToWorker QuitWorker _ → do enqueueRequest (removeWorker worker_id) request_queue sendToWorker QuitWorker `catch` (\(_::SomeException) → return ()) - liftIO $ notifyDisconnected worker_id + liftIO $ notifyDisconnected_ worker_id ) ) flip enqueueRequest request_queue $ do @@ -372,6 +389,7 @@ addWorker worker_id else do debugM $ identifier ++ " is *not* allowed to connect." + noticeM $ "Rejected connections from " ++ identifier sendToWorker QuitWorker ) `catch` @@ -391,6 +409,7 @@ liftIO $ killThread acceptor_thread_id killControllerThreads request_queue return $ extractRunOutcomeFromSupervisorOutcome supervisor_outcome +{-# INLINE runSupervisor #-} {-| Explores the given tree using multiple processes to achieve parallelism. @@ -407,6 +426,7 @@ ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode) + , Network ) ⇒ (shared_configuration → ExplorationMode exploration_mode) {-^ a function that constructs the exploration mode given the shared @@ -436,7 +456,7 @@ {-^ a function that constructs the controller for the supervisor (called only on the supervisor) -} → - Network (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' @@ -474,21 +494,24 @@ handle handle return Nothing +{-# INLINE runExplorer #-} {-| Runs a worker that connects to the supervisor via. the given address and port id. -} runWorker :: ( Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode) + , Network ) ⇒ 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 -} → HostName {-^ the address of the supervisor -} → PortID {-^ the port id on which the supervisor is listening -} → - Network () + IO () runWorker exploration_mode purity tree host_name port_id = liftIO $ do handle ← connectTo host_name port_id Process.runWorkerUsingHandles exploration_mode purity tree handle handle +{-# INLINE runWorker #-} -------------------------------------------------------------------------------- ------------------------------- Utility funtions ------------------------------- @@ -509,6 +532,7 @@ [(supervisorConfigurationTermFor shared_configuration_term supervisor_configuration_term,defTI { termName = "supervisor" , termDoc = "Run the program in supervisor mode, waiting for network connections from workers on the specified port." + , man = mainMan } ) ,(worker_configuration_term,defTI @@ -554,20 +578,23 @@ ) ⇒ Driver IO shared_configuration supervisor_configuration m n exploration_mode driver = - case (driverNetwork :: Driver Network shared_configuration supervisor_configuration m n exploration_mode) of - Driver runDriver → Driver (runNetwork . runDriver) + let ?network_secret = NetworkSecret + in case (driverNetwork :: Driver IO shared_configuration supervisor_configuration m n exploration_mode) of + Driver runDriver → Driver runDriver +{-# INLINE driver #-} -{-| This is the same as 'driver', but runs in the 'Network' monad. Use this - driver if you want to do other things with the network (such as starting - a subseqent parallel exploration) after the run completes. +{-| This is the same as 'driver', but it has the 'Network' constraint. Use this + driver if you want to do other things with the network (such as starting a + subseqent parallel exploration) after the run completes. -} driverNetwork :: ∀ shared_configuration supervisor_configuration m n exploration_mode. ( Serialize shared_configuration , Serialize (ProgressFor exploration_mode) , Serialize (WorkerFinishedProgressFor exploration_mode) + , Network ) ⇒ - Driver Network shared_configuration supervisor_configuration m n exploration_mode + Driver IO shared_configuration supervisor_configuration m n exploration_mode driverNetwork = Driver $ \DriverParameters{..} → do runExplorer constructExplorationMode @@ -579,6 +606,7 @@ constructController >>= maybe (return ()) (liftIO . (notifyTerminated <$> fst . fst <*> snd . fst <*> snd)) +{-# INLINE driverNetwork #-} -------------------------------------------------------------------------------- ----------------------------------- Internal ----------------------------------- diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,7 +1,7 @@ -- Language extensions {{{ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE ViewPatterns #-} @@ -22,8 +22,7 @@ import Network (PortID(..)) -import qualified System.Log.Logger as Logger -import System.Log.Logger (Priority(DEBUG,INFO),rootLoggerName,setLevel,updateGlobalLogger) +import System.Log.Logger (Priority(DEBUG),rootLoggerName,setLevel,updateGlobalLogger) import System.Log.Logger.TH import System.Random (randomRIO) @@ -39,10 +38,6 @@ import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) -- }}} --- Logging Functions {{{ -deriveLoggers "Logger" [DEBUG,INFO] --- }}} - -- Helper Functions {{{ remdups :: (Eq a) => [a] -> [a] -- {{{ remdups [] = [] @@ -53,10 +48,11 @@ -- }}} -- }}} -main = do +main = withNetwork $ do -- updateGlobalLogger rootLoggerName (setLevel DEBUG) defaultMain tests +tests :: Network ⇒ [Test] tests = -- {{{ [testCase "one process" . runTest $ \changeNumberOfWorkers → do changeNumberOfWorkers (const 0) @@ -68,7 +64,7 @@ 1 → changeNumberOfWorkers (+1) ] where - runTest generateNoise = do + runTest generateNoise = withNetwork $ do let tree = nqueensCount 15 port_id = PortNumber 54210 progresses_ref ← newIORef [] @@ -83,8 +79,6 @@ replicateM_ (new_number_of_workers-old_number_of_workers) . forkIO - . - unsafeRunNetwork $ runWorker AllMode @@ -112,7 +106,6 @@ return True notifyDisconnected _ = return () RunOutcome _ termination_reason ← - unsafeRunNetwork $ runSupervisor AllMode (const $ return ())