[Haskell-cafe] Parallel term reduction

[John D. Ramsdell]

I have a reduction system in which a rule takes a term and returns a
set of terms.
The reduction system creates a tree that originates at a starting
value called the root.
For most problems, the reduction system terminates, but a step count
limit protects
from non-termination.  Rule application is expensive, so it is
essential that a rule is
never applied to the same problem twice.  This check makes my program
sequential,
in that parallel annotations don't improve performance on SMPs.  There
isn't even an
obvious place to add them in my program, at least not to me.  How do
people write
parallel reduction systems that avoid redundant rule application?

John

> module Main (main) where

> import System.Time (ClockTime(..), getClockTime

> data Eq a => Item a
>     = Item { item :: a,
>              parent :: Maybe (Item a) }

> instance Eq a => Eq (Item a) where
>     x == y = item x == item y

The reduction system takes a rule, a step count, and an initial value,
and computes a tree of reductions.  The order of the items in the returned
list is irrelevant, because the tree is assembled as a post processing step.

> reduce :: (Eq a, Monad m) => (a -> [a]) -> Int -> a -> m [Item a]
> reduce rule limit root =
>     step rule limit [top] [top]
>     where
>      top = Item { item = root, parent = Nothing }

step rule limit seen todo, where seen in the items already seen, and todo
is the items on the queue.

> step :: (Eq a, Monad m) => (a -> [a]) -> Int ->
>         [Item a] -> [Item a] -> m [Item a]
> step _ limit _ _
>     | limit <= 0 = fail "Step limit exceeded"
> step _ _ seen [] = return seen
> step rule limit seen (next : rest) =
>     loop seen rest children
>     where
>      children = map child (rule (item next))
>      child i = Item { item = i, parent = Just next }
>      loop seen rest [] =
>          step rule (limit - 1) seen rest
>      loop seen rest (kid : kids) =
>          if elem kid seen then
>             loop seen rest kids
>          else
>             loop (kid : seen) (rest ++ [kid]) kids

A silly rule

> rule :: Int -> [Int]
> rule n = filter (>= 0) [n - 1, n - 2, n - 3]

> secDiff :: ClockTime -> ClockTime -> Float
> secDiff (TOD secs1 psecs1) (TOD secs2 psecs2)
>     = fromInteger (psecs2 - psecs1) / 1e12 + fromInteger (secs2 - secs1)

> main :: IO ()
> main =
>     do
>       t0 <- getClockTime
>       ns <- reduce rule 20000 5000
>       t1 <- getClockTime
>       putStrLn $ "length: " ++ show (length ns)
>       putStrLn $ "time: " ++ show (secDiff t0 t1) ++ " seconds"

The makefile
------------
PROG	= reduce
GHCFLAGS = -Wall -fno-warn-name-shadowing -O

%:	%.lhs
	ghc $(GHCFLAGS) -o $@ $<

all:	$(PROG)

clean:
	-rm *.o *.hi $(PROG)