diff --git a/LogicGrowsOnTrees.cabal b/LogicGrowsOnTrees.cabal --- a/LogicGrowsOnTrees.cabal +++ b/LogicGrowsOnTrees.cabal @@ -1,5 +1,5 @@ Name: LogicGrowsOnTrees -Version: 1.0.0.0.1 +Version: 1.1 License: BSD3 License-file: LICENSE Author: Gregory Crosswhite @@ -210,7 +210,7 @@ Source-Repository this Type: git Location: git://github.com/gcross/LogicGrowsOnTrees.git - Tag: 1.0.0.0.1 + Tag: 1.1 Library Build-depends: @@ -218,7 +218,7 @@ AbortT-mtl == 1.0.*, base > 4 && < 5, bytestring >= 0.9 && < 0.11, - cereal == 0.3.*, + cereal >= 0.3 && < 0.5, cmdtheline == 0.2.*, composition >= 0.2 && < 1.1, containers >= 0.4 && < 0.6, @@ -227,16 +227,18 @@ directory >= 1.1 && < 1.3, hslogger == 1.2.*, hslogger-template == 2.0.*, - lens >= 3.8 && < 3.10, + lens >= 3.8 && < 3.11, MonadCatchIO-transformers == 0.3.*, monoid-statistics == 0.3.*, mtl == 2.1.*, multiset == 0.2.*, + old-locale == 1.0.*, operational == 0.2.*, prefix-units == 0.1.*, pretty == 1.1.*, PSQueue == 1.1.*, sequential-index == 0.2.*, + split == 0.2.*, stm >= 2.3 && < 2.5, time == 1.4.*, transformers >= 0.2 && < 0.4, @@ -414,7 +416,7 @@ Build-depends: LogicGrowsOnTrees, base > 4 && < 5, - cereal == 0.3.*, + cereal >= 0.3 && < 0.5, cmdtheline == 0.2.* if flag(examples) Buildable: True @@ -615,6 +617,39 @@ else GHC-Options: -threaded +Benchmark tree-versus-list-lopsided-trivial-tree + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-lopsided-trivial-tree.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-lopsided-null-tree + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-lopsided-null-tree.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-null-tree + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-null-tree.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + Benchmark tree-versus-list-trivial-tree Type: exitcode-stdio-1.0 Main-is: tree-versus-list-trivial-tree.hs @@ -626,6 +661,19 @@ if flag(warnings) GHC-Options: -Wall -fno-warn-name-shadowing +Benchmark tree-versus-list-unit-tree + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-unit-tree.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + cereal == 0.4.*, + criterion >= 0.6 && < 0.9, + deepseq == 1.3.* + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + Benchmark tree-versus-list-nqueens Type: exitcode-stdio-1.0 Main-is: tree-versus-list-nqueens.hs @@ -637,6 +685,83 @@ if flag(warnings) GHC-Options: -Wall -fno-warn-name-shadowing +Benchmark tree-versus-list-nqueens-using-sets + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-nqueens-using-sets.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-nqueens-using-bits + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-nqueens-using-bits.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-nqueens-with-list-at-bottom + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-nqueens-with-list-at-bottom.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-nqueens-with-nothing-at-bottom + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-nqueens-with-nothing-at-bottom.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-bind + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-bind.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-bind-and-mplus + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-bind-and-mplus.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + +Benchmark tree-versus-list-fmap + Type: exitcode-stdio-1.0 + Main-is: tree-versus-list-fmap.hs + Hs-source-dirs: benchmarks + Build-depends: + LogicGrowsOnTrees, + base > 4 && < 5, + criterion >= 0.6 && < 0.9 + if flag(warnings) + GHC-Options: -Wall -fno-warn-name-shadowing + Test-Suite tests Type: exitcode-stdio-1.0 Main-is: tests.hs @@ -645,7 +770,7 @@ LogicGrowsOnTrees, base > 4 && < 5, bytestring >= 0.9 && < 0.11, - cereal == 0.3.*, + cereal >= 0.3 && < 0.5, composition >= 0.2 && < 1.1, containers >= 0.4 && < 0.6, data-ivar == 0.30.*, @@ -653,19 +778,21 @@ hslogger == 1.2.*, hslogger-template == 2.0.*, HUnit == 1.2.*, - lens >= 3.8 && < 3.10, + lens >= 3.8 && < 3.11, + MonadCatchIO-transformers == 0.3.*, operational == 0.2.*, random == 1.0.*, QuickCheck >= 2.4 && < 2.7, quickcheck-instances >= 0.3.1 && < 0.4, - smallcheck == 1.0.*, + smallcheck >= 1.0 && < 1.2, stm >= 2.3 && < 2.5, test-framework >= 0.6 && < 0.9, test-framework-hunit >= 0.2 && < 0.4, test-framework-quickcheck2 >= 0.2 && < 0.4, test-framework-smallcheck == 0.2.*, + time == 1.4.*, transformers >= 0.2 && < 0.4, - uuid == 1.2.*, + uuid >= 1.2 && < 1.4, void == 0.6.* if flag(warnings) GHC-Options: -Wall -fno-warn-name-shadowing -with-rtsopts=-M256M diff --git a/benchmarks/tree-versus-list-bind-and-mplus.hs b/benchmarks/tree-versus-list-bind-and-mplus.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-bind-and-mplus.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +bindAndPlusIt :: MonadPlus m ⇒ Int → m WordSum +bindAndPlusIt (-1) = mzero +bindAndPlusIt 0 = return (WordSum 1) +bindAndPlusIt depth = (return (depth-1) >>= bindAndPlusIt) `mplus` (return (depth-2) >>= bindAndPlusIt) +{-# NOINLINE bindAndPlusIt #-} + +main = defaultMain + [bench "list" $ nf (getWordSum . mconcat . bindAndPlusIt) depth + ,bench "tree"$ nf (getWordSum . exploreTree . bindAndPlusIt) depth + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . bindAndPlusIt) depth + ,bench "tree using worker" $ doWorker bindAndPlusIt depth + ] + where + depth = 20 + + doWorker lopsidedTree depth = exploreTreeGeneric AllMode Pure (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-bind.hs b/benchmarks/tree-versus-list-bind.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-bind.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +unitBindIt :: Monad m ⇒ Int → m WordSum +unitBindIt 0 = return (WordSum 1) +unitBindIt depth = return () >> unitBindIt (depth-1) +{-# NOINLINE unitBindIt #-} + +intBindIt :: Monad m ⇒ Int → m WordSum +intBindIt 0 = return (WordSum 1) +intBindIt depth = return (depth-1) >>= intBindIt +{-# NOINLINE intBindIt #-} + +main = defaultMain + [bgroup "list" + [bench "unit" $ nf (getWordSum . mconcat . unitBindIt) depth + ,bench "int" $ nf (getWordSum . mconcat . intBindIt) depth + ] + ,bgroup "tree" + [bench "unit" $ nf (getWordSum . exploreTree . unitBindIt) depth + ,bench "int" $ nf (getWordSum . exploreTree . intBindIt) depth + ] + ,bgroup "tree w/ checkpointing" + [bench "unit" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . unitBindIt) depth + ,bench "int" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . intBindIt) depth + ] + ,bgroup "tree using worker" + [bench "unit" $ doWorker unitBindIt depth + ,bench "int" $ doWorker intBindIt depth + ] + ] + where + depth = 16384 + + doWorker lopsidedTree depth = exploreTreeGeneric AllMode Pure (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-fmap.hs b/benchmarks/tree-versus-list-fmap.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-fmap.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +bindAndPlusIt :: (Functor m, MonadPlus m) ⇒ Int → m WordSum +bindAndPlusIt (-1) = mzero +bindAndPlusIt 0 = return (WordSum 1) +bindAndPlusIt depth = fmap (\(WordSum x) → WordSum (x+1)) $ bindAndPlusIt (depth-1) `mplus` bindAndPlusIt (depth-2) +{-# NOINLINE bindAndPlusIt #-} + +main = defaultMain + [bench "list" $ nf (getWordSum . mconcat . bindAndPlusIt) depth + ,bench "tree"$ nf (getWordSum . exploreTree . bindAndPlusIt) depth + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . bindAndPlusIt) depth + ,bench "tree using worker" $ doWorker bindAndPlusIt depth + ] + where + depth = 20 + + doWorker lopsidedTree depth = exploreTreeGeneric AllMode Pure (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-lopsided-null-tree.hs b/benchmarks/tree-versus-list-lopsided-null-tree.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-lopsided-null-tree.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +leftLopsidedTree :: MonadPlus m ⇒ Word → m WordSum +leftLopsidedTree depth + | depth == 0 = mzero + | otherwise = leftLopsidedTree (depth-1) `mplus` mzero +{-# NOINLINE leftLopsidedTree #-} + +rightLopsidedTree :: MonadPlus m ⇒ Word → m WordSum +rightLopsidedTree depth + | depth == 0 = mzero + | otherwise = mzero `mplus` rightLopsidedTree (depth-1) +{-# NOINLINE rightLopsidedTree #-} + +main = defaultMain + [bgroup "list" + [bench "left" $ nf (getWordSum . mconcat . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . mconcat . rightLopsidedTree) depth + ] + ,bgroup "tree" + [bench "left" $ nf (getWordSum . exploreTree . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . exploreTree . rightLopsidedTree) depth + ] + ,bgroup "tree w/ checkpointing" + [bench "left" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . rightLopsidedTree) depth + ] + ,bgroup "tree using worker" + [bench "left" $ doWorker leftLopsidedTree depth + ,bench "right" $ doWorker rightLopsidedTree depth + ] + ] + where + depth = 4096 + + doWorker lopsidedTree depth = exploreTreeGeneric AllMode Pure (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-lopsided-trivial-tree.hs b/benchmarks/tree-versus-list-lopsided-trivial-tree.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-lopsided-trivial-tree.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +leftLopsidedTree :: MonadPlus m ⇒ Word → m WordSum +leftLopsidedTree depth + | depth == 0 = mzero + | otherwise = leftLopsidedTree (depth-1) `mplus` return (WordSum 1) +{-# NOINLINE leftLopsidedTree #-} + +rightLopsidedTree :: MonadPlus m ⇒ Word → m WordSum +rightLopsidedTree depth + | depth == 0 = mzero + | otherwise = return (WordSum 1) `mplus` rightLopsidedTree (depth-1) +{-# NOINLINE rightLopsidedTree #-} + +main = defaultMain + [bgroup "list" + [bench "left" $ nf (getWordSum . mconcat . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . mconcat . rightLopsidedTree) depth + ] + ,bgroup "tree" + [bench "left" $ nf (getWordSum . exploreTree . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . exploreTree . rightLopsidedTree) depth + ] + ,bgroup "tree w/ checkpointing" + [bench "left" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . leftLopsidedTree) depth + ,bench "right" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . rightLopsidedTree) depth + ] + ,bgroup "tree using worker" + [bench "left" $ doWorker leftLopsidedTree depth + ,bench "right" $ doWorker rightLopsidedTree depth + ] + ,bgroup "tree using single thread (direct)" + [bench "left" $ doThreadDirect leftLopsidedTree depth + ,bench "right" $ doThreadDirect rightLopsidedTree depth + ] + ,bgroup "tree using single thread (main)" + [bench "left" $ doThreadMain leftLopsidedTree depth + ,bench "right" $ doThreadMain leftLopsidedTree depth + ] + ] + where + depth = 4096 + + doWorker lopsidedTree depth = exploreTreeGeneric AllMode Pure (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} + + doThreadDirect lopsidedTree depth = Threads.exploreTree (setNumberOfWorkers 1) (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doThreadDirect #-} + + doThreadMain lopsidedTree depth = + withArgs ["-n1"] $ + simpleMainForExploreTree + Threads.driver + (const $ return ()) + (lopsidedTree depth :: Tree WordSum) + {-# NOINLINE doThreadMain #-} diff --git a/benchmarks/tree-versus-list-nqueens-using-bits.hs b/benchmarks/tree-versus-list-nqueens-using-bits.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-nqueens-using-bits.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Criterion.Main +import Data.Monoid + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Examples.Queens +import LogicGrowsOnTrees.Utils.WordSum +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +main = defaultMain + [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensUsingBitsCount) n + ,bench "tree" $ nf (getWordSum . exploreTree . nqueensUsingBitsCount) n + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensUsingBitsCount) n + ,bench "tree using worker" $ doWorker n + ] + where + n = 11 + + -- This needs to be here because otherwise nqueensUsingBitsCount n only gets + -- evaluated once, which distorts the benchmark. + doWorker n = exploreTreeGeneric AllMode Pure (nqueensUsingBitsCount n) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-nqueens-using-sets.hs b/benchmarks/tree-versus-list-nqueens-using-sets.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-nqueens-using-sets.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Criterion.Main +import Data.Monoid + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Examples.Queens +import LogicGrowsOnTrees.Utils.WordSum +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +main = defaultMain + [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensUsingSetsCount) n + ,bench "tree" $ nf (getWordSum . exploreTree . nqueensUsingSetsCount) n + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensUsingSetsCount) n + ,bench "tree using worker" $ doWorker n + ] + where + n = 11 + + -- This needs to be here because otherwise nqueensUsingSetsCount n only gets + -- evaluated once, which distorts the benchmark. + doWorker n = exploreTreeGeneric AllMode Pure (nqueensUsingSetsCount n) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-nqueens-with-list-at-bottom.hs b/benchmarks/tree-versus-list-nqueens-with-list-at-bottom.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-nqueens-with-list-at-bottom.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Criterion.Main +import Data.Monoid + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Examples.Queens +import LogicGrowsOnTrees.Utils.WordSum +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +main = defaultMain + [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensWithListAtBottomCount) n + ,bench "tree" $ nf (getWordSum . exploreTree . nqueensWithListAtBottomCount) n + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensWithListAtBottomCount) n + ,bench "tree using worker" $ doWorker n + ] + where + n = 12 + + -- This needs to be here because otherwise nqueensWithListAtBottomCount n + -- only gets evaluated once, which distorts the benchmark. + doWorker n = exploreTreeGeneric AllMode Pure (nqueensWithListAtBottomCount n) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-nqueens-with-nothing-at-bottom.hs b/benchmarks/tree-versus-list-nqueens-with-nothing-at-bottom.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-nqueens-with-nothing-at-bottom.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Criterion.Main +import Data.Monoid + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Examples.Queens +import LogicGrowsOnTrees.Utils.WordSum +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +main = defaultMain + [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensWithNothingAtBottomCount) n + ,bench "tree" $ nf (getWordSum . exploreTree . nqueensWithNothingAtBottomCount) n + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensWithNothingAtBottomCount) n + ,bench "tree using worker" $ doWorker n + ] + where + n = 12 + + -- This needs to be here because otherwise nqueensWithNothingAtBottomCount n + -- only gets evaluated once, which distorts the benchmark. + doWorker n = exploreTreeGeneric AllMode Pure (nqueensWithNothingAtBottomCount n) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-nqueens.hs b/benchmarks/tree-versus-list-nqueens.hs --- a/benchmarks/tree-versus-list-nqueens.hs +++ b/benchmarks/tree-versus-list-nqueens.hs @@ -15,6 +15,12 @@ [bench "list of Sum" $ nf (getWordSum . mconcat . nqueensCount) n ,bench "tree" $ nf (getWordSum . exploreTree . nqueensCount) n ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nqueensCount) n - ,bench "tree using worker" $ exploreTreeGeneric AllMode Pure (nqueensCount n) + ,bench "tree using worker" $ doWorker n ] - where n = 13 + where + n = 13 + + -- This needs to be here because otherwise nqueensCount n only gets + -- evaluated once, which distorts the benchmark. + doWorker n = exploreTreeGeneric AllMode Pure (nqueensCount n) + {-# NOINLINE doWorker #-} diff --git a/benchmarks/tree-versus-list-null-tree.hs b/benchmarks/tree-versus-list-null-tree.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-null-tree.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Control.Monad +import Criterion.Main +import Data.List (genericReplicate) +import Data.Monoid +import Data.Word +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +nullPerfectTree :: MonadPlus m ⇒ Word → m WordSum +nullPerfectTree depth + | depth == 0 = mzero + | otherwise = nullPerfectTree (depth-1) `mplus` nullPerfectTree (depth-1) +{-# NOINLINE nullPerfectTree #-} + +main = defaultMain + [bench "list" $ nf (getWordSum . mconcat . nullPerfectTree) depth + ,bench "tree" $ nf (getWordSum . exploreTree . nullPerfectTree) depth + ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . nullPerfectTree) depth + ,bench "tree using worker" $ doWorker depth + ,bench "tree using single thread (direct)" $ doThreadDirect depth + ,bench "tree using single thread (main)" $ doThreadMain depth + ] + where + depth = 15 + + -- These need to be here because otherwise nullPerfectTree depth only gets + -- evaluated once, which distorts the benchmark. + + doWorker depth = exploreTreeGeneric AllMode Pure (nullPerfectTree depth :: Tree WordSum) + {-# NOINLINE doWorker #-} + + doThreadDirect depth = Threads.exploreTree (setNumberOfWorkers 1) (nullPerfectTree depth :: Tree WordSum) + {-# NOINLINE doThreadDirect #-} + + doThreadMain depth = + withArgs ["-n1"] $ + simpleMainForExploreTree + Threads.driver + (const $ return ()) + (nullPerfectTree depth :: Tree WordSum) + {-# NOINLINE doThreadMain #-} + diff --git a/benchmarks/tree-versus-list-trivial-tree.hs b/benchmarks/tree-versus-list-trivial-tree.hs --- a/benchmarks/tree-versus-list-trivial-tree.hs +++ b/benchmarks/tree-versus-list-trivial-tree.hs @@ -2,13 +2,17 @@ import Criterion.Main import Data.Monoid +import System.Environment import LogicGrowsOnTrees import LogicGrowsOnTrees.Checkpoint import LogicGrowsOnTrees.Utils.PerfectTree import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) main = defaultMain @@ -16,5 +20,12 @@ ,bench "tree" $ nf (getWordSum . exploreTree . trivialPerfectTree 2) depth ,bench "tree w/ checkpointing" $ nf (getWordSum . exploreTreeStartingFromCheckpoint Unexplored . trivialPerfectTree 2) depth ,bench "tree using worker" $ exploreTreeGeneric AllMode Pure (trivialPerfectTree 2 depth) + ,bench "tree using single thread (direct)" $ Threads.exploreTree (setNumberOfWorkers 1) (trivialPerfectTree 2 depth) + ,bench "tree using single thread (main)" $ + withArgs ["-n1"] $ + simpleMainForExploreTree + Threads.driver + (const $ return ()) + (trivialPerfectTree 2 depth) ] where depth = 15 diff --git a/benchmarks/tree-versus-list-unit-tree.hs b/benchmarks/tree-versus-list-unit-tree.hs new file mode 100644 --- /dev/null +++ b/benchmarks/tree-versus-list-unit-tree.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE UnicodeSyntax #-} + +import Criterion.Main +import Control.DeepSeq +import Data.Monoid +import Data.Serialize +import System.Environment + +import LogicGrowsOnTrees +import LogicGrowsOnTrees.Checkpoint +import LogicGrowsOnTrees.Utils.PerfectTree +import LogicGrowsOnTrees.Utils.WordSum +import qualified LogicGrowsOnTrees.Parallel.Adapter.Threads as Threads +import LogicGrowsOnTrees.Parallel.Adapter.Threads (setNumberOfWorkers) +import LogicGrowsOnTrees.Parallel.Common.Worker (exploreTreeGeneric) +import LogicGrowsOnTrees.Parallel.ExplorationMode (ExplorationMode(AllMode)) +import LogicGrowsOnTrees.Parallel.Main +import LogicGrowsOnTrees.Parallel.Purity (Purity(Pure)) + +makeTree x = perfectTree x 2 15 + +-- We need to define our own version of () because the mconcat method for () +-- completely ignores the argument list and so bypasses the cost of adding the +-- ()'s up. +data MyUnit = MyUnit + +instance Serialize MyUnit where + put _ = put () + get = return MyUnit + +instance Monoid MyUnit where + mempty = MyUnit + mappend x y = x `seq` y `seq` MyUnit + mconcat [] = MyUnit + mconcat (x:xs) = x `seq` mconcat xs + +instance NFData MyUnit where + rnf x = x `seq` () + +main = defaultMain + [bench "list" $ nf (mconcat . makeTree) MyUnit + ,bench "tree" $ nf (exploreTree . makeTree) MyUnit + ,bench "tree w/ checkpointing" $ nf (exploreTreeStartingFromCheckpoint Unexplored . makeTree) MyUnit + ,bench "tree using worker" $ exploreTreeGeneric AllMode Pure (makeTree MyUnit) + ,bench "tree using single thread (direct)" $ Threads.exploreTree (setNumberOfWorkers 1) (makeTree MyUnit) + ,bench "tree using single thread (main)" $ + withArgs ["-n1"] $ + simpleMainForExploreTree + Threads.driver + (const $ return ()) + (makeTree MyUnit) + ] diff --git a/c-sources/queens.c b/c-sources/queens.c --- a/c-sources/queens.c +++ b/c-sources/queens.c @@ -13,7 +13,7 @@ void (*popValue)(), void (*finalizeValue)() ) { - if(occupied_rows & 1 != 0) { + if(occupied_rows & 1) { return LogicGrowsOnTrees_Queens_count_solutions( size, @@ -34,7 +34,7 @@ column = 0; uint64_t blocked = occupied_columns | occupied_negative_diagonals | occupied_positive_diagonals; for(column = 0; column < size; ++column, column_bit <<= 1) { - if((column_bit & blocked) == 0) { + if(!(column_bit & blocked)) { #ifdef __GNUC__ if(__builtin_expect(pushValue != NULL,0)) { #else diff --git a/sources/LogicGrowsOnTrees/Checkpoint.hs b/sources/LogicGrowsOnTrees/Checkpoint.hs --- a/sources/LogicGrowsOnTrees/Checkpoint.hs +++ b/sources/LogicGrowsOnTrees/Checkpoint.hs @@ -34,6 +34,7 @@ , checkpointFromContext , checkpointFromCursor , checkpointFromExplorationState + , checkpointFromReversedList , checkpointFromSequence , checkpointFromInitialPath , checkpointFromUnexploredPath @@ -71,7 +72,7 @@ import Data.DeriveTH import Data.Functor.Identity (Identity,runIdentity) import Data.Monoid ((<>),Monoid(..)) -import Data.Sequence ((|>),Seq,viewr,ViewR(..)) +import Data.Sequence (Seq,viewr,ViewR(..)) import qualified Data.Sequence as Seq import Data.Serialize import Data.Typeable (Typeable) @@ -193,7 +194,7 @@ {-| Like 'CheckpointCursor', but each step keeps track of the subtree for the alternative branch in case we backtrack to it. -} -type Context m α = Seq (ContextStep m α) +type Context m α = [ContextStep m α] {-| Like 'CheckpointDifferential', but left branches include the subtree for the right branch; the right branches do not need this information because we @@ -227,7 +228,7 @@ {-| Constructs the initial 'ExplorationTState' for the given tree. -} initialExplorationState :: Checkpoint → TreeT m α → ExplorationTState m α -initialExplorationState = ExplorationTState Seq.empty +initialExplorationState = ExplorationTState mempty -------------------------------------------------------------------------------- ----------------------------- Utility functions -------------------------------- @@ -239,7 +240,7 @@ at your current location and the subcheckpoint at your location. -} checkpointFromContext :: Context m α → Checkpoint → Checkpoint -checkpointFromContext = checkpointFromSequence $ +checkpointFromContext = checkpointFromReversedList $ \step → case step of CacheContextStep cache → CachePoint cache LeftBranchContextStep right_checkpoint _ → flip ChoicePoint right_checkpoint @@ -270,20 +271,34 @@ with @Explored@, which both shrinks the size of the checkpoint as well as making it /much/ easier to determine if it is equivalent to 'Explored'. -} +checkpointFromReversedList :: + (α → (Checkpoint → Checkpoint)) → + [α] → + Checkpoint → + Checkpoint +checkpointFromReversedList _ [] = id +checkpointFromReversedList processStep (step:rest) = + checkpointFromReversedList processStep rest + . + simplifyCheckpointRoot + . + processStep step + +{-| The same as 'checkpointFromReversedList', but where the cursor is specified + as a (non-reversed) 'Seq' rather than a list. + -} checkpointFromSequence :: (α → (Checkpoint → Checkpoint)) → Seq α → Checkpoint → Checkpoint -checkpointFromSequence processStep sequence = - case viewr sequence of - EmptyR → id - rest :> step → - checkpointFromSequence processStep rest - . - simplifyCheckpointRoot - . - processStep step +checkpointFromSequence _ (viewr → EmptyR) = id +checkpointFromSequence processStep (viewr → rest :> step) = + checkpointFromSequence processStep rest + . + simplifyCheckpointRoot + . + processStep step {-| Constructs a full checkpoint given the path to where you are currently searching and the subcheckpoint at your location, assuming that we have no @@ -326,7 +341,7 @@ does not contain any information about the branches not taken.) -} pathFromContext :: Context m α → Path -pathFromContext = fmap pathStepFromContextStep +pathFromContext = Seq.fromList . map pathStepFromContextStep . reverse {-| Computes the path to the current location in the checkpoint as given by the cursor. (Note that this is a lossy conversation because the resulting path @@ -413,14 +428,14 @@ (Nothing, moveUpContext) (\x → (Nothing, Just $ ExplorationTState - (context |> CacheContextStep (encode x)) + (CacheContextStep (encode x):context) Unexplored (TreeT . k $ x) )) Choice left right :>>= k → return (Nothing, Just $ ExplorationTState - (context |> LeftBranchContextStep Unexplored (right >>= TreeT . k)) + (LeftBranchContextStep Unexplored (right >>= TreeT . k):context) Unexplored (left >>= TreeT . k) ) @@ -429,7 +444,7 @@ Cache _ :>>= k → return (Nothing, Just $ ExplorationTState - (context |> CacheContextStep cache) + (CacheContextStep cache:context) rest_checkpoint (either error (TreeT . k) . decode $ cache) ) @@ -439,7 +454,7 @@ Choice left right :>>= k → return (Nothing, Just $ ExplorationTState - (context |> LeftBranchContextStep right_checkpoint (right >>= TreeT . k)) + (LeftBranchContextStep right_checkpoint (right >>= TreeT . k):context) left_checkpoint (left >>= TreeT . k) ) @@ -448,15 +463,14 @@ getView = viewT . unwrapTreeT $ tree moveUpContext = go context where - go context = case viewr context of - EmptyR → Nothing - rest_context :> LeftBranchContextStep right_checkpoint right_tree → - Just (ExplorationTState - (rest_context |> RightBranchContextStep) - right_checkpoint - right_tree - ) - rest_context :> _ → go rest_context + go [] = Nothing + go (LeftBranchContextStep right_checkpoint right_tree:rest_context) = + Just (ExplorationTState + (RightBranchContextStep:rest_context) + right_checkpoint + right_tree + ) + go (_:rest_context) = go rest_context {-# INLINE stepThroughTreeTStartingFromCheckpoint #-} -------------------------------------------------------------------------------- @@ -477,6 +491,7 @@ Tree α → α exploreTreeStartingFromCheckpoint = runIdentity .* exploreTreeTStartingFromCheckpoint +{-# INLINE exploreTreeStartingFromCheckpoint #-} {-| Explores the remaining nodes in an impure tree, starting from the given checkpoint, and sums over all the results in the leaves. diff --git a/sources/LogicGrowsOnTrees/Examples/Queens.hs b/sources/LogicGrowsOnTrees/Examples/Queens.hs --- a/sources/LogicGrowsOnTrees/Examples/Queens.hs +++ b/sources/LogicGrowsOnTrees/Examples/Queens.hs @@ -30,6 +30,14 @@ , nqueensGeneric , nqueensSolutions , nqueensCount + -- ** With a list at the bottom (instead of C) + ,nqueensWithListAtBottomGeneric + ,nqueensWithListAtBottomSolutions + ,nqueensWithListAtBottomCount + -- ** With nothing at the bottom (instead of C or a List) + ,nqueensWithNothingAtBottomGeneric + ,nqueensWithNothingAtBottomSolutions + ,nqueensWithNothingAtBottomCount -- * Board size command argument , BoardSize(..) , makeBoardSizeTermAtPosition @@ -52,7 +60,14 @@ import LogicGrowsOnTrees (Tree,allFrom,exploreTree) -- exploreTree added so that haddock will link to it import qualified LogicGrowsOnTrees.Examples.Queens.Advanced as Advanced -import LogicGrowsOnTrees.Examples.Queens.Advanced (NQueensSolution,NQueensSolutions,multiplySolution,nqueensGeneric) +import LogicGrowsOnTrees.Examples.Queens.Advanced + (NQueensSolution + ,NQueensSolutions + ,multiplySolution + ,nqueensGeneric + ,nqueensWithListAtBottomGeneric + ,nqueensWithNothingAtBottomGeneric + ) import LogicGrowsOnTrees.Utils.Word_ import LogicGrowsOnTrees.Utils.WordSum @@ -255,7 +270,7 @@ !value = do column ← allFrom . goGetOpenings 0 $ - occupied_columns .|. + occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals let column_bit = bit (fromIntegral column) @@ -311,4 +326,28 @@ nqueensCount = nqueensGeneric (const id) (\_ symmetry _ → return . WordSum . Advanced.multiplicityForSymmetry $ symmetry) () {-# SPECIALIZE nqueensCount :: Word → [WordSum] #-} {-# SPECIALIZE nqueensCount :: Word → Tree WordSum #-} + +{-| Like 'nqueensSolutions', but uses List at the bottom instead of C. -} +nqueensWithListAtBottomSolutions :: MonadPlus m ⇒ Word → m NQueensSolution +nqueensWithListAtBottomSolutions n = nqueensWithListAtBottomGeneric (++) multiplySolution [] n +{-# SPECIALIZE nqueensWithListAtBottomSolutions :: Word → NQueensSolutions #-} +{-# SPECIALIZE nqueensWithListAtBottomSolutions :: Word → Tree NQueensSolution #-} + +{-| Like 'nqueensCount', but uses List at the bottom instead of C. -} +nqueensWithListAtBottomCount :: MonadPlus m ⇒ Word → m WordSum +nqueensWithListAtBottomCount = nqueensWithListAtBottomGeneric (const id) (\_ symmetry _ → return . WordSum . Advanced.multiplicityForSymmetry $ symmetry) () +{-# SPECIALIZE nqueensWithListAtBottomCount :: Word → [WordSum] #-} +{-# SPECIALIZE nqueensWithListAtBottomCount :: Word → Tree WordSum #-} + +{-| Like 'nqueensSolutions', but uses List at the bottom instead of C. -} +nqueensWithNothingAtBottomSolutions :: MonadPlus m ⇒ Word → m NQueensSolution +nqueensWithNothingAtBottomSolutions n = nqueensWithNothingAtBottomGeneric (++) multiplySolution [] n +{-# SPECIALIZE nqueensWithNothingAtBottomSolutions :: Word → NQueensSolutions #-} +{-# SPECIALIZE nqueensWithNothingAtBottomSolutions :: Word → Tree NQueensSolution #-} + +{-| Like 'nqueensCount', but uses List at the bottom instead of C. -} +nqueensWithNothingAtBottomCount :: MonadPlus m ⇒ Word → m WordSum +nqueensWithNothingAtBottomCount = nqueensWithNothingAtBottomGeneric (const id) (\_ symmetry _ → return . WordSum . Advanced.multiplicityForSymmetry $ symmetry) () +{-# SPECIALIZE nqueensWithNothingAtBottomCount :: Word → [WordSum] #-} +{-# SPECIALIZE nqueensWithNothingAtBottomCount :: Word → Tree WordSum #-} diff --git a/sources/LogicGrowsOnTrees/Examples/Queens/Advanced.hs b/sources/LogicGrowsOnTrees/Examples/Queens/Advanced.hs --- a/sources/LogicGrowsOnTrees/Examples/Queens/Advanced.hs +++ b/sources/LogicGrowsOnTrees/Examples/Queens/Advanced.hs @@ -32,6 +32,10 @@ , PositionAndBitWithReflection -- * Main algorithm , nqueensGeneric + -- ** Using List instead of C at bottom + , nqueensWithListAtBottomGeneric + -- ** Not using anything at bottom + , nqueensWithNothingAtBottomGeneric -- ** Symmetry breaking -- $symmetry-breaking , nqueensStart @@ -78,7 +82,7 @@ import Control.Applicative ((<$>),liftA2) import Control.Arrow ((***)) import Control.Exception (evaluate) -import Control.Monad (MonadPlus(..),(>=>),liftM,liftM2) +import Control.Monad (MonadPlus(..),(>=>),liftM,liftM2,msum) import Data.Bits ((.&.),(.|.),bit,rotateL,rotateR,unsafeShiftL,unsafeShiftR) import Data.Function (on) @@ -164,6 +168,59 @@ search value size state = nqueensSearch updateValue (finalizeValueWithSymmetry n NoSymmetries) value size state {-# INLINE nqueensGeneric #-} +nqueensWithListAtBottomGeneric :: + (MonadPlus m + ,Typeable α + ,Typeable β + ) ⇒ + ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solution -} → + (Word → NQueensSymmetry → α → m β) {-^ function that finalizes a partial solution with the given board size and symmetry -} → + α {-^ initial partial solution -} → + Word {-^ board size -} → + m β {-^ the final result -} +nqueensWithListAtBottomGeneric updateValue finalizeValueWithSymmetry initial_value 1 = + finalizeValueWithSymmetry 1 AllSymmetries . updateValue [(0,0)] $ initial_value +nqueensWithListAtBottomGeneric _ _ _ 2 = mzero +nqueensWithListAtBottomGeneric _ _ _ 3 = mzero +nqueensWithListAtBottomGeneric updateValue finalizeValueWithSymmetry initial_value n = + nqueensStart + updateValue + break90 + break180 + search + initial_value + n + where + break90 = nqueensBreak90 updateValue (finalizeValueWithSymmetry n AllRotations) break90 break180 search + break180 = nqueensBreak180 updateValue (finalizeValueWithSymmetry n Rotate180Only) break180 search + search value size state = nqueensWithListAtBottomSearch updateValue (finalizeValueWithSymmetry n NoSymmetries) value size state +{-# INLINE nqueensWithListAtBottomGeneric #-} + +nqueensWithNothingAtBottomGeneric :: + MonadPlus m ⇒ + ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solution -} → + (Word → NQueensSymmetry → α → m β) {-^ function that finalizes a partial solution with the given board size and symmetry -} → + α {-^ initial partial solution -} → + Word {-^ board size -} → + m β {-^ the final result -} +nqueensWithNothingAtBottomGeneric updateValue finalizeValueWithSymmetry initial_value 1 = + finalizeValueWithSymmetry 1 AllSymmetries . updateValue [(0,0)] $ initial_value +nqueensWithNothingAtBottomGeneric _ _ _ 2 = mzero +nqueensWithNothingAtBottomGeneric _ _ _ 3 = mzero +nqueensWithNothingAtBottomGeneric updateValue finalizeValueWithSymmetry initial_value n = + nqueensStart + updateValue + break90 + break180 + search + initial_value + n + where + break90 = nqueensBreak90 updateValue (finalizeValueWithSymmetry n AllRotations) break90 break180 search + break180 = nqueensBreak180 updateValue (finalizeValueWithSymmetry n Rotate180Only) break180 search + search value size state = nqueensWithNothingAtBottomSearch updateValue (finalizeValueWithSymmetry n NoSymmetries) value size state +{-# INLINE nqueensWithNothingAtBottomGeneric #-} + -------------------------------------------------------------------------------- ------------------------------ Symmetry-breaking ------------------------------- -------------------------------------------------------------------------------- @@ -1003,6 +1060,146 @@ (occupied_positive_diagonals `rotateL` 1) ) {-# INLINE nqueensSearch #-} + +{-| Using brute-force to find placements for all of the remaining queens, using + the List monad instead of C for the bottom of the tree. + -} +nqueensWithListAtBottomSearch :: ∀ m α β. + (MonadPlus m + ,Typeable α + ,Typeable β + ) ⇒ + ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} → + (α → m β) {-^ function that finalizes the partial solution -} → + α {-^ partial solution -} → + Int {-^ board size -} → + NQueensSearchState {-^ current state -} → + m β {-^ the final result -} +nqueensWithListAtBottomSearch updateValue_ finalizeValue initial_value size initial_search_state@(NQueensSearchState _ window_start _ _ _ _) = + go initial_value initial_search_state + where + updateValue = updateValue_ . convertSolutionToWord + go !value !s@(NQueensSearchState + number_of_queens_remaining + row + occupied_rows + occupied_columns + occupied_negative_diagonals + occupied_positive_diagonals + ) + | number_of_queens_remaining <= 10 = msum $ go2 value s + | occupied_rows .&. 1 == 0 = + (getOpenings size $ + occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals + ) + >>= + \(PositionAndBit offset offset_bit) → go + ([(row,window_start+offset)] `updateValue` value) + (NQueensSearchState + (number_of_queens_remaining-1) + (row+1) + (occupied_rows `unsafeShiftR` 1) + (occupied_columns .|. offset_bit) + ((occupied_negative_diagonals .|. offset_bit) `unsafeShiftR` 1) + ((occupied_positive_diagonals .|. offset_bit) `rotateL` 1) + ) + | otherwise = + go value + (NQueensSearchState + number_of_queens_remaining + (row+1) + (occupied_rows `unsafeShiftR` 1) + occupied_columns + (occupied_negative_diagonals `unsafeShiftR` 1) + (occupied_positive_diagonals `rotateL` 1) + ) + go2 :: α → NQueensSearchState → [m β] + go2 !value !(NQueensSearchState + number_of_queens_remaining + row + occupied_rows + occupied_columns + occupied_negative_diagonals + occupied_positive_diagonals + ) + | number_of_queens_remaining == 0 = return $ finalizeValue value + | occupied_rows .&. 1 == 0 = + (getOpenings size $ + occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals + ) + >>= + \(PositionAndBit offset offset_bit) → go2 + ([(row,window_start+offset)] `updateValue` value) + (NQueensSearchState + (number_of_queens_remaining-1) + (row+1) + (occupied_rows `unsafeShiftR` 1) + (occupied_columns .|. offset_bit) + ((occupied_negative_diagonals .|. offset_bit) `unsafeShiftR` 1) + ((occupied_positive_diagonals .|. offset_bit) `rotateL` 1) + ) + | otherwise = + go2 value + (NQueensSearchState + number_of_queens_remaining + (row+1) + (occupied_rows `unsafeShiftR` 1) + occupied_columns + (occupied_negative_diagonals `unsafeShiftR` 1) + (occupied_positive_diagonals `rotateL` 1) + ) +{-# INLINE nqueensWithListAtBottomSearch #-} + +{-| Using brute-force to find placements for all of the remaining queens, using + nothing different for the bottom of the tree. + -} +nqueensWithNothingAtBottomSearch :: + MonadPlus m ⇒ + ([(Word,Word)] → α → α) {-^ function that adds a list of coordinates to the partial solutions -} → + (α → m β) {-^ function that finalizes the partial solution -} → + α {-^ partial solution -} → + Int {-^ board size -} → + NQueensSearchState {-^ current state -} → + m β {-^ the final result -} +nqueensWithNothingAtBottomSearch updateValue_ finalizeValue initial_value size initial_search_state@(NQueensSearchState _ window_start _ _ _ _) = + go initial_value initial_search_state + where + updateValue = updateValue_ . convertSolutionToWord + go !value !(NQueensSearchState + number_of_queens_remaining + row + occupied_rows + occupied_columns + occupied_negative_diagonals + occupied_positive_diagonals + ) + | number_of_queens_remaining == 0 = finalizeValue value + | occupied_rows .&. 1 == 0 = + (getOpenings size $ + occupied_columns .|. occupied_negative_diagonals .|. occupied_positive_diagonals + ) + >>= + \(PositionAndBit offset offset_bit) → go + ([(row,window_start+offset)] `updateValue` value) + (NQueensSearchState + (number_of_queens_remaining-1) + (row+1) + (occupied_rows `unsafeShiftR` 1) + (occupied_columns .|. offset_bit) + ((occupied_negative_diagonals .|. offset_bit) `unsafeShiftR` 1) + ((occupied_positive_diagonals .|. offset_bit) `rotateL` 1) + ) + | otherwise = + go value + (NQueensSearchState + number_of_queens_remaining + (row+1) + (occupied_rows `unsafeShiftR` 1) + occupied_columns + (occupied_negative_diagonals `unsafeShiftR` 1) + (occupied_positive_diagonals `rotateL` 1) + ) +{-# INLINE nqueensWithNothingAtBottomSearch #-} {-| Interface for directly using the brute-force search approach -} nqueensBruteForceGeneric :: diff --git a/sources/LogicGrowsOnTrees/Location.hs b/sources/LogicGrowsOnTrees/Location.hs --- a/sources/LogicGrowsOnTrees/Location.hs +++ b/sources/LogicGrowsOnTrees/Location.hs @@ -211,16 +211,14 @@ Location {-^ the location within the full tree obtained by following the path to the subtree and then the path indicated by the context -} -applyContextToLocation context = - case viewl context of - EmptyL → id - step :< rest → - applyContextToLocation rest - . - case step of - CacheContextStep _ → id - LeftBranchContextStep _ _ → leftBranchOf - RightBranchContextStep → rightBranchOf +applyContextToLocation [] = id +applyContextToLocation (step:rest) = + applyContextToLocation rest + . + case step of + CacheContextStep _ → id + LeftBranchContextStep _ _ → leftBranchOf + RightBranchContextStep → rightBranchOf {-| Append a path to a location's path. -} applyPathToLocation :: diff --git a/sources/LogicGrowsOnTrees/Parallel/Adapter/Threads.hs b/sources/LogicGrowsOnTrees/Parallel/Adapter/Threads.hs --- a/sources/LogicGrowsOnTrees/Parallel/Adapter/Threads.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Adapter/Threads.hs @@ -34,6 +34,8 @@ , fork , getCurrentProgressAsync , getCurrentProgress + , getCurrentStatisticsAsync + , getCurrentStatistics , getNumberOfWorkersAsync , getNumberOfWorkers , requestProgressUpdateAsync @@ -165,6 +167,7 @@ , optDoc = "This *required* option specifies the number of worker threads to spawn." } ) Nothing ) +{-# INLINE driver #-} -------------------------------------------------------------------------------- ---------------------------------- Controller ---------------------------------- @@ -224,6 +227,7 @@ Tree result {-^ the (pure) tree -} → IO (RunOutcome (Progress result) result) {-^ the outcome of the run -} exploreTree = exploreTreeStartingFrom mempty +{-# INLINE exploreTree #-} {-| Like 'exploreTree' but with a starting progress. -} exploreTreeStartingFrom :: @@ -233,6 +237,7 @@ Tree result {-^ the (pure) tree -} → IO (RunOutcome (Progress result) result) {-^ the outcome of the run -} exploreTreeStartingFrom = runExplorer AllMode Pure +{-# INLINE exploreTreeStartingFrom #-} {-| Like 'exploreTree' but with the tree running in IO. -} exploreTreeIO :: @@ -555,6 +560,7 @@ ) starting_progress controller +{-# INLINE runExplorer #-} -------------------------------------------------------------------------------- ----------------------------------- Internal ----------------------------------- diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/Process.hs b/sources/LogicGrowsOnTrees/Parallel/Common/Process.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/Process.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/Process.hs @@ -136,6 +136,7 @@ ,Handler $ \e → case e of ConnectionLost → debugM "Connection to supervisor was lost before this process had finished." ] +{-# INLINE runWorker #-} {-| The same as 'runWorker', but it lets you provide handles through which the messages will be sent and received. (Note that the reading and writing @@ -159,3 +160,4 @@ tree (receive receive_handle) (withMVar send_lock . const . send send_handle) +{-# INLINE runWorkerUsingHandles #-} diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/RequestQueue.hs b/sources/LogicGrowsOnTrees/Parallel/Common/RequestQueue.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/RequestQueue.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/RequestQueue.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DoRec #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -31,7 +32,9 @@ , RequestQueueReader -- * Functions -- ** Synchronized requests + , addWorkerCountListener , getCurrentProgress + , getCurrentStatistics , getNumberOfWorkers , requestProgressUpdate , syncAsync @@ -48,30 +51,42 @@ -- ** Controller threads , forkControllerThread , killControllerThreads + -- ** CPU time tracking + , CPUTimeTracker + , newCPUTimeTracker + , startCPUTimeTracker + , getCurrentCPUTime -- ** Miscellaneous , getQuantityAsync ) where import Prelude hiding (catch) -import Control.Applicative (liftA2) +import Control.Applicative ((<$>),(<*>),liftA2) import Control.Arrow ((&&&)) import Control.Concurrent (ThreadId,forkIO,killThread) import Control.Concurrent.MVar (newEmptyMVar,putMVar,takeMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (TChan,newTChanIO,readTChan,tryReadTChan,writeTChan) -import Control.Exception (BlockedIndefinitelyOnMVar(..),catch,finally) +import Control.Concurrent.STM.TVar (TVar,modifyTVar',newTVarIO,readTVar,writeTVar) +import Control.Exception (BlockedIndefinitelyOnMVar(..),catch,finally,mask) import Control.Monad.CatchIO (MonadCatchIO) -import Control.Monad ((>=>),join,liftM,liftM3) +import Control.Monad ((>=>),join,liftM,liftM3,unless) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ReaderT(..),ask) import Data.Composition ((.*)) import Data.IORef (IORef,atomicModifyIORef,readIORef,newIORef) import Data.List (delete) +import Data.Time.Clock (NominalDiffTime,UTCTime,diffUTCTime,getCurrentTime) import qualified LogicGrowsOnTrees.Parallel.Common.Supervisor as Supervisor -import LogicGrowsOnTrees.Parallel.Common.Supervisor (SupervisorFullConstraint,SupervisorMonad,SupervisorProgram(..)) +import LogicGrowsOnTrees.Parallel.Common.Supervisor + (RunStatistics + ,SupervisorFullConstraint + ,SupervisorMonad + ,SupervisorProgram(..) + ) import LogicGrowsOnTrees.Parallel.ExplorationMode -------------------------------------------------------------------------------- @@ -82,10 +97,17 @@ class (HasExplorationMode m, Functor m, MonadCatchIO m) ⇒ RequestQueueMonad m where {-| Abort the supervisor. -} abort :: m () + {-| Submits a function to be called whenever the number of workers changes; + the given function will be also called immediately with the current + number of workers. + -} + addWorkerCountListenerAsync :: (Int → IO ()) → IO () → m () {-| Fork a new thread running in this monad; all controller threads are automnatically killed when the run is finished. -} fork :: m () → m ThreadId {-| Request the current progress, invoking the given callback with the result; see 'getCurrentProgress' for the synchronous version. -} getCurrentProgressAsync :: (ProgressFor (ExplorationModeFor m) → IO ()) → m () + {-| Get the current run statistics. -} + getCurrentStatisticsAsync :: (RunStatistics → IO ()) → m () {-| Request the number of workers, invoking the given callback with the result; see 'getNumberOfWorkers' for the synchronous version. -} getNumberOfWorkersAsync :: (Int → IO ()) → m () {-| Request that a global progress update be performed, invoking the given callback with the result; see 'requestProgressUpdate' for the synchronous version. -} @@ -118,8 +140,10 @@ instance (SupervisorFullConstraint worker_id m, MonadCatchIO m) ⇒ RequestQueueMonad (RequestQueueReader exploration_mode worker_id m) where abort = ask >>= enqueueRequest Supervisor.abortSupervisor + addWorkerCountListenerAsync listener callback = ask >>= enqueueRequest (Supervisor.addWorkerCountListener listener >> liftIO callback) fork m = ask >>= flip forkControllerThread' m getCurrentProgressAsync = (ask >>=) . getQuantityAsync Supervisor.getCurrentProgress + getCurrentStatisticsAsync = (ask >>=) . getQuantityAsync Supervisor.getCurrentStatistics getNumberOfWorkersAsync = (ask >>=) . getQuantityAsync Supervisor.getNumberOfWorkers requestProgressUpdateAsync receiveUpdatedProgress = ask @@ -137,10 +161,18 @@ ------------------------------ Synchronized requests ------------------------------ +{-| Like 'addWorkerCountListenerAsync', but blocks until the listener has been added. -} +addWorkerCountListener :: RequestQueueMonad m ⇒ (Int → IO ()) → m () +addWorkerCountListener listener = syncAsync (\callback → addWorkerCountListenerAsync listener (callback ())) + {-| Like 'getCurrentProgressAsync', but blocks until the result is ready. -} getCurrentProgress :: RequestQueueMonad m ⇒ m (ProgressFor (ExplorationModeFor m)) getCurrentProgress = syncAsync getCurrentProgressAsync +{-| Like 'getCurrentStatisticsAsync', but blocks until the result is ready. -} +getCurrentStatistics :: RequestQueueMonad m ⇒ m RunStatistics +getCurrentStatistics = syncAsync getCurrentStatisticsAsync + {-| Like 'getNumberOfWorkersAsync', but blocks until the result is ready. -} getNumberOfWorkers :: RequestQueueMonad m ⇒ m Int getNumberOfWorkers = syncAsync getNumberOfWorkersAsync @@ -292,10 +324,8 @@ m' ThreadId forkControllerThread' request_queue controller = liftIO $ do start_signal ← newEmptyMVar - rec thread_id ← - forkIO - $ - (takeMVar start_signal >> runReaderT controller request_queue) + rec thread_id ← forkIO . mask $ \restore → + (restore $ takeMVar start_signal >> runReaderT controller request_queue) `finally` (atomicModifyIORef (controllerThreads request_queue) (delete thread_id &&& const ())) atomicModifyIORef (controllerThreads request_queue) ((thread_id:) &&& const ()) @@ -316,7 +346,53 @@ m' () killControllerThreads = liftIO . readIORef . controllerThreads >=> liftIO . mapM_ killThread ----------------------------------- Miscellaneous ---------------------------------- +------------------------------ CPU time tracking ------------------------------- + +{-| A data structure that tracks the amount of CPU time that has been used. -} +data CPUTimeTracker = CPUTimeTracker + { trackerStarted :: IORef Bool + , trackerLastTime :: TVar (Maybe (UTCTime,Int)) + , trackerTotalTime :: TVar NominalDiffTime + } + +{-| Creates a new CPU time tracker, which should be equal to the amount of total + time used so far if we are continuing a previous run and zero otherwise. + -} +newCPUTimeTracker :: NominalDiffTime → IO CPUTimeTracker +newCPUTimeTracker initial_cpu_time = + CPUTimeTracker + <$> newIORef False + <*> newTVarIO Nothing + <*> newTVarIO initial_cpu_time + +computeAdditionalTime current_time (last_time,last_number_of_workers) = + (current_time `diffUTCTime` last_time) * fromIntegral last_number_of_workers + +{-| Starts the CPU time tracker; it detects when it has already been started so + if you attempt to start it more than once then all subsequent attempts will + be ignored. + -} +startCPUTimeTracker :: RequestQueueMonad m ⇒ CPUTimeTracker → m () +startCPUTimeTracker CPUTimeTracker{..} = do + already_started ← liftIO $ atomicModifyIORef trackerStarted (const True &&& id) + unless already_started . addWorkerCountListener $ \current_number_of_workers → do + current_time ← getCurrentTime + atomically $ do + maybe_last ← readTVar trackerLastTime + flip (maybe (return ())) maybe_last $ \last → + modifyTVar' trackerTotalTime (+ computeAdditionalTime current_time last) + writeTVar trackerLastTime $ Just (current_time,current_number_of_workers) + +{-| Gets the current CPI time. -} +getCurrentCPUTime :: CPUTimeTracker → IO NominalDiffTime +getCurrentCPUTime CPUTimeTracker{..} = do + current_time ← getCurrentTime + atomically $ do + old_total_time ← readTVar trackerTotalTime + maybe_last ← readTVar trackerLastTime + return $ old_total_time + maybe 0 (computeAdditionalTime current_time) maybe_last + +-------------------------------- Miscellaneous --------------------------------- {-| Submits a 'Request' to the supervisor and invokes the given callback with the result when it is available. (This function is used by diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor.hs b/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor.hs @@ -58,6 +58,7 @@ , removeWorkerIfPresent -- ** Supervisor interaction , abortSupervisor + , addWorkerCountListener , beginSupervisorOccupied , disableSupervisorDebugMode , enableSupervisorDebugMode @@ -345,6 +346,13 @@ abortSupervisor :: SupervisorFullConstraint worker_id m ⇒ SupervisorMonad exploration_mode worker_id m α abortSupervisor = wrapIntoSupervisorMonad Implementation.abortSupervisor +{-| Submits a function to be called whenever the number of workers changes; the + given function will be also called immediately with the current number of + workers. + -} +addWorkerCountListener :: SupervisorMonadConstraint m ⇒ (Int → IO ()) → SupervisorMonad exploration_mode worker_id m () +addWorkerCountListener = wrapIntoSupervisorMonad . Implementation.addWorkerCountListener + {-| Signals that the supervisor has begun processing an event. -} beginSupervisorOccupied :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m () beginSupervisorOccupied = changeSupervisorOccupiedStatus True @@ -385,7 +393,7 @@ getCurrentStatistics :: SupervisorFullConstraint worker_id m ⇒ SupervisorMonad exploration_mode worker_id m RunStatistics -getCurrentStatistics = SupervisorMonad Implementation.getCurrentStatistics +getCurrentStatistics = wrapIntoSupervisorMonad Implementation.getCurrentStatistics {-| Gets the number of workers that are currently present in the system. -} getNumberOfWorkers :: SupervisorMonadConstraint m ⇒ SupervisorMonad exploration_mode worker_id m Int diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor/Implementation.hs b/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor/Implementation.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor/Implementation.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/Supervisor/Implementation.hs @@ -34,6 +34,7 @@ , abortSupervisor , abortSupervisorWithReason , addWorker + , addWorkerCountListener , changeSupervisorOccupiedStatus , current_time , getCurrentProgress @@ -245,6 +246,7 @@ , runSupervisorMonadOccupation :: !Float {-^ the fraction of the time the supervisor spent processing events while inside the 'SupervisorMonad' -} , runNumberOfCalls :: !Int {-^ the number of calls made to functions in "LogicGrowsOnTrees.Parallel.Common.Supervisor" -} , runAverageTimePerCall :: !Float {-^ the average amount of time per call made to functions in "LogicGrowsOnTrees.Parallel.Common.Supervisor" -} + , runWorkerCountStatistics :: !(FunctionOfTimeStatistics Int) {-^ statistics for the number of workers waiting for a workload -} , runWorkerOccupation :: !Float {-^ the fraction of the total time that workers were occupied -} , runWorkerWaitTimes :: !(FunctionOfTimeStatistics NominalDiffTime) {-^ statistics for how long it took for workers to obtain a workload -} , runStealWaitTimes :: !IndependentMeasurementsStatistics {-^ statistics for the time needed to steal a workload from a worker -} @@ -331,6 +333,7 @@ , _current_progress :: !(ProgressFor exploration_mode) , _debug_mode :: !Bool , _supervisor_occupation_statistics :: !OccupationStatistics + , _worker_count_statistics :: !(StepFunctionOfTime Int) , _worker_occupation_statistics :: !(Map worker_id OccupationStatistics) , _retired_worker_occupation_statistics :: !(Map worker_id RetiredOccupationStatistics) , _worker_wait_time_statistics :: !(InterpolatedFunctionOfTime NominalDiffTime) @@ -346,6 +349,7 @@ , _time_spent_in_supervisor_monad :: !NominalDiffTime , _workload_buffer_size :: !Int , _number_of_calls :: !Int + , _worker_count_listeners :: [Int → IO ()] } $( makeLenses ''SupervisorState ) -- }}} @@ -494,12 +498,13 @@ SupervisorFullConstraint worker_id m ⇒ SupervisorTerminationReasonFor exploration_mode worker_id → AbortMonad exploration_mode worker_id m α -abortSupervisorWithReason reason = AbortMonad $ - (SupervisorOutcome +abortSupervisorWithReason reason = AbortMonad $ do + lift $ notifyWorkerCountListeners 0 + SupervisorOutcome <$> (return reason) - <*> getCurrentStatistics + <*> getCurrentStatistics' <*> (Set.toList <$> use known_workers) - ) >>= abort + >>= abort -- }}} addPointToExponentiallyDecayingSum :: UTCTime → ExponentiallyDecayingSum → ExponentiallyDecayingSum -- {{{ @@ -525,12 +530,21 @@ addWorker worker_id = postValidate ("addWorker " ++ show worker_id) $ do infoM $ "Adding worker " ++ show worker_id validateWorkerNotKnown "adding worker" worker_id - known_workers %= Set.insert worker_id + Set.size <$> (known_workers <%= Set.insert worker_id) >>= notifyWorkerCountListeners start_time ← view current_time worker_occupation_statistics %= Map.insert worker_id (OccupationStatistics start_time start_time 0 False) tryToObtainWorkloadFor True worker_id -- }}} +addWorkerCountListener :: -- {{{ + SupervisorMonadConstraint m ⇒ + (Int → IO ()) → + ContextMonad exploration_mode worker_id m () +addWorkerCountListener listener = do + worker_count_listeners %= (listener:) + getNumberOfWorkers >>= liftIO . listener +-- }}} + beginWorkerOccupied :: -- {{{ ( SupervisorMonadConstraint m , SupervisorWorkerIdConstraint worker_id @@ -835,7 +849,8 @@ ) ⇒ FinalResultFor exploration_mode → InsideAbortMonad exploration_mode worker_id m α -finishWithResult final_value = +finishWithResult final_value = do + lift $ notifyWorkerCountListeners 0 SupervisorOutcome <$> (return $ SupervisorCompleted final_value) <*> (lift getCurrentStatistics) @@ -858,14 +873,14 @@ getCurrentProgress = use current_progress -- }}} -getCurrentStatistics :: -- {{{ +getCurrentStatistics' :: -- {{{ ( SupervisorFullConstraint worker_id m , SupervisorMonadConstraint m' , SupervisorReaderConstraint exploration_mode worker_id m m' , SupervisorStateConstraint exploration_mode worker_id m' ) ⇒ m' RunStatistics -getCurrentStatistics = do +getCurrentStatistics' = do runEndTime ← view current_time runStartTime ← use (supervisor_occupation_statistics . start_time) let runWallTime = runEndTime `diffUTCTime` runStartTime @@ -883,6 +898,11 @@ use time_spent_in_supervisor_monad runNumberOfCalls ← use number_of_calls let runAverageTimePerCall = runSupervisorMonadOccupation / fromIntegral runNumberOfCalls + runWorkerCountStatistics ← + extractFunctionOfTimeStatisticsWithFinalPoint + runStartTime + (Set.size <$> use known_workers) + (use worker_count_statistics) runWorkerOccupation ← getOccupationFraction . mconcat . Map.elems <$> @@ -917,12 +937,18 @@ return RunStatistics{..} -- }}} +getCurrentStatistics :: SupervisorFullConstraint worker_id m ⇒ ContextMonad exploration_mode worker_id m RunStatistics -- {{{ +getCurrentStatistics = getCurrentStatistics' +-- }}} + getNumberOfWorkers :: SupervisorMonadConstraint m ⇒ ContextMonad exploration_mode worker_id m Int -- {{{ getNumberOfWorkers = liftM Set.size . use $ known_workers -- }}} getOccupationFraction :: RetiredOccupationStatistics → Float -- {{{ -getOccupationFraction = realToFrac . liftA2 (/) (^.occupied_time) (^.total_time) +getOccupationFraction statistics + | statistics ^. total_time == 0 = 0 + | otherwise = realToFrac . liftA2 (/) (^.occupied_time) (^.total_time) $ statistics -- }}} getWorkerDepth :: -- {{{ @@ -1017,6 +1043,15 @@ return result -- }}} +notifyWorkerCountListeners :: -- {{{ + SupervisorMonadConstraint m ⇒ + Int → + ContextMonad exploration_mode worker_id m () +notifyWorkerCountListeners number_of_workers = do + updateFunctionOfTimeUsingLens worker_count_statistics number_of_workers + use worker_count_listeners >>= liftIO . mapM_ ($ number_of_workers) +-- }}} + performGlobalProgressUpdate :: -- {{{ ( SupervisorMonadConstraint m , SupervisorWorkerIdConstraint worker_id @@ -1228,7 +1263,7 @@ worker_id → ContextMonad exploration_mode worker_id m () retireWorker worker_id = do - known_workers %= Set.delete worker_id + Set.size <$> (known_workers <%= Set.delete worker_id) >>= notifyWorkerCountListeners retired_occupation_statistics ← worker_occupation_statistics %%= (fromJust . Map.lookup worker_id &&& Map.delete worker_id) >>= @@ -1265,7 +1300,7 @@ (∀ α. AbortMonad exploration_mode worker_id m α) → m (SupervisorOutcomeFor exploration_mode worker_id) runSupervisorStartingFrom exploration_mode starting_progress callbacks program = liftIO Clock.getCurrentTime >>= \start_time → - flip runReaderT (SupervisorConstants callbacks undefined exploration_mode) + flip runReaderT (SupervisorConstants callbacks (error "The current time was not set when entering the Supervisor module.") exploration_mode) . flip evalStateT (SupervisorState @@ -1296,6 +1331,7 @@ , _steal_request_matcher_queue = mempty , _steal_request_failures = 0 , _workload_steal_time_statistics = mempty + , _worker_count_statistics = initialStepFunctionForStartingTime start_time , _waiting_worker_count_statistics = initialStepFunctionForStartingTime start_time , _available_workload_count_statistics = initialStepFunctionForStartingTime start_time , _instantaneous_workload_request_rate = ExponentiallyDecayingSum start_time 0 @@ -1305,6 +1341,7 @@ , _time_spent_in_supervisor_monad = 0 , _workload_buffer_size = 4 , _number_of_calls = 0 + , _worker_count_listeners = [] } ) . diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/Worker.hs b/sources/LogicGrowsOnTrees/Parallel/Common/Worker.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/Worker.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/Worker.hs @@ -58,7 +58,7 @@ import Data.IVar (IVar) import Data.Maybe (fromMaybe) import Data.Monoid ((<>),Monoid(..)) -import Data.Sequence ((|>),(><),viewl,ViewL(..)) +import Data.Sequence ((|>),(><)) import Data.Serialize import qualified Data.Sequence as Seq import Data.Void (Void,absurd) @@ -460,6 +460,7 @@ then Right progress else Left (progressResult progress) _ → error "should never reach here due to incompatible types" +{-# INLINE exploreTreeGeneric #-} -------------------------------------------------------------------------------- ------------------------------ Internal functions ------------------------------ @@ -516,22 +517,20 @@ CheckpointCursor → Context m α → Maybe (CheckpointCursor,Context m α,Workload) -tryStealWorkload initial_path = go +tryStealWorkload initial_path cursor context = go cursor (reverse context) where - go cursor context = - case viewl context of - EmptyL → Nothing - CacheContextStep cache :< rest_context → - go (cursor |> CachePointD cache) rest_context - LeftBranchContextStep other_checkpoint _ :< rest_context → - Just (cursor |> ChoicePointD LeftBranch Unexplored - ,rest_context - ,Workload - ((initial_path >< pathFromCursor cursor) |> ChoiceStep RightBranch) - other_checkpoint - ) - RightBranchContextStep :< rest_context → - go (cursor |> ChoicePointD RightBranch Explored) rest_context + go _ [] = Nothing + go cursor (CacheContextStep cache:rest_context) = + go (cursor |> CachePointD cache) rest_context + go cursor (RightBranchContextStep:rest_context) = + go (cursor |> ChoicePointD RightBranch Explored) rest_context + go cursor (LeftBranchContextStep other_checkpoint _:rest_context) = + Just (cursor |> ChoicePointD LeftBranch Unexplored + ,reverse rest_context + ,Workload + ((initial_path >< pathFromCursor cursor) |> ChoiceStep RightBranch) + other_checkpoint + ) workloadFromSetting :: Path → diff --git a/sources/LogicGrowsOnTrees/Parallel/Common/Workgroup.hs b/sources/LogicGrowsOnTrees/Parallel/Common/Workgroup.hs --- a/sources/LogicGrowsOnTrees/Parallel/Common/Workgroup.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Common/Workgroup.hs @@ -215,7 +215,7 @@ asks sendWorkloadStealRequestTo >>= liftInner . forM_ worker_ids receiveCurrentProgress = receiveProgress request_queue sendWorkloadToWorker = \workload worker_id → do - infoM $ "Activating worker " ++ show worker_id ++ " with workload " ++ show workload + infoM $ "Activating worker " ++ show worker_id asks sendWorkloadTo >>= liftInner . ($ workload) . ($ worker_id) bumpWorkerRemovalPriority worker_id forkControllerThread request_queue controller diff --git a/sources/LogicGrowsOnTrees/Parallel/Main.hs b/sources/LogicGrowsOnTrees/Parallel/Main.hs --- a/sources/LogicGrowsOnTrees/Parallel/Main.hs +++ b/sources/LogicGrowsOnTrees/Parallel/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -92,38 +92,54 @@ , simpleMainForExploreTreeImpureUntilFoundUsingPush -- * Utility functions , extractRunOutcomeFromSupervisorOutcome + , mainMan , mainParser ) where -import Prelude hiding (readFile,writeFile) +import Prelude hiding (catch,readFile,writeFile) import Control.Applicative ((<$>),(<*>),pure) -import Control.Concurrent (ThreadId,killThread,threadDelay) -import Control.Exception (finally,handleJust,onException) -import Control.Monad (forever,liftM,mplus,when) +import Control.Arrow ((&&&)) +import Control.Concurrent (threadDelay) +import Control.Exception (AsyncException,SomeException,finally,fromException,handleJust,onException) +import Control.Monad (forM_,forever,join,liftM2,mplus,when,unless,void) +import Control.Monad.CatchIO (catch) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Tools (ifM) +import qualified Control.Monad.Trans.State.Strict as State +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (evalStateT) import Data.ByteString.Lazy (readFile,writeFile) import Data.Char (toLower) -import Data.Composition ((.*)) +import Data.Composition ((.*),(.**)) import Data.Derive.Serialize import Data.DeriveTH +import Data.Function (on) import Data.Functor.Identity (Identity) -import Data.Maybe (catMaybes) +import Data.IORef (IORef,newIORef,readIORef,writeIORef) +import Data.List (find,intercalate,nub) +import Data.List.Split (splitOn) +import Data.Maybe (isJust) import Data.Monoid (Monoid(..)) +import Data.Ord (comparing) import Data.Prefix.Units (FormatMode(FormatSiAll),formatValue,unitName) import Data.Serialize +import Data.Time.Clock (NominalDiffTime) import System.Console.CmdTheLine import System.Directory (doesFileExist,removeFile,renameFile) import System.Environment (getProgName) -import System.IO (hPutStr,hPutStrLn,stderr) +import System.IO (hFlush,hPutStrLn,stderr,stdout) import System.IO.Error (isDoesNotExistError) import qualified System.Log.Logger as Logger -import System.Log.Logger (Priority(..),setLevel,rootLoggerName,updateGlobalLogger) +import System.Log.Formatter (simpleLogFormatter) +import System.Log.Handler (setFormatter) +import System.Log.Handler.Simple (streamHandler) +import System.Log.Logger (Priority(..),logM,rootLoggerName,setHandlers,setLevel,updateGlobalLogger) import System.Log.Logger.TH +import Text.PrettyPrint (text) import Text.Printf (printf) import LogicGrowsOnTrees (Tree,TreeIO,TreeT) @@ -143,45 +159,57 @@ ----------------------------------- Loggers ------------------------------------ -------------------------------------------------------------------------------- -deriveLoggers "Logger" [INFO,NOTICE] +deriveLoggers "Logger" [INFO,NOTICE,ERROR] -------------------------------------------------------------------------------- ------------------------------------ Types ------------------------------------- -------------------------------------------------------------------------------- +type Tense = String → String → String + +---------------------------------- Statistic ----------------------------------- + +data Statistic = Statistic + { statisticLongName :: String + , statisticShortName :: String + , statisticDescription :: String + , statisticApplication :: Tense → RunStatistics → String + } +instance Eq Statistic where + (==) = (==) `on` statisticLongName +instance Ord Statistic where + compare = comparing statisticLongName + -------------------------------- Configuration --------------------------------- data CheckpointConfiguration = CheckpointConfiguration - { checkpoint_path :: FilePath + { maybe_checkpoint_path :: Maybe FilePath , checkpoint_interval :: Float } deriving (Eq,Show) data LoggingConfiguration = LoggingConfiguration { log_level :: Priority + , maybe_log_format :: Maybe String } deriving (Eq,Show) -instance Serialize LoggingConfiguration where - put = put . show . log_level - get = LoggingConfiguration . read <$> get +instance Serialize Priority where + put = put . show + get = read <$> get +$( derive makeSerialize ''LoggingConfiguration ) data StatisticsConfiguration = StatisticsConfiguration - { show_wall_times :: !Bool - , show_supervisor_occupation :: !Bool - , show_supervisor_monad_occupation :: !Bool - , show_supervisor_calls :: !Bool - , show_worker_occupation :: !Bool - , show_worker_wait_times :: !Bool - , show_steal_wait_times :: !Bool - , show_numbers_of_waiting_workers :: !Bool - , show_numbers_of_available_workloads :: !Bool - , show_instantaneous_workload_request_rates :: !Bool - , show_instantaneous_workload_steal_times :: !Bool - } deriving (Eq,Show) + { end_stats_configuration :: [[Statistic]] + , log_end_stats_configuration :: Bool + , log_stats_configuration :: [[Statistic]] + , log_stats_level_configuration :: Priority + , log_stats_interval_configuration :: Float + } data SupervisorConfiguration = SupervisorConfiguration - { maybe_checkpoint_configuration :: Maybe CheckpointConfiguration + { checkpoint_configuration :: CheckpointConfiguration , maybe_workload_buffer_size_configuration :: Maybe Int , statistics_configuration :: StatisticsConfiguration - } deriving (Eq,Show) + , show_cpu_time :: Bool + } data SharedConfiguration tree_configuration = SharedConfiguration { logging_configuration :: LoggingConfiguration @@ -189,6 +217,9 @@ } deriving (Eq,Show) $( derive makeSerialize ''SharedConfiguration ) +data ProgressAndCPUTime progress = ProgressAndCPUTime progress Rational +$( derive makeSerialize ''ProgressAndCPUTime ) + --------------------------------- Driver types --------------------------------- {-| The 'Driver' is the core type that abstracts the various adapters behind a @@ -301,6 +332,21 @@ \level → let name = show level in return (name,level) `mplus` return (map toLower name,level) +instance ArgVal [Statistic] where + converter = (parse,pretty) + where + parse = go [] . splitOn "," + where + go stats [] = Right . reverse . nub $ stats + go _ ("all":_) = Right statistics + go stats (name:rest) = + case find (\Statistic{..} → statisticLongName == name || statisticShortName == name) statistics of + Just stat → go (stat:stats) rest + Nothing → Left . text $ "unrecognized statistic '" ++ show name ++ "'" + pretty stats + | length stats == length statistics = text "all" + | otherwise = text . intercalate "," . map statisticLongName $ stats + -------------------------------------------------------------------------------- -------------------------------- Main functions -------------------------------- -------------------------------------------------------------------------------- @@ -362,6 +408,7 @@ (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTree = genericMain (const AllMode) Pure +{-# INLINE mainForExploreTree #-} {-| Explore the given IO tree in parallel; the results in the leaves will be summed up using the 'Monoid' instance. @@ -384,6 +431,7 @@ (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeIO = genericMain (const AllMode) io_purity +{-# INLINE mainForExploreTreeIO #-} {-| Explore the given impure tree in parallel; the results in all of the leaves will be summed up using the 'Monoid' instance. @@ -407,6 +455,7 @@ (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeImpure = genericMain (const AllMode) . ImpureAtopIO +{-# INLINE mainForExploreTreeImpure #-} ---------------------------- Stop at first result ------------------------------ @@ -443,6 +492,7 @@ (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeUntilFirst = genericMain (const FirstMode) Pure +{-# INLINE mainForExploreTreeUntilFirst #-} {-| Explore the given IO tree in parallel, stopping if a solution is found. -} mainForExploreTreeIOUntilFirst :: @@ -463,6 +513,7 @@ (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeIOUntilFirst = genericMain (const FirstMode) io_purity +{-# INLINE mainForExploreTreeIOUntilFirst #-} {-| Explore the given impure tree in parallel, stopping if a solution is found. -} mainForExploreTreeImpureUntilFirst :: @@ -484,6 +535,7 @@ (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeImpureUntilFirst = genericMain (const FirstMode) . ImpureAtopIO +{-# INLINE mainForExploreTreeImpureUntilFirst #-} ------------------- Stop when sum of results meets condition ------------------- @@ -553,6 +605,7 @@ (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) Pure +{-# INLINE mainForExploreTreeUntilFoundUsingPull #-} {-| Explore the given IO tree in parallel until the sum of results meets the given condition. @@ -576,6 +629,7 @@ (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeIOUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) io_purity +{-# INLINE mainForExploreTreeIOUntilFoundUsingPull #-} {-| Explore the given impure tree in parallel until the sum of results meets the given condition. @@ -600,6 +654,7 @@ (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeImpureUntilFoundUsingPull constructCondition = genericMain (FoundModeUsingPull . constructCondition) . ImpureAtopIO +{-# INLINE mainForExploreTreeImpureUntilFoundUsingPull #-} {- $push #push# In this mode, whenever a result is found it is immediately sent to the @@ -649,6 +704,7 @@ (tree_configuration → Tree result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) Pure +{-# INLINE mainForExploreTreeUntilFoundUsingPush #-} {-| Explore the given IO tree in parallel until the sum of results meets the given condition. @@ -672,6 +728,7 @@ (tree_configuration → TreeIO result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeIOUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) io_purity +{-# INLINE mainForExploreTreeIOUntilFoundUsingPush #-} {-| Explore the given impure tree in parallel until the sum of results meets the given condition. @@ -696,88 +753,7 @@ (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → result_monad () mainForExploreTreeImpureUntilFoundUsingPush constructCondition = genericMain (FoundModeUsingPush . constructCondition) . ImpureAtopIO - ----------------------------- Generic main function ----------------------------- - -{-| This is just like the previous functions, except that it is generalized over - all tree purities and exploration modes. (In fact, the specialized - functions are just wrappers around this function.) - -} -genericMain :: - ( MonadIO result_monad - , ResultFor exploration_mode ~ result - , Serialize (ProgressFor exploration_mode) - ) ⇒ - (tree_configuration → ExplorationMode exploration_mode) - {-^ a function that constructs the exploration mode given the tree - configuration; note that the constructor that this function returns - is restricted by the value of the exploration_mode type variable - -} → - Purity m n {-^ the purity of the tree -} → - Driver - result_monad - (SharedConfiguration tree_configuration) - SupervisorConfiguration - m n - exploration_mode - {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} → - Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} → - TermInfo - {-^ information about the program; should look something like the following: - - > defTI { termDoc = "count the number of n-queens solutions for a given board size" } - -} → - (tree_configuration → RunOutcomeFor exploration_mode → IO ()) - {-^ a callback that will be invoked with the outcome of the run and the - tree configuration information; note that if the run was 'Completed' - then the checkpoint file will be deleted if this function finishes - successfully - -} → - (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → - result_monad () -genericMain constructExplorationMode_ purity (Driver run) tree_configuration_term program_info notifyTerminated_ constructTree_ = - run DriverParameters{..} - where - constructExplorationMode = constructExplorationMode_ . tree_configuration - shared_configuration_term = makeSharedConfigurationTerm tree_configuration_term - supervisor_configuration_term = - SupervisorConfiguration - <$> checkpoint_configuration_term - <*> maybe_workload_buffer_size_configuration_term - <*> statistics_configuration_term - initializeGlobalState SharedConfiguration{logging_configuration=LoggingConfiguration{..}} = - updateGlobalLogger rootLoggerName (setLevel log_level) - constructTree = constructTree_ . tree_configuration - getStartingProgress shared_configuration SupervisorConfiguration{..} = - case maybe_checkpoint_configuration of - Nothing → (infoM "Checkpointing is NOT enabled") >> return initial_progress - Just CheckpointConfiguration{..} → do - noticeM $ "Checkpointing enabled" - noticeM $ "Checkpoint file is " ++ checkpoint_path - noticeM $ "Checkpoint interval is " ++ show checkpoint_interval ++ " seconds" - ifM (doesFileExist checkpoint_path) - (noticeM "Loading existing checkpoint file" >> either error id . decodeLazy <$> readFile checkpoint_path) - (return initial_progress) - where - initial_progress = initialProgress . constructExplorationMode $ shared_configuration - notifyTerminated SharedConfiguration{..} SupervisorConfiguration{..} run_outcome@RunOutcome{..} = - case maybe_checkpoint_configuration of - Nothing → doEndOfRun - Just CheckpointConfiguration{checkpoint_path} → - do doEndOfRun - noticeM "Deleting any remaining checkpoint file" - removeFileIfExists checkpoint_path - `finally` - case runTerminationReason of - Aborted checkpoint → writeCheckpointFile checkpoint_path checkpoint - Failure checkpoint _ → writeCheckpointFile checkpoint_path checkpoint - _ → return () - where - doEndOfRun = do - showStatistics statistics_configuration runStatistics - notifyTerminated_ tree_configuration run_outcome - - constructController = const controllerLoop +{-# INLINE mainForExploreTreeImpureUntilFoundUsingPush #-} -------------------------------------------------------------------------------- -------------------------- Simplified main functions --------------------------- @@ -812,6 +788,7 @@ Tree result {-^ the tree to explore -} → result_monad () simpleMainForExploreTree = dispatchToMainFunction mainForExploreTree +{-# INLINE simpleMainForExploreTree #-} {-| Explore the given IO tree in parallel; the results in the leaves will be summed up using the 'Monoid' instance. @@ -827,6 +804,7 @@ TreeIO result {-^ the tree to explore in IO -} → result_monad () simpleMainForExploreTreeIO = dispatchToMainFunction mainForExploreTreeIO +{-# INLINE simpleMainForExploreTreeIO #-} {-| Explore the given impure tree in parallel; the results in all of the leaves will be summed up using the 'Monoid' instance. @@ -843,6 +821,7 @@ TreeT m result {-^ the (impure) tree to explore -} → result_monad () simpleMainForExploreTreeImpure = dispatchToMainFunction . mainForExploreTreeImpure +{-# INLINE simpleMainForExploreTreeImpure #-} ---------------------------- Stop at first result ------------------------------ @@ -862,6 +841,7 @@ Tree result {-^ the tree to explore -} → result_monad () simpleMainForExploreTreeUntilFirst = dispatchToMainFunction mainForExploreTreeUntilFirst +{-# INLINE simpleMainForExploreTreeUntilFirst #-} {-| Explore the given tree in parallel in IO, stopping if a solution is found. -} simpleMainForExploreTreeIOUntilFirst :: @@ -875,6 +855,7 @@ TreeIO result {-^ the tree to explore in IO -} → result_monad () simpleMainForExploreTreeIOUntilFirst = dispatchToMainFunction mainForExploreTreeIOUntilFirst +{-# INLINE simpleMainForExploreTreeIOUntilFirst #-} {-| Explore the given impure tree in parallel, stopping if a solution is found. -} simpleMainForExploreTreeImpureUntilFirst :: @@ -889,6 +870,7 @@ TreeT m result {-^ the impure tree to explore -} → result_monad () simpleMainForExploreTreeImpureUntilFirst = dispatchToMainFunction . mainForExploreTreeImpureUntilFirst +{-# INLINE simpleMainForExploreTreeImpureUntilFirst #-} ------------------- Stop when sum of results meets condition ------------------- @@ -915,6 +897,7 @@ Tree result {-^ the tree to explore -} → result_monad () simpleMainForExploreTreeUntilFoundUsingPull = dispatchToMainFunction . mainForExploreTreeUntilFoundUsingPull . const +{-# INLINE simpleMainForExploreTreeUntilFoundUsingPull #-} {-| Explore the given IO tree in parallel until the sum of results meets the given condition. @@ -931,6 +914,7 @@ TreeIO result {-^ the tree to explore in IO -} → result_monad () simpleMainForExploreTreeIOUntilFoundUsingPull = dispatchToMainFunction . mainForExploreTreeIOUntilFoundUsingPull . const +{-# INLINE simpleMainForExploreTreeIOUntilFoundUsingPull #-} {-| Explore the given impure tree in parallel until the sum of results meets the given condition. @@ -948,6 +932,7 @@ TreeT m result {-^ the impure tree to explore -} → result_monad () simpleMainForExploreTreeImpureUntilFoundUsingPull = (dispatchToMainFunction .* mainForExploreTreeImpureUntilFoundUsingPull) . const +{-# INLINE simpleMainForExploreTreeImpureUntilFoundUsingPull #-} {- $push-simple For more details, follow this link: "LogicGrowsOnTrees.Parallel.Main#push" @@ -969,6 +954,7 @@ Tree result {-^ the tree to explore -} → result_monad () simpleMainForExploreTreeUntilFoundUsingPush = dispatchToMainFunction . mainForExploreTreeUntilFoundUsingPush . const +{-# INLINE simpleMainForExploreTreeUntilFoundUsingPush #-} {-| Explore the given IO tree in parallel until the sum of results meets the given condition. @@ -985,6 +971,7 @@ TreeIO result {-^ the tree to explore in IO -} → result_monad () simpleMainForExploreTreeIOUntilFoundUsingPush = dispatchToMainFunction . mainForExploreTreeIOUntilFoundUsingPush . const +{-# INLINE simpleMainForExploreTreeIOUntilFoundUsingPush #-} {-| Explore the given impure tree in parallel until the sum of results meets the given condition. @@ -1002,8 +989,138 @@ TreeT m result {-^ the impure tree to explore -} → result_monad () simpleMainForExploreTreeImpureUntilFoundUsingPush = (dispatchToMainFunction .* mainForExploreTreeImpureUntilFoundUsingPush) . const +{-# INLINE simpleMainForExploreTreeImpureUntilFoundUsingPush #-} -------------------------------------------------------------------------------- +---------------------------- Generic main function ----------------------------- +-------------------------------------------------------------------------------- + +{-| This is just like the previous functions, except that it is generalized over + all tree purities and exploration modes. (In fact, the specialized + functions are just wrappers around this function.) + -} +genericMain :: + ( MonadIO result_monad + , ResultFor exploration_mode ~ result + , Serialize (ProgressFor exploration_mode) + ) ⇒ + (tree_configuration → ExplorationMode exploration_mode) + {-^ a function that constructs the exploration mode given the tree + configuration; note that the constructor that this function returns + is restricted by the value of the exploration_mode type variable + -} → + Purity m n {-^ the purity of the tree -} → + Driver + result_monad + (SharedConfiguration tree_configuration) + SupervisorConfiguration + m n + exploration_mode + {-^ the driver for the desired adapter (note that all drivers can be specialized to this type) -} → + Term tree_configuration {-^ a term with any configuration information needed to construct the tree -} → + TermInfo + {-^ information about the program; should look something like the following: + + > defTI { termDoc = "count the number of n-queens solutions for a given board size" } + -} → + (tree_configuration → RunOutcomeFor exploration_mode → IO ()) + {-^ a callback that will be invoked with the outcome of the run and the + tree configuration information; note that if the run was 'Completed' + then the checkpoint file will be deleted if this function finishes + successfully + -} → + (tree_configuration → TreeT m result) {-^ the function that constructs the tree given the tree configuration information -} → + result_monad () +genericMain constructExplorationMode_ purity (Driver run) tree_configuration_term program_info_ notifyTerminated_user constructTree_ = do + tracker_ref ← liftIO . newIORef $ error "tracker was not set" + let constructController = constructController_ tracker_ref + notifyTerminated = notifyTerminated_main tracker_ref + getStartingProgress = getStartingProgress_ tracker_ref + run DriverParameters{..} + where + constructExplorationMode = constructExplorationMode_ . tree_configuration + shared_configuration_term = makeSharedConfigurationTerm tree_configuration_term + supervisor_configuration_term = + SupervisorConfiguration + <$> checkpoint_configuration_term + <*> maybe_workload_buffer_size_configuration_term + <*> statistics_configuration_term + <*> show_cpu_time_term + program_info = program_info_ { man = mainMan } + initializeGlobalState SharedConfiguration{logging_configuration=LoggingConfiguration{..}} = do + case maybe_log_format of + Nothing → return () + Just log_format → do + handler ← flip setFormatter (simpleLogFormatter log_format) <$> streamHandler stdout log_level + updateGlobalLogger rootLoggerName $ setHandlers [handler] + updateGlobalLogger rootLoggerName (setLevel log_level) + constructTree = constructTree_ . tree_configuration + getStartingProgress_ + tracker_ref + shared_configuration + SupervisorConfiguration{checkpoint_configuration=CheckpointConfiguration{..},..} + = do + case maybe_checkpoint_path of + Nothing → do + infoM "Checkpointing is NOT enabled" + newCPUTimeTracker 0 >>= writeIORef tracker_ref + return initial_progress + Just checkpoint_path → do + infoM $ "Checkpointing enabled" + infoM $ "Checkpoint file is " ++ checkpoint_path + infoM $ "Checkpoint interval is " ++ show checkpoint_interval ++ " seconds" + ifM (doesFileExist checkpoint_path) + (do infoM "Loading existing checkpoint file" + ProgressAndCPUTime progress initial_cpu_time ← either error id . decodeLazy <$> readFile checkpoint_path + newCPUTimeTracker (realToFrac initial_cpu_time) >>= writeIORef tracker_ref + return progress + ) + (newCPUTimeTracker 0 >>= writeIORef tracker_ref >> return initial_progress) + where + initial_progress = initialProgress . constructExplorationMode $ shared_configuration + notifyTerminated_main + tracker_ref + SharedConfiguration{..} + SupervisorConfiguration{checkpoint_configuration=CheckpointConfiguration{..},..} + run_outcome@RunOutcome{..} + = do + cpu_time ← readIORef tracker_ref >>= getCurrentCPUTime + case maybe_checkpoint_path of + Nothing → doEndOfRun cpu_time + Just checkpoint_path → + do doEndOfRun cpu_time + infoM "Deleting any remaining checkpoint file" + removeFileIfExists checkpoint_path + `finally` + do + case runTerminationReason of + Aborted checkpoint → writeCheckpointFile checkpoint_path checkpoint cpu_time + Failure checkpoint _ → writeCheckpointFile checkpoint_path checkpoint cpu_time + _ → return () + where + StatisticsConfiguration{..} = statistics_configuration + doEndOfRun cpu_time = do + if log_end_stats_configuration + then writeStatisticsToLog + log_stats_level_configuration + pastTense + runStatistics + end_stats_configuration + else mapM_ (hPutStrLn stderr) + . + map snd + . + generateStatistics pastTense runStatistics + $ + end_stats_configuration + when show_cpu_time . hPutStrLn stderr $ + "Total CPU time used was " ++ showWithUnitPrefix cpu_time ++ "seconds." + hFlush stderr + notifyTerminated_user tree_configuration run_outcome + constructController_ = const . controllerLoop +{-# INLINE genericMain #-} + +-------------------------------------------------------------------------------- ------------------------------ Utility functions ------------------------------- -------------------------------------------------------------------------------- @@ -1022,6 +1139,30 @@ Failure remainig_progress $ "Worker " ++ show worker_id ++ " failed with message: " ++ message runStatistics = supervisorRunStatistics +{-| The additional entries in the manual explaining log format strings and + statistics. If you are not using the "Main" term info then you should add + 'mainMan' to your term information as otherwise the documentation will be + incomplete; in particular when using 'execChoice' you will want to use this + for each of the modes that corresponds to the supervisor (as logging and + statistics are only on the supervisor). + -} +mainMan :: [ManBlock] +mainMan = + [S "Log Formatting" + ,P "The following are the variables you can use in the format string:" + ,I "$msg" "The actual log message" + ,I "$loggername" "The name of the logger" + ,I "$prio" "The priority level of the message" + ,I "$tid" "The thread ID" + ,I "$pid" "Process ID (Not available on windows)" + ,I "$time" "The current time" + ,I "$utcTime" "The current time in UTC Time" + ] + ++ + [S "Statistics",P "Each statistic has a long-form name and an abbreviated name (in parentheses) shown below; you may use either when specifying it"] + ++ + map (I <$> (printf "%s (%s)" <$> statisticLongName <*> statisticShortName) <*> statisticDescription) statistics + {-| Parse the command line options using the given term and term info (the latter of which has the program name added to it); if successful return the result, otherwise throw an exception. @@ -1037,64 +1178,325 @@ ----------------------------------- Internal ----------------------------------- -------------------------------------------------------------------------------- -default_terminfo :: TermInfo -default_terminfo = defTI { termDoc = "LogicGrowsOnTrees program" } +---------------------------------- Statistics ---------------------------------- -dispatchToMainFunction f driver notifyTerminated tree = - f driver - (pure ()) - default_terminfo - (const notifyTerminated) - (const tree) -{- INLINE dispatchToMainFunction -} +statistics :: [Statistic] +statistics = + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + [Statistic "walltimes" "times" + "the starting, ending, and duration (wall) time of the run" + (\tense RunStatistics{..} → + let total_time = realToFrac runWallTime :: Float + in tense + (printf "The run started at %s, and so far it has run for %sseconds." + (show runStartTime) + (showWithUnitPrefix total_time) + ) + (printf "The run started at %s, ended at %s, and took %sseconds." + (show runStartTime) + (show runEndTime) + (showWithUnitPrefix total_time) + ) + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "supervisor-occupation" "supocc" + "the percentage of the time that the supervisor was occupied" + (\tense RunStatistics{..} → + printf "The supervior %s occupied for %.2f%% of the time so far, of which %.2f%% %s spent inside the SupervisorMonad." + (tense "has been" "was") + (runSupervisorOccupation*100) + (runSupervisorOccupation/runSupervisorMonadOccupation*100) + (tense "has been" "was") + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "supervisor-calls" "supcalls" + "the number of calls made to functions in the Supervisor module as well as the average time per call" + (\tense RunStatistics{..} → + printf "There %s %i calls made to functions in the Supervisor module, each of which took an average of %sseconds to complete." + (tense "have been" "were") + runNumberOfCalls + (showWithUnitPrefix runAverageTimePerCall) + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "worker-count" "workcnt" + "statistics about the number of participating workers" + (\_ RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runWorkerCountStatistics + in if timeMax == 0 + then + "No workers participated in this run." + else if timeMin == 0 + then + printf "On average there were %.1f +/- %.1f (std. dev) workers participating in the run; never more than %i." + timeAverage + timeStdDev + timeMax + else + printf "On average there were %.1f +/- %.1f (std. dev) workers participating in the run; never more than %i nor fewer than %i." + timeAverage + timeStdDev + timeMax + timeMin + ) -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "worker-occupation" "workocc" + "the average percentage of the time that the workers were occupied" + (\tense RunStatistics{..} → + printf "Workers %s occupied for %.2f%% of the time on average." + (tense "have been" "were") + (runWorkerOccupation*100) + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "worker-waiting-times" "workwait" + "statistics about the amount of time that it took for a worker to obtain a new workload after finishing a workload" + (\tense RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runWorkerWaitTimes + total_time = realToFrac runWallTime :: Float + in if timeCount == 0 + then + printf "At no point %s a worker receive%s a new workload after finishing its current workload." + (tense "has" "did") + (tense "d" "") + else + if timeMax == 0 + then + printf "Workers %scompleted their workload and obtained a new one %i times and never once has any had to wait to receive a new workload." + (tense "have " "") + timeCount + else + printf ( + intercalate "\n" + ["Workers %scompleted their task and obtained a new workload %i times with an average of one every %sseconds or %.1g enqueues/second." + ,"The minimum waiting time %s %sseconds, and the maximum waiting time %s %sseconds." + ,"On average, a worker %shad to wait %sseconds +/- %sseconds (std. dev) for a new workload." + ] + ) + (tense "have " "") + timeCount + (showWithUnitPrefix $ total_time / fromIntegral timeCount) + (fromIntegral timeCount / total_time) + (tense "has been" "was") + (showWithUnitPrefix timeMin) + (tense "has been" "was") + (showWithUnitPrefix timeMax) + (tense "has " "") + (showWithUnitPrefix timeAverage) + (showWithUnitPrefix timeStdDev) + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "steal-waiting-times" "stealwait" + "statistics about the amount of time needed to steal a workload" + (\tense RunStatistics{..} → + let IndependentMeasurementsStatistics{..} = runStealWaitTimes + total_time = realToFrac runWallTime :: Float + in if statCount == 0 + then + printf "No workloads %s stolen." + (tense "have been" "were") + else + printf ( + intercalate "\n" + ["Workloads %s stolen %i times with an average of %sseconds between each steal or %.1g steals/second." + ,"The minimum waiting time for a steal %s %sseconds, and the maximum waiting time %s %sseconds." + ,"On average, it %s %sseconds +/- %sseconds (std. dev) to steal a workload." + ] + ) + (tense "have been" "were") + statCount + (showWithUnitPrefix $ total_time / fromIntegral statCount) + (fromIntegral statCount / total_time) + (tense "has been" "was") + (showWithUnitPrefix statMin) + (tense "has been" "was") + (showWithUnitPrefix statMax) + (tense "has taken" "took") + (showWithUnitPrefix statAverage) + (showWithUnitPrefix statStdDev) + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "waiting-worker-count" "waitworkcnt" + "statistics about the number of waiting workers" + (\tense RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runWaitingWorkerStatistics + in if timeMax == 0 + then + printf "No worker %s to wait for a workload to become available." + (tense "has had" "ever had") + else if timeMin == 0 + then + printf "On average, %.1f +/- %.1f (std. dev) workers %s waiting for a workload at any given time; never more than %i." + timeAverage + timeStdDev + (tense "have been" "were") + timeMax + else + printf "On average, %.1f +/- %.1f (std. dev) workers %s waiting for a workload at any given time; never more than %i nor fewer than %i." + timeAverage + timeStdDev + (tense "have been" "were") + timeMax + timeMin + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "available-workload-count" "avlwldcnt" + "This option will cause statistics about the number of available workloads to be printed to standard error after the program terminates." + (\tense RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runAvailableWorkloadStatistics + in if timeMax == 0 + then + printf "No workload %s to wait for an available worker." + (tense "has had" "ever had") + else if timeMin == 0 + then + printf "On average, %.1f +/- %.1f (std. dev) workloads %s waiting for a worker at any given time; never more than %i." + timeAverage + timeStdDev + (tense "have been" "were") + timeMax + else + printf "On average, %.1f +/- %.1f (std. dev) workloads %s waiting for a worker at any given time; never more than %i nor fewer than %i." + timeAverage + timeStdDev + (tense "have been" "were") + timeMax + timeMin + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "instant-workload-request-rate" "instworkreq" + "statistics about the (roughly) instantaneous rate at which workloads were requested by finished workers (obtained via exponential smoothing over a time scale of one second)" + (\tense RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadRequestRateStatistics + in printf "On average, the instantanenous rate at which workloads %s being requested %s %.1f +/- %.1f (std. dev) requests per second; the rate %s below %.1f nor %s above %.1f." + (tense "are" "were") + (tense "is" "was") + timeAverage + timeStdDev + (tense "has never fallen" "never fell") + timeMin + (tense "risen" "rose") + timeMax + ) + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ,Statistic "instant-workload-steal-times" "instwldsteal" + "statistics about the (roughly) instantaneous amount of time that it took to steal a workload (obtained via exponential smoothing over a time scale of one second" + (\tense RunStatistics{..} → + let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadStealTimeStatistics + in printf "On average, the instantaneous time to steal a workload %s %sseconds +/- %sseconds (std. dev); this time interval %s below %sseconds nor %s above %sseconds." + (tense "has been" "was") + (showWithUnitPrefix timeAverage) + (showWithUnitPrefix timeStdDev) + (tense "has never fallen" "never fell") + (showWithUnitPrefix timeMin) + (tense "risen" "rose") + (showWithUnitPrefix timeMax) + ) + ] -checkpoint_configuration_term :: Term (Maybe CheckpointConfiguration) +----------------------------- Configuration terms ------------------------------ + +checkpoint_configuration_term :: Term CheckpointConfiguration checkpoint_configuration_term = - maybe (const Nothing) (Just .* CheckpointConfiguration) + CheckpointConfiguration <$> value (flip opt ( (optInfo ["c","checkpoint-file"]) { optName = "FILEPATH" - , optDoc = "This enables periodic checkpointing with the given path specifying the location of the checkpoint file; if the file already exists then it will be loaded as the initial starting point for the search." + , optDoc = unwords + ["This enables periodic checkpointing with the given path" + ,"specifying the location of the checkpoint file; if the file" + ,"already exists then it will be loaded as the initial starting" + ,"point for the search." + ] } ) Nothing) <*> value (flip opt ( - (optInfo ["i","checkpoint-interval"]) + (optInfo ["i","interval"]) { optName = "SECONDS" - , optDoc = "This specifies the time between checkpoints (in seconds, decimals allowed); it is ignored if checkpoint file is not specified." + , optDoc = unwords + ["If checkpointing is enabled, this specifies how often a" + ,"checkpoint will be written; if checkpointing is not enabled," + ,"then it sets how often a global progress update is performed" + ,"(which matters when workers will join and leave during the" + ,"run so that their partial progress is not lost). This" + ,"quantity is given in seconds, and not only may it be" + ,"fractional but in fact a decimal point is required as" + ,"otherwise the argument parser gets confused." + ] } ) 60) - logging_configuration_term :: Term LoggingConfiguration logging_configuration_term = LoggingConfiguration - <$> value (flip opt ( - (optInfo ["l","log-level"]) - { optName = "LEVEL" - , optDoc = "This specifies the upper bound (inclusive) on the importance of the messages that will be logged; it must be one of (in increasing order of importance): DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, or EMERGENCY." + <$> (value . opt WARNING $ + (optInfo ["l","log-level"]) + { optName = "LEVEL" + , optDoc = "This specifies the upper bound (inclusive) on the importance of the messages that will be logged; it must be one of (in increasing order of importance): DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, or EMERGENCY." + } + ) + <*> (value . opt Nothing $ + (optInfo ["log-format"]) + { optName = "FORMAT" + , optDoc = "This specifies the format of logged messages; see the Log Formatting section for more details." + } + ) + +show_cpu_time_term :: Term Bool +show_cpu_time_term = + value . flag $ + (optInfo ["show-cpu-time"]) + { optDoc = "Print the total CPU time when the run finishes." } - ) WARNING) statistics_configuration_term :: Term StatisticsConfiguration statistics_configuration_term = - (\show_all → if show_all then const (StatisticsConfiguration True True True True True True True True True True True) else id) - <$> value (flag ((optInfo ["show-all"]) { optDoc ="This option will cause *all* run statistic to be printed to standard error after the program terminates." })) - <*> (StatisticsConfiguration - <$> value (flag ((optInfo ["show-walltimes"]) { optDoc ="This option will cause the starting, ending, and duration wall time of the run to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-supervisor-occupation"]) { optDoc ="This option will cause the supervisor occupation percentage to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-supervisor-monad-occupation"]) { optDoc ="This option will cause the supervisor monad occupation percentage to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-supervisor-calls"]) { optDoc ="This option will cause the number of supervisor calls and average time per supervisor call to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-worker-occupation"]) { optDoc ="This option will cause the worker occupation percentage to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-worker-wait-times"]) { optDoc ="This option will cause statistics about the worker wait times to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-steal-wait-times"]) { optDoc ="This option will cause statistics about the steal wait times to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-numbers-of-waiting-workers"]) { optDoc ="This option will cause statistics about the number of waiting workers to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-numbers-of-available-workloads"]) { optDoc ="This option will cause statistics about the number of available workloads to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-workload-request-rate"]) { optDoc ="This option will cause statistics about the (roughly) instantaneous rate at which workloads are requested by finished works to be printed to standard error after the program terminates." })) - <*> value (flag ((optInfo ["show-workload-steal-time"]) { optDoc ="This option will cause statistics about the (roughly) instantaneous amount of time that it took to steal a workload to be printed to standard error after the program terminates." })) + StatisticsConfiguration + <$> (value . optAll [] $ + (optInfo ["s","end-stats"]) + { optName = "STATS" + , optDoc = "A comma-separated list of statistics to be printed to stderr at the end of the run; you may alternatively specify multiple statistics by using this option multiple times. (See the Statistics section for more information.)" + } ) + <*> (value . flag $ + (optInfo ["log-end-stats"]) + { optDoc = "If present, then the end-of-run stats are sent to the log instead of stderr." + } + ) + <*> (value . optAll [] $ + (optInfo ["log-stats"]) + { optName = "STATS" + , optDoc = "A comma-separated list of statistics to be regularly logged during the run level; you may alternatively specify multiple statistics by using this option multiple times. (See the Statistics section for more information.)" + } + ) + <*> (value . opt NOTICE $ + (optInfo ["log-stats-level"]) + { optName = "STATS" + , optDoc = "The level at which to log the stats." + } + ) + <*> (value . opt 60 $ + (optInfo ["log-stats-interval"]) + { optName = "SECONDS" + , optDoc = "The time between logging statistics (in seconds, decimals allowed); it is ignored if no statistics have been enabled for logging." + } + ) maybe_workload_buffer_size_configuration_term :: Term (Maybe Int) maybe_workload_buffer_size_configuration_term = - value (opt Nothing ((optInfo ["buffer-size"]) { optName = "SIZE", optDoc = "This option sets the size of the workload buffer, which contains stolen workloads that are held at the supervisor so that if a worker needs a new workload it can be given one immediately rather than having to wait for a new workload to be stolen. This setting should be large enough that a request for a new workload can always be answered immediately using a workload from the buffer, which is roughly a function of the product of the number of workloads requested per second and the time needed to steal a new workload (both of which are server statistics than you can request to see upon completions). If you are not having problems with scaling, then you can ignore this option (it defaults to 4)." })) + value (opt Nothing ((optInfo ["buffer-size"]) + { optName = "SIZE" + , optDoc = unwords + ["This option sets the size of the workload buffer which contains" + ,"stolen workloads that are held at the supervisor so that if a" + ,"worker needs a new workload it can be given one immediately rather" + ,"than having to wait for a new workload to be stolen. This setting" + ,"should be large enough that a request for a new workload can" + ,"always be answered immediately using a workload from the buffer," + ,"which is roughly a function of the product of the number of" + ,"workloads requested per second and the time needed to steal a new" + ,"workload (both of which are server statistics than you can request" + ,"to see upon completions). If you are not having problems with" + ,"scaling, then you can ignore this option (it defaults to 4)." + ] + } + )) makeSharedConfigurationTerm :: Term tree_configuration → Term (SharedConfiguration tree_configuration) makeSharedConfigurationTerm tree_configuration_term = @@ -1102,188 +1504,121 @@ <$> logging_configuration_term <*> tree_configuration_term +------------------------------------ Loops ------------------------------------- + checkpointLoop :: ( RequestQueueMonad m , Serialize (ProgressFor (ExplorationModeFor m)) - ) ⇒ CheckpointConfiguration → m α -checkpointLoop CheckpointConfiguration{..} = forever $ do + ) ⇒ CPUTimeTracker → CheckpointConfiguration → m α +checkpointLoop tracker CheckpointConfiguration{..} = + case maybe_checkpoint_path of + Nothing → forever $ requestProgressUpdate >> delay + Just checkpoint_path → flip evalStateT False . forever $ + -- state carries around whether an alert has been issued since the + -- last problem occurred + (do join $ + liftM2 (liftIO .* writeCheckpointFile checkpoint_path) + (lift requestProgressUpdate) + (liftIO (getCurrentCPUTime tracker)) + infoM $ "Checkpoint written to " ++ show checkpoint_path + State.get >>= (flip when $ noticeM "The problem with the checkpoint has been resolved.") + State.put False + ) `catch` (\(e::SomeException) → + unless (isJust . (fromException :: SomeException → Maybe AsyncException) $ e) $ do + let message = "Failed writing checkpoint to \"" ++ checkpoint_path ++ "\" with error \"" ++ show e ++ "\"; will keep retrying in case the problem gets resolved." + ifM State.get (infoM message) (errorM message) + State.put True + ) + where + delay = liftIO . threadDelay $ amount + where + amount = round $ checkpoint_interval * 1000000 + +statisticsLoop :: RequestQueueMonad m ⇒ [[Statistic]] → Priority → Float → m α +statisticsLoop stats level interval = forever $ do liftIO $ threadDelay delay - requestProgressUpdate >>= writeCheckpointFile checkpoint_path + run_statistics ← getCurrentStatistics + liftIO $ + writeStatisticsToLog + level + pastPerfectTense + run_statistics + stats where - delay = round $ checkpoint_interval * 1000000 + delay = round $ interval * 1000000 controllerLoop :: ( RequestQueueMonad m , Serialize (ProgressFor (ExplorationModeFor m)) - ) ⇒ SupervisorConfiguration → m () -controllerLoop SupervisorConfiguration{..} = do - maybe (return ()) setWorkloadBufferSize $ maybe_workload_buffer_size_configuration - maybe_checkpoint_thread_id ← maybeForkIO checkpointLoop maybe_checkpoint_configuration - case catMaybes - [maybe_checkpoint_thread_id - ] - of [] → return () - thread_ids → liftIO $ - (forever $ threadDelay 3600000000) - `finally` - (mapM_ killThread thread_ids) + ) ⇒ IORef CPUTimeTracker → SupervisorConfiguration → m () +controllerLoop tracker_ref SupervisorConfiguration{statistics_configuration=StatisticsConfiguration{..},..} = do + tracker ← liftIO . readIORef $ tracker_ref + startCPUTimeTracker tracker + maybe (return ()) setWorkloadBufferSize maybe_workload_buffer_size_configuration + void . fork $ checkpointLoop tracker checkpoint_configuration + when (not . null $ log_stats_configuration) $ + void . fork $ statisticsLoop log_stats_configuration log_stats_level_configuration log_stats_interval_configuration -maybeForkIO :: RequestQueueMonad m ⇒ (α → m ()) → Maybe α → m (Maybe ThreadId) -maybeForkIO loop = maybe (return Nothing) (liftM Just . fork . loop) +-------------------------------- Miscellaneous --------------------------------- +default_terminfo :: TermInfo +default_terminfo = defTI { termDoc = "LogicGrowsOnTrees program" } + +dispatchToMainFunction f driver notifyTerminated tree = + f driver + (pure ()) + default_terminfo + (const notifyTerminated) + (const tree) +{-# INLINE dispatchToMainFunction #-} + +generateStatistics :: Tense → RunStatistics → [[Statistic]] → [(String,String)] +generateStatistics tense run_statistics = + map ( + statisticLongName + &&& + (\(statisticApplication → apply) → apply tense run_statistics) + ) + . + nub + . + concat + +pastPerfectTense, pastTense :: Tense +pastPerfectTense x _ = x +pastTense _ x = x + removeFileIfExists :: FilePath → IO () removeFileIfExists path = handleJust - (\e → if isDoesNotExistError e then Nothing else Just ()) + (\e → if isDoesNotExistError e then Just () else Nothing) (\_ → return ()) (removeFile path) -showStatistics :: MonadIO m ⇒ StatisticsConfiguration → RunStatistics → m () -showStatistics StatisticsConfiguration{..} RunStatistics{..} = liftIO $ do - let total_time :: Double - total_time = realToFrac runWallTime - when show_wall_times $ - hPutStrLn stderr $ - printf "Run started at %s, ended at %s, and took %sseconds.\n" - (show runStartTime) - (show runEndTime) - (showWithUnitPrefix total_time) - hPutStr stderr $ - case (show_supervisor_occupation,show_supervisor_monad_occupation) of - (True,False) → printf "Supervior was occupied for %.2f%% of the run.\n\n" (runSupervisorOccupation*100) - (False,True) → printf "Supervisor ran inside the SupervisorMonad for %.2f%% of the run.\n\n" (runSupervisorMonadOccupation*100) - (True,True) → printf "Supervior was occupied for %.2f%% of the run, of which %.2f%% was spent inside the SupervisorMonad.\n\n" (runSupervisorOccupation*100) (runSupervisorOccupation/runSupervisorMonadOccupation*100) - _ → "" - when show_supervisor_calls $ - hPutStrLn stderr $ - printf "%i calls were made into the supervisor monad, and each took an average of %sseconds.\n" - runNumberOfCalls - (showWithUnitPrefix runAverageTimePerCall) - when show_worker_occupation $ - hPutStrLn stderr $ - printf "Workers were occupied %.2f%% of the time on average.\n" - (runWorkerOccupation*100) - when show_worker_wait_times $ do - let FunctionOfTimeStatistics{..} = runWorkerWaitTimes - hPutStrLn stderr $ - if timeCount == 0 - then - "At no point did a worker receive a new workload after finishing a workload." - else - if timeMax == 0 - then - printf "Workers completed their task and obtained a new workload %i times and never had to wait to receive the new workload." - timeCount - else - printf - (unlines - ["Workers completed their task and obtained a new workload %i times with an average of one every %sseconds or %.1g enqueues/second." - ,"The minimum waiting time was %sseconds, and the maximum waiting time was %sseconds." - ,"On average, a worker had to wait %sseconds +/- %sseconds (std. dev) for a new workload." - ] - ) - timeCount - (showWithUnitPrefix $ total_time / fromIntegral timeCount) - (fromIntegral timeCount / total_time) - (showWithUnitPrefix timeMin) - (showWithUnitPrefix timeMax) - (showWithUnitPrefix timeAverage) - (showWithUnitPrefix timeStdDev) - when show_steal_wait_times $ do - let IndependentMeasurementsStatistics{..} = runStealWaitTimes - hPutStrLn stderr $ - if statCount == 0 - then - "No workloads were stolen." - else - printf - (unlines - ["Workloads were stolen %i times with an average of %sseconds between each steal or %.1g steals/second." - ,"The minimum waiting time for a steal was %sseconds, and the maximum waiting time was %sseconds." - ,"On average, it took %sseconds +/- %sseconds (std. dev) to steal a workload." - ] - ) - statCount - (showWithUnitPrefix $ total_time / fromIntegral statCount) - (fromIntegral statCount / total_time) - (showWithUnitPrefix statMin) - (showWithUnitPrefix statMax) - (showWithUnitPrefix statAverage) - (showWithUnitPrefix statStdDev) - when show_numbers_of_waiting_workers $ do - let FunctionOfTimeStatistics{..} = runWaitingWorkerStatistics - hPutStrLn stderr $ - if timeMax == 0 - then - printf "No worker ever had to wait for a workload to become available.\n" - else if timeMin == 0 - then - printf "On average, %.1f +/ - %.1f (std. dev) workers were waiting at any given time; never more than %i.\n" - timeAverage - timeStdDev - timeMax - else - printf "On average, %.1f +/ - %.1f (std. dev) workers were waiting at any given time; never more than %i nor fewer than %i.\n" - timeAverage - timeStdDev - timeMax - timeMin - when show_numbers_of_available_workloads $ do - let FunctionOfTimeStatistics{..} = runAvailableWorkloadStatistics - hPutStrLn stderr $ - if timeMax == 0 - then - printf "No workload ever had to wait for an available worker.\n" - else if timeMin == 0 - then - printf "On average, %.1f +/ - %.1f (std. dev) workloads were waiting for a worker at any given time; never more than %i.\n" - timeAverage - timeStdDev - timeMax - else - printf "On average, %.1f +/ - %.1f (std. dev) workloads were waiting for a worker at any given time; never more than %i nor fewer than %i.\n" - timeAverage - timeStdDev - timeMax - timeMin - when show_instantaneous_workload_request_rates $ do - let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadRequestRateStatistics - hPutStrLn stderr $ - printf - (unlines - ["On average, the instantanenous rate at which workloads were being requested was %.1f +/ - %.1f (std. dev) requests per second; the rate never fell below %.1f nor rose above %.1f." - ,"This value was obtained by exponentially smoothing the request data over a time scale of one second." - ] - ) - timeAverage - timeStdDev - timeMin - timeMax - when show_instantaneous_workload_steal_times $ do - let FunctionOfTimeStatistics{..} = runInstantaneousWorkloadStealTimeStatistics - hPutStrLn stderr $ - printf - (unlines - ["On average, the instantaneous time to steal a workload was %sseconds +/ - %sseconds (std. dev); this time interval never fell below %sseconds nor rose above %sseconds." - ,"This value was obtained by exponentially smoothing the request data over a time scale of one second." - ] - ) - (showWithUnitPrefix timeAverage) - (showWithUnitPrefix timeStdDev) - (showWithUnitPrefix timeMin) - (showWithUnitPrefix timeMax) +showWithUnitPrefix :: Real n ⇒ n → String +showWithUnitPrefix 0 = "0 " +showWithUnitPrefix x = printf "%.1f %s" x_scaled (unitName unit) where - showWithUnitPrefix :: Real n ⇒ n → String - showWithUnitPrefix 0 = "0 " - showWithUnitPrefix x = printf "%.1f %s" x_scaled (unitName unit) - where - (x_scaled :: Float,Just unit) = formatValue (Left FormatSiAll) . realToFrac $ x + (x_scaled :: Float,Just unit) = formatValue (Left FormatSiAll) . realToFrac $ x -writeCheckpointFile :: (Serialize ip, MonadIO m) ⇒ FilePath → ip → m () -writeCheckpointFile checkpoint_path checkpoint = do - noticeM $ "Writing checkpoint file" +writeStatisticsToLog :: Priority → Tense → RunStatistics → [[Statistic]] → IO () +writeStatisticsToLog level = + (\outputs → + unless (null outputs) $ do + logIt "=== BEGIN STATISTICS ===" + forM_ outputs $ \(name,output) → logIt (name ++ ": " ++ output) + logIt "=== END STATISTICS ===" + ) + .** + generateStatistics + where + logIt = logM "LogicGrowsOnTrees.Parallel.Main" level + +writeCheckpointFile :: (Serialize ip, MonadIO m) ⇒ FilePath → ip → NominalDiffTime → m () +writeCheckpointFile checkpoint_path checkpoint cpu_time = do + infoM $ "Writing checkpoint file" liftIO $ - (do writeFile checkpoint_temp_path (encodeLazy checkpoint) + (do writeFile checkpoint_temp_path . encodeLazy $ ProgressAndCPUTime checkpoint (toRational cpu_time) renameFile checkpoint_temp_path checkpoint_path ) `onException` ( removeFileIfExists checkpoint_temp_path diff --git a/sources/LogicGrowsOnTrees/Utils/PerfectTree.hs b/sources/LogicGrowsOnTrees/Utils/PerfectTree.hs --- a/sources/LogicGrowsOnTrees/Utils/PerfectTree.hs +++ b/sources/LogicGrowsOnTrees/Utils/PerfectTree.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnicodeSyntax #-} {-| This modules contains utility functions for constructing perfect trees for @@ -21,7 +23,10 @@ import Control.Applicative ((<$>),(<*>)) import Control.Monad (MonadPlus,msum) +import Data.Derive.Serialize +import Data.DeriveTH import Data.List (genericReplicate) +import Data.Serialize import Data.Word (Word) import System.Console.CmdTheLine @@ -39,7 +44,7 @@ {-| Newtype wrapper for arities that has an 'ArgVal' instance that enforces that the arity be at least 2. -} -newtype Arity = Arity { getArity :: Word } deriving (Eq,Show) +newtype Arity = Arity { getArity :: Word } deriving (Eq,Show,Serialize) instance ArgVal Arity where converter = (parseArity,prettyArity) @@ -64,6 +69,7 @@ { arity :: !Word , depth :: !Word } deriving (Eq, Show) +$( derive makeSerialize ''ArityAndDepth ) {-| Constructs a configuration term that expects the arity and depth to be at the given command line argument positions. diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -21,6 +21,7 @@ import Control.Exception import Control.Lens (_1,_2,(%=),(<+=),use) import Control.Monad +import qualified Control.Monad.CatchIO as CatchIO import Control.Monad.IO.Class import Control.Monad.Operational (ProgramViewT(..),view) import Control.Monad.Trans.Class (MonadTrans(..)) @@ -28,6 +29,7 @@ import Control.Monad.Trans.Writer import Data.Bits +import Data.Time.Clock (diffUTCTime,getCurrentTime) import Data.Composition ((.*)) import Data.Function import Data.Functor.Identity @@ -71,7 +73,7 @@ import Test.QuickCheck.Instances () import Test.QuickCheck.Modifiers import Test.QuickCheck.Monadic -import Test.QuickCheck.Property hiding ((.&.),(==>)) +import Test.QuickCheck.Property hiding ((.&.),(==>),abort) import Test.SmallCheck ((==>)) import Test.SmallCheck.Series (Serial(..)) import Test.SmallCheck.Drivers as Small (test) @@ -86,7 +88,7 @@ import LogicGrowsOnTrees.Parallel.Main (RunOutcome(..),TerminationReason(..)) import LogicGrowsOnTrees.Parallel.Purity import LogicGrowsOnTrees.Path -import LogicGrowsOnTrees.Parallel.Common.RequestQueue hiding (setWorkloadBufferSize) +import LogicGrowsOnTrees.Parallel.Common.RequestQueue hiding (addWorkerCountListener,setWorkloadBufferSize) import LogicGrowsOnTrees.Parallel.Common.Supervisor import LogicGrowsOnTrees.Utils.Handle (send,receive) import LogicGrowsOnTrees.Utils.PerfectTree @@ -664,22 +666,22 @@ ,testGroup "LogicGrowsOnTrees.Checkpoint" -- {{{ [testGroup "contextFromCheckpoint" -- {{{ [testProperty "cache" $ \(checkpoint :: Checkpoint) (i :: Int) → -- {{{ - checkpointFromContext (Seq.singleton (CacheContextStep (encode i))) checkpoint + checkpointFromContext [CacheContextStep (encode i)] checkpoint == (simplifyCheckpointRoot $ CachePoint (encode i) checkpoint) -- }}} ,testProperty "left branch" $ \(inner_checkpoint :: Checkpoint) (other_tree :: Tree [()]) (other_checkpoint :: Checkpoint) → -- {{{ - (checkpointFromContext (Seq.singleton (LeftBranchContextStep other_checkpoint other_tree)) inner_checkpoint) + (checkpointFromContext [LeftBranchContextStep other_checkpoint other_tree] inner_checkpoint) == (simplifyCheckpointRoot $ ChoicePoint inner_checkpoint other_checkpoint) -- }}} ,testProperty "right branch" $ \(checkpoint :: Checkpoint) → -- {{{ - checkpointFromContext (Seq.singleton RightBranchContextStep) checkpoint + checkpointFromContext [RightBranchContextStep] checkpoint == (simplifyCheckpointRoot $ ChoicePoint Explored checkpoint) -- }}} ,testProperty "empty" $ \(checkpoint :: Checkpoint) → -- {{{ - checkpointFromContext Seq.empty checkpoint == checkpoint + checkpointFromContext [] checkpoint == checkpoint -- }}} ] -- }}} @@ -1096,7 +1098,7 @@ -- }}} ] -- }}} - ,testCase "processPendingRequests" $ do + ,testCase "processPendingRequests" $ do -- {{{ mvar ← newEmptyMVar RunOutcome{..} ← Threads.exploreTreeIO (Threads.setNumberOfWorkers 2) $ let go = processPendingRequests >> liftIO (tryTakeMVar mvar) >>= maybe go return @@ -1106,10 +1108,108 @@ Completed () → return () Failure _ message → error message return () + -- }}} + ,testCase "threads are killed" $ do -- {{{ + exception_1_mvar ← newEmptyMVar + exception_2_mvar ← newEmptyMVar + _ ← Threads.exploreTree + ((do _ ← Threads.fork $ + (do Threads.setNumberOfWorkers 1 + liftIO . forever $ threadDelay 1000000 + ) + `CatchIO.catch` + (\(x::AsyncException) → liftIO $ putMVar exception_2_mvar x) + liftIO . forever $ threadDelay 1000000 + ) + `CatchIO.catch` + (\(x::AsyncException) → liftIO $ putMVar exception_1_mvar x) + ) + (return ()) + takeMVar exception_1_mvar >>= (@?= ThreadKilled) + takeMVar exception_2_mvar >>= (@?= ThreadKilled) + -- }}} ] -- }}} ,testGroup "LogicGrowsOnTrees.Parallel.Common.RequestQueue" -- {{{ - [testCase "kills all controller threads" $ do -- {{{ + [testCase "CPU time tracker" $ do -- {{{ + quit_var ← newEmptyMVar + time_1_actual_ref ← newIORef 0 + time_2_expected_ref ← newIORef 0 + time_2_actual_ref ← newIORef 0 + time_3_expected_ref ← newIORef 0 + time_3_actual_ref ← newIORef 0 + time_4_expected_ref ← newIORef 0 + time_4_actual_ref ← newIORef 0 + time_5_expected_ref ← newIORef 0 + time_5_actual_ref ← newIORef 0 + tracker ← newCPUTimeTracker 0.01 + _ ← flip Threads.exploreTreeIO (liftIO $ takeMVar quit_var) $ do + startCPUTimeTracker tracker + startCPUTimeTracker tracker + current_time_1 ← liftIO $ getCurrentTime + liftIO $ getCurrentCPUTime tracker >>= writeIORef time_1_actual_ref + + Workgroup.setNumberOfWorkers 1 + liftIO $ threadDelay 10000 + current_time_2 ← liftIO $ getCurrentTime + let diff_time_12 = current_time_2 `diffUTCTime` current_time_1 + liftIO $ do + getCurrentCPUTime tracker >>= writeIORef time_2_actual_ref + writeIORef time_2_expected_ref $ 0.01 + diff_time_12 + + Workgroup.setNumberOfWorkers 2 + liftIO $ threadDelay 30000 + current_time_3 ← liftIO $ getCurrentTime + let diff_time_23 = current_time_3 `diffUTCTime` current_time_2 + liftIO $ do + getCurrentCPUTime tracker >>= writeIORef time_3_actual_ref + writeIORef time_3_expected_ref $ 0.01 + diff_time_12 + 2*diff_time_23 + + Workgroup.setNumberOfWorkers 3 + liftIO $ threadDelay 50000 + current_time_4 ← liftIO $ getCurrentTime + let diff_time_34 = current_time_4 `diffUTCTime` current_time_3 + liftIO $ do + getCurrentCPUTime tracker >>= writeIORef time_4_actual_ref + writeIORef time_4_expected_ref $ 0.01 + diff_time_12 + 2*diff_time_23 + 3*diff_time_34 + + Workgroup.setNumberOfWorkers 1 + liftIO $ threadDelay 70000 + current_time_5 ← liftIO $ getCurrentTime + let diff_time_45 = current_time_5 `diffUTCTime` current_time_4 + liftIO $ do + getCurrentCPUTime tracker >>= writeIORef time_5_actual_ref + writeIORef time_5_expected_ref $ 0.01 + diff_time_12 + 2*diff_time_23 + 3*diff_time_34 + diff_time_45 + + abort + putMVar quit_var () + time_1_actual ← readIORef time_1_actual_ref + time_2_expected ← readIORef time_2_expected_ref + time_2_actual ← readIORef time_2_actual_ref + time_3_expected ← readIORef time_3_expected_ref + time_3_actual ← readIORef time_3_actual_ref + time_4_expected ← readIORef time_4_expected_ref + time_4_actual ← readIORef time_4_actual_ref + time_5_expected ← readIORef time_5_expected_ref + time_5_actual ← readIORef time_5_actual_ref + assertEqual + ("1: " ++ (show 1) ++ " vs. " ++ (show time_1_actual)) + 0.01 + time_1_actual + assertBool + ("2: " ++ (show time_2_expected) ++ " vs. " ++ (show time_2_actual)) + (abs (time_2_expected-time_2_actual) / (abs time_2_expected + abs time_2_actual) * 2 < 0.1) + assertBool + ("3: " ++ (show time_3_expected) ++ " vs. " ++ (show time_3_actual)) + (abs (time_3_expected-time_3_actual) / (abs time_3_expected + abs time_3_actual) * 2 < 0.01) + assertBool + ("4: " ++ (show time_4_expected) ++ " vs. " ++ (show time_4_actual)) + (abs (time_4_expected-time_4_actual) / (abs time_4_expected + abs time_4_actual) * 2 < 0.01) + assertBool + ("5: " ++ (show time_5_expected) ++ " vs. " ++ (show time_5_actual)) + (abs (time_5_expected-time_5_actual) / (abs time_5_expected + abs time_5_actual) * 2 < 0.01) + -- }}} + ,testCase "kills all controller threads" $ do -- {{{ starts@[a,b,c,d] ← replicateM 4 newEmptyMVar vars@[w,x,y,z] ← replicateM 4 newEmptyMVar request_queue ← newRequestQueue @@ -1453,6 +1553,41 @@ -- }}} ] -- }}} + ,testCase "worker count listener" $ do -- {{{ + count_1_ref ← newIORef (-1) + count_2_ref ← newIORef (-1) + _ ← runUnrestrictedSupervisor AllMode ignore_supervisor_actions $ (do + addWorkerCountListener $ writeIORef count_1_ref + liftIO $ readIORef count_1_ref >>= (@?= 0) + addWorker (0::Int) + liftIO $ readIORef count_1_ref >>= (@?= 1) + addWorkerCountListener $ writeIORef count_2_ref + liftIO $ readIORef count_2_ref >>= (@?= 1) + addWorker 1 + liftIO $ readIORef count_1_ref >>= (@?= 2) + liftIO $ readIORef count_2_ref >>= (@?= 2) + removeWorker 0 + liftIO $ readIORef count_1_ref >>= (@?= 1) + liftIO $ readIORef count_2_ref >>= (@?= 1) + addWorker 2 + liftIO $ readIORef count_1_ref >>= (@?= 2) + liftIO $ readIORef count_2_ref >>= (@?= 2) + receiveStolenWorkload 1 . Just $ + StolenWorkload + (ProgressUpdate + (Progress (ChoicePoint Unexplored Unexplored) ()) + (Workload (Seq.fromList [ChoiceStep LeftBranch]) Unexplored) + ) + (Workload (Seq.fromList [ChoiceStep RightBranch]) Unexplored) + receiveWorkerFinishedAndRemoved 1 (Progress (ChoicePoint Explored Unexplored) ()) + liftIO $ readIORef count_1_ref >>= (@?= 1) + liftIO $ readIORef count_2_ref >>= (@?= 1) + abortSupervisor + :: ∀ α. SupervisorMonad (AllMode ()) Int IO α) + readIORef count_1_ref >>= (@?= 0) + readIORef count_2_ref >>= (@?= 0) + return () + -- }}} ] -- }}} ,testGroup "LogicGrowsOnTrees.Parallel.Common.Worker" -- {{{ @@ -1808,7 +1943,7 @@ -- }}} ] -- }}} - ,testGroup "walkThroughTreeT" -- {{{ + ,testGroup "sendTreeTDownPath" -- {{{ [testCase "cache step" $ do -- {{{ let (transformed_tree,log) = runWriter . sendTreeTDownPath (Seq.singleton (CacheStep . encode $ [24 :: Int])) $ do @@ -1841,7 +1976,7 @@ -- }}} ] -- }}} - ,testProperty "LogicGrowsOnTrees.Utils.Handle" $ \(x::UUID) → morallyDubiousIOProperty $ + ,testProperty "LogicGrowsOnTrees.Utils.Handle" $ \(x::UUID) → morallyDubiousIOProperty $ -- {{{ bracket (getTemporaryDirectory >>= flip openBinaryTempFile "test-handles") (\(filepath,handle) → do @@ -1854,5 +1989,6 @@ y ← receive handle return (x == y) ) + -- }}} ] -- }}}