diff --git a/Control/Concurrent/ParallelTreeSearch.hs b/Control/Concurrent/ParallelTreeSearch.hs --- a/Control/Concurrent/ParallelTreeSearch.hs +++ b/Control/Concurrent/ParallelTreeSearch.hs @@ -10,26 +10,96 @@ -- This Haskell library provides an implementation of parallel search -- based on the search tree provided by the package tree-monad. -module Control.Concurrent.ParallelTreeSearch ( parallelTreeSearch ) where +module Control.Concurrent.ParallelTreeSearch ( + SearchQueue(..), SearchView(..), LIFO(..), FIFO(..), + + parallelTreeSearch + + ) where + import Control.Monad.SearchTree import Control.Concurrent +import qualified Data.Sequence as Seq -- | --- This function enumerates the results stored in a @SearchTree@ 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 :: Int -- ^ thread limit - -> Int -- ^ work limit - -> SearchTree a -- ^ search space represented as tree +-- 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 + +-- | +-- 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 + +-- | +-- A @SearchView@ is used for pattern matching a search queue. +-- +data SearchView q a = EmptyQ | SearchTree a :~ q a + +-- | +-- LIFO search queues can be used to implement parallel depth-first +-- search. +-- +newtype LIFO a = LIFO [SearchTree a] + +instance SearchQueue LIFO + 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 + +-- | +-- 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 t = +parallelTreeSearch tl wl q = do counter <- newMVar 1 channel <- newChan let env = SearchEnv tl wl counter channel - forkIO (parSearch env [] [t]) + forkIO (parSearch env [] q) xs <- getChanContents channel return (concNonEmpty xs) @@ -47,34 +117,35 @@ , threadCounter :: MVar Int , results :: Chan [a] } --- We use a queue to represent the search. Currently, we use a stack, --- but we could also use a fifo queue to obtain breadth-first search. --- -type Queue a = [SearchTree a] -parSearch :: SearchEnv a -> [a] -> Queue a -> IO () -parSearch env xs [] = do writeResults env xs - finaliseResults env -parSearch env xs q = - do noMoreThreads <- threadLimitReached env - if noMoreThreads - then let (ys,q') = search (workLimit env) xs q - in do writeResults env ys - parSearch env [] q' - else do (ys,q') <- process env [] q - parSearch env ys q' +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 if the first entry of the given queue is a +-- forks a new thread for the first entry of the given queue that is a -- choice. -- -process :: SearchEnv a -> [a] -> Queue a -> IO ([a], Queue a) -process _ xs [] = return (xs,[]) -process env xs (None : q) = process env xs q -process env xs (One x : q) = process env (x:xs) q -process env xs (Choice s t : q) = do incThreadCounter env - forkIO (parSearch env xs [s]) - return ([],t:q) +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 () @@ -94,10 +165,10 @@ then writeChan (results env) [] else putMVar (threadCounter env) (count-1) +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))) -search :: Int -> [a] -> Queue a -> ([a],Queue a) -search _ xs [] = (xs,[]) -search 0 xs q = (xs,q) -search n xs (None : q) = search (n-1) xs q -search n xs (One x : q) = search (n-1) (x:xs) q -search n xs (Choice s t : q) = search (n-1) xs (s: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.1.1 +Version: 0.2 Cabal-Version: >= 1.6 Synopsis: Parallel Tree Search Description: @@ -7,7 +7,7 @@ This Haskell library provides an implementation of parallel search based on the search tree provided by the package tree-monad. -Category: Control, Concurrent +Category: Control, Concurrency License: PublicDomain License-File: LICENSE Author: Sebastian Fischer @@ -20,7 +20,7 @@ Extra-Source-Files: README Library - Build-Depends: base, tree-monad + Build-Depends: base, tree-monad, containers Exposed-Modules: Control.Concurrent.ParallelTreeSearch Ghc-Options: -Wall