From ec7b4ad2b0af9947fe46a0bbc715b79939c6a754 Mon Sep 17 00:00:00 2001 From: Ward Wheeler Date: Fri, 27 Sep 2024 10:54:49 -0400 Subject: [PATCH] Adding and modifying files to compile --- PhyloWidgits.cabal | 3 - src/LocalGraph.hs | 27 ++++----- src/ParallelUtilities.hs | 123 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 137 insertions(+), 16 deletions(-) create mode 100644 src/ParallelUtilities.hs diff --git a/PhyloWidgits.cabal b/PhyloWidgits.cabal index 684d984..6e752f8 100644 --- a/PhyloWidgits.cabal +++ b/PhyloWidgits.cabal @@ -109,10 +109,7 @@ executable pruneRandGraph , fgl , graphviz , MissingH - , MonadRandom , parallel - , PHANE-evaluation - , PHANE-PhyloLib , process , text , random diff --git a/src/LocalGraph.hs b/src/LocalGraph.hs index d0fae12..932068f 100644 --- a/src/LocalGraph.hs +++ b/src/LocalGraph.hs @@ -6,8 +6,8 @@ This is for indirection so can change underlying graph library without polutting -} module LocalGraph where -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Random.Class +--import Control.Monad.IO.Class (MonadIO (..)) +--import Control.Monad.Random.Class import Control.Parallel.Strategies import Cyclic qualified as C import Data.Graph.Inductive.Basic qualified as B @@ -28,9 +28,9 @@ import Data.Text.Lazy qualified as T import Data.Vector qualified as V import GeneralUtilities import GraphFormatUtilities qualified as GFU -import PHANE.Evaluation -import PHANE.Evaluation.ErrorPhase (ErrorPhase (Computing)) -import PHANE.Evaluation.Verbosity (Verbosity (..)) +--import PHANE.Evaluation +--import PHANE.Evaluation.ErrorPhase (ErrorPhase (Computing)) +--import PHANE.Evaluation.Verbosity (Verbosity (..)) import System.IO @@ -40,7 +40,7 @@ import System.IO {- | to avoid circular dependency with Types.hs Core monad transformer stack for evaluating computations within the application PhyG. -} -type PhyG = Evaluation () +--type PhyG = Evaluation () -- | Gr local graph definition using FGL @@ -483,7 +483,7 @@ labParents inGraph inNode = {- | isPhylogeneticGraph checks various issues to see if there is wierdness in graph --} + isPhylogeneticGraph ∷ (Show a, Eq a, NFData a, Show b, Eq b) ⇒ Gr a b → PhyG Bool isPhylogeneticGraph inGraph = if isEmpty inGraph @@ -517,6 +517,7 @@ isPhylogeneticGraph inGraph = if not consistent then pure False else pure True +-} -- | removeParentsInChain checks the parents of each netowrk node are not anc/desc of each other @@ -1529,7 +1530,7 @@ getCoevalConstraintEdges inGraph inNode = (_, edgeAfterList) = nodesAndEdgesAfter inGraph [inNode] in (edgeBeforeList, edgeAfterList) - +{- -- | getGraphCoevalConstraints takes a graph and returns coeval constraints based on network nodes getGraphCoevalConstraints ∷ (Eq a, Eq b, Show a, NFData b) ⇒ Gr a b → PhyG [([LEdge b], [LEdge b])] getGraphCoevalConstraints inGraph = @@ -1571,7 +1572,7 @@ getGraphCoevalConstraintsNodes inGraph = -- let (edgeBeforeList, edgeAfterList) = unzip (PU.seqParMap PU.myStrategy (getCoevalConstraintEdges inGraph) networkNodeList) -- `using` PU.myParListChunkRDS) pure $ zip3 networkNodeList edgeBeforeList edgeAfterList - +-} {- | meetsAllCoevalConstraintsNodes checks constraint pair list and examines whether one edge is from before and one after--if so fails False else True if all pass @@ -1646,7 +1647,7 @@ notMatchEdgeIndices unlabeledEdegList labelledEdge = then False else True - +{- -- | isGraphTimeConsistent retuns False if graph fails time consistency isGraphTimeConsistent ∷ (Show a, Eq a, Eq b, NFData a) ⇒ Gr a b → PhyG Bool isGraphTimeConsistent inGraph = @@ -1668,6 +1669,7 @@ isGraphTimeConsistent inGraph = pure $ null timeOffendingEdgeList +-} {- | addBeforeAfterToPair adds before and after node list to pari of nodes for later use in time contraint edge removal @@ -2257,7 +2259,7 @@ getToFlipEdges parentNodeIndex inEdgeList = then firstEdge : getToFlipEdges parentNodeIndex (drop 1inEdgeList) else getToFlipEdges parentNodeIndex (drop 1inEdgeList) - +{- {- | Random generates display trees up to input number by choosing to keep indegree nodes > 1 unifomaly at random -} @@ -2301,8 +2303,7 @@ chooseOneDumpRest = \case [] → pure [] x : [] → pure [] x : xs → fmap NE.tail . shuffleList $ x :| xs - - +-} -- | generateDisplayTrees nice wrapper around generateDisplayTrees' with clean interface generateDisplayTrees ∷ (Eq a) ⇒ Bool → Gr a b → [Gr a b] generateDisplayTrees contractEdges inGraph = diff --git a/src/ParallelUtilities.hs b/src/ParallelUtilities.hs new file mode 100644 index 0000000..4a913a5 --- /dev/null +++ b/src/ParallelUtilities.hs @@ -0,0 +1,123 @@ +{- | +Module : ParallelUtilities.hs +Description : Utilities for parallel traversals, and other related functions +Copyright : (c) 2021 Ward C. Wheeler, Division of Invertebrate Zoology, AMNH. All rights reserved. +License : + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +The views and conclusions contained in the software and documentation are those +of the authors and should not be interpreted as representing official policies, +either expressed or implied, of the FreeBSD Project. + +Maintainer : Ward Wheeler +Stability : unstable +Portability : portable (I hope) + +-} + +{-# Language ImportQualifiedPost #-} + +{-# Options_GHC -fno-warn-orphans #-} + +module ParallelUtilities + ( parmap + , seqParMap + , getNumThreads + , rnf + , myStrategy + , myStrategyR0 + , myStrategyRS + , myStrategyRDS + , myStrategyRPAR + , myParListChunk + , myParListChunkRDS + , myChunkParMapRDS + , myStrategyHighLevel + , myStrategyLowLevel + ) where + +import Control.Concurrent +import Control.DeepSeq +import Control.Parallel.Strategies +import Data.BitVector qualified as BV +import System.IO.Unsafe + + +-- Map a function over a traversable structure in parallel +-- Preferred over parMap which is limited to lists +-- Add chunking (with arguement) (via chunkList) "fmap blah blah `using` parListChunk chunkSize rseq/rpar" +-- but would have to do one for lists (with Chunk) and one for vectors (splitAt recusively) +parmap :: Traversable t => Strategy b -> (a -> b) -> t a -> t b +parmap strat f = withStrategy (parTraversable strat).fmap f + +-- | seqParMap takes strategy, if numThread == 1 retuns fmap otherwise parmap and +seqParMap :: Traversable t => Strategy b -> (a -> b) -> t a -> t b +seqParMap strat f = + if getNumThreads > 1 then parmap strat f + else fmap f + +myParListChunk :: Strategy a -> Strategy [a] +myParListChunk = parListChunk getNumThreads + +myParListChunkRDS :: (NFData a) => Strategy [a] +myParListChunkRDS = parListChunk getNumThreads myStrategyRDS + +-- | myStrategy can be r0, rpar, rseq, rdeepseq +-- r0 seems fastest in tests of PhyG +myStrategy :: (NFData b) => Strategy b +myStrategy = r0 --rseq -- rpar -- rseq -- r0 + +myStrategyLowLevel :: (NFData b) => Strategy b +myStrategyLowLevel = r0 + +myStrategyHighLevel :: (NFData b) => Strategy b +myStrategyHighLevel = rdeepseq + +myStrategyR0 :: Strategy b +myStrategyR0 = r0 + +myStrategyRDS :: (NFData b) => Strategy b +myStrategyRDS = rdeepseq + +myStrategyRS :: Strategy b +myStrategyRS = rseq + +myStrategyRPAR :: Strategy b +myStrategyRPAR = rpar + +-- | getNumThreads gets number of COncurrent threads +{-# NOINLINE getNumThreads #-} +getNumThreads :: Int +getNumThreads = unsafePerformIO getNumCapabilities + + +-- NFData instance for parmap/rdeepseq Bit Vectory types +instance NFData BV.BV where + + rnf bv = BV.size bv `seq` BV.nat bv `seq` () + + +-- | myChunkParMapRDS chuncked parmap that defaults to fmap if not paralell +myChunkParMapRDS :: NFData c => (b -> c) -> [b] -> [c] +myChunkParMapRDS f inList = + if getNumThreads == 1 then fmap f inList + else fmap f inList `using` myParListChunkRDS