parallel-tree-search 0.2.1 → 0.3
raw patch · 2 files changed
+28/−177 lines, 2 files
Files
Control/Concurrent/ParallelTreeSearch.hs view
@@ -9,187 +9,38 @@ -- -- This Haskell library provides an implementation of parallel search -- based on the search tree provided by the package tree-monad.--module Control.Concurrent.ParallelTreeSearch ( -- SearchQueue(..), SearchView(..), LIFO(..), FIFO(..), -- parallelDFS, parallelBFS, parallelTreeSearch-- ) where--import Control.Monad.SearchTree-import Control.Concurrent-import qualified Data.Sequence as Seq---- |--- Search queues store multiple search trees. -- -class SearchQueue q- where- -- | Constructs an empty search queue.- emptyQ :: q a-- -- | Adds a search tree to asearch queue.- addQ :: SearchTree a -> q a -> q a-- -- | creates a view on a search queue for pattern matching.- viewQ :: q a -> SearchView q a+module Control.Concurrent.ParallelTreeSearch ( parallelTreeSearch ) where --- |--- Checks whether the given search queue is empty.--- -isEmptyQ :: SearchQueue q => q a -> Bool-{-# SPECIALISE INLINE isEmptyQ :: LIFO a -> Bool #-}-{-# SPECIALISE INLINE isEmptyQ :: FIFO a -> Bool #-}-isEmptyQ q = case viewQ q of EmptyQ -> True; _ -> False+import Control.Monad+import Control.Monad.SearchTree --- |--- A @SearchView@ is used for pattern matching a search queue.--- -data SearchView q a = EmptyQ | SearchTree a :~ q a+import Control.Concurrent --- | --- LIFO search queues can be used to implement parallel depth-first--- search.--- -newtype LIFO a = LIFO [SearchTree a]+-- | Enumerate the leaves of a @SearchTree@ in parallel.+parallelTreeSearch :: Int -- ^ number of threads to use+ -> SearchTree a -- ^ tree to search+ -> IO [a] -- ^ lazy list of leaves+parallelTreeSearch threadCount tree =+ do ctr <- newMVar 1+ res <- newChan+ queue <- newChan+ writeChan queue tree+ sequence (replicate threadCount (forkIO (search ctr res queue)))+ liftM (foldr (\mx xs -> maybe [] (:xs) mx) []) (getChanContents res) -instance SearchQueue LIFO+search :: MVar Int -> Chan (Maybe a) -> Chan (SearchTree a) -> IO ()+search ctr res queue = process =<< readChan queue where- {-# SPECIALISE instance SearchQueue LIFO #-}-- emptyQ = LIFO []-- addQ t (LIFO q) = LIFO (t:q)-- viewQ (LIFO []) = EmptyQ- viewQ (LIFO (x:xs)) = x :~ LIFO xs---- | --- FIFO search queues can be used to implement parallel breadth-first--- search.--- -newtype FIFO a = FIFO (Seq.Seq (SearchTree a))--instance SearchQueue FIFO- where - {-# SPECIALISE instance SearchQueue FIFO #-}-- emptyQ = FIFO Seq.empty-- addQ t (FIFO q) = FIFO (q Seq.|> t)-- viewQ (FIFO q) = case Seq.viewl q of- Seq.EmptyL -> EmptyQ- x Seq.:< xs -> x :~ FIFO xs---- |--- Enumerate the leaves of a search tree concurrently in depth-first--- order.--- -parallelDFS :: Int -- ^ thread limit- -> Int -- ^ work limit- -> SearchTree a -- ^ tree to search- -> IO [a]-parallelDFS tl wl t = parallelTreeSearch tl wl (LIFO [t])---- |--- Enumerate the leaves of a search tree concurrently in breadth-first--- order.--- -parallelBFS :: Int -- ^ thread limit- -> Int -- ^ work limit- -> SearchTree a -- ^ tree to search- -> IO [a]-parallelBFS tl wl t = parallelTreeSearch tl wl (FIFO (Seq.singleton t))----- |--- This function enumerates the results stored in the queue of--- @SearchTree@s in parallel. It is parameterised by the maximum--- number of threads to use and the maximum amount of work to perform--- by each thread before communicating the results.--- -parallelTreeSearch :: SearchQueue q- => Int -- ^ thread limit- -> Int -- ^ work limit- -> q a -- ^ queue with search trees- -> IO [a]-parallelTreeSearch tl wl q =- do counter <- newMVar 1- channel <- newChan- let env = SearchEnv tl wl counter channel- forkIO (parSearch env [] q)- xs <- getChanContents channel- return (concNonEmpty xs)---- like concat, but stops on empty list.----concNonEmpty :: [[a]] -> [a]-concNonEmpty [] = []-concNonEmpty ([]:_) = []-concNonEmpty (xs:xss) = xs ++ concNonEmpty xss---- Environment passed to the parallel search algorithm.----data SearchEnv a = SearchEnv { threadLimit :: Int- , workLimit :: Int- , threadCounter :: MVar Int- , results :: Chan [a] }---parSearch :: SearchQueue q => SearchEnv a -> [a] -> q a -> IO ()-parSearch env xs q - | isEmptyQ q = do writeResults env xs- finaliseResults env- | otherwise = do noMoreThreads <- threadLimitReached env- if noMoreThreads- then let (ys,q') = search (workLimit env) xs (viewQ q)- in do writeResults env ys- parSearch env [] q'- else do (ys,q') <- process env [] (viewQ q)- parSearch env ys q'---- forks a new thread for the first entry of the given queue that is a--- choice.----process :: SearchQueue q- => SearchEnv a -> [a] -> SearchView q a -> IO ([a], q a)-process _ xs EmptyQ = return (xs,emptyQ)-process env xs (None :~ q) = process env xs (viewQ q)-process env xs (One x :~ q) = process env (x:xs) (viewQ q)-process env xs (Choice s t :~ q) =- do incThreadCounter env- forkIO (parSearch env xs (addQ s (emptyQ `withTypeOf` q)))- return ([], addQ t q)--withTypeOf :: a -> a -> a-withTypeOf = const---- auxiliary functions--writeResults :: SearchEnv a -> [a] -> IO ()-writeResults _ [] = return ()-writeResults env xs = writeChan (results env) xs--incThreadCounter :: SearchEnv a -> IO ()-incThreadCounter env = modifyMVar_ (threadCounter env) (return.(+1))--threadLimitReached :: SearchEnv a -> IO Bool-threadLimitReached env = do count <- readMVar (threadCounter env)- return (count >= threadLimit env)+ process None = finished+ process (One x) = do writeChan res (Just x); finished+ process (Choice l r) = do modifyMVar_ ctr (return.succ)+ writeChan queue l+ writeChan queue r+ search ctr res queue -finaliseResults :: SearchEnv a -> IO ()-finaliseResults env = do count <- takeMVar (threadCounter env)- if count <= 1- then writeChan (results env) []- else putMVar (threadCounter env) (count-1)+ finished = do count <- modifyMVar ctr ((\n -> return (n,n)).pred)+ if count == 0 then writeChan res Nothing+ else search ctr res queue -search :: SearchQueue q => Int -> [a] -> SearchView q a -> ([a],q a)-search _ xs EmptyQ = (xs,emptyQ)-search 0 xs (t :~ q) = (xs,addQ t q)-search n xs (None :~ q) = search (n-1) xs (viewQ q)-search n xs (One x :~ q) = search (n-1) (x:xs) (viewQ q)-search n xs (Choice s t :~ q) = search (n-1) xs (viewQ (addQ s (addQ t q)))
parallel-tree-search.cabal view
@@ -1,5 +1,5 @@ Name: parallel-tree-search-Version: 0.2.1+Version: 0.3 Cabal-Version: >= 1.6 Synopsis: Parallel Tree Search Description: @@ -11,7 +11,7 @@ License: PublicDomain License-File: LICENSE Author: Fabian Reck, Sebastian Fischer-Maintainer: sebf@informatik.uni-kiel.de+Maintainer: Sebastian Fischer Bug-Reports: mailto:sebf@informatik.uni-kiel.de Homepage: http://github.com/sebfisch/parallel-tree-search Build-Type: Simple