diff --git a/Control/Concurrent/ParallelTreeSearch.hs b/Control/Concurrent/ParallelTreeSearch.hs --- a/Control/Concurrent/ParallelTreeSearch.hs +++ b/Control/Concurrent/ParallelTreeSearch.hs @@ -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))) diff --git a/parallel-tree-search.cabal b/parallel-tree-search.cabal --- a/parallel-tree-search.cabal +++ b/parallel-tree-search.cabal @@ -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