diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,15 @@ +Changes in version 0.2.0 + +* Better performance! +* Major bump because of strictness changes. +* Functions are now slightly stricter. + In the past the successor list of nodes unreachable from the root wasn't evaluated. + This is no longer the case and they will be evaluated. + Moving forward users should expect all inputs to be evaluated unless stated otherwise. +* Requires GHC >= 8.0 to build (base dependency) +* Requires containers >= 0.5 +* Exchanged the deprecated container functions with their replacements. +* Replaced a few right folds with strict left folds. +* Commented out/removed some unused code. +* Replaced mapsnd and swap with variants from base. +* Add very simplistic benchmark/test suites. diff --git a/Data/Graph/Dom.hs b/Data/Graph/Dom.hs --- a/Data/Graph/Dom.hs +++ b/Data/Graph/Dom.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} {- | Module : Data.Graph.Dom Copyright : (c) Matt Morrow 2009 License : BSD3 - Maintainer : - Stability : experimental + Maintainer : + Stability : stable Portability : portable The Lengauer-Tarjan graph dominators algorithm. @@ -19,6 +19,12 @@ \[3\] Brisk, Sarrafzadeh, /Interference Graphs for Procedures in Static Single/ /Information Form are Interval Graphs/, 2007. + + * Strictness + + Unless stated otherwise all exposed functions might fully evaluate their input + but are not guaranteed to do so. + -} module Data.Graph.Dom ( @@ -34,22 +40,24 @@ ,parents,ancestors ) where +import Data.Monoid(Monoid(..)) +import Data.Bifunctor +import Data.Tuple (swap) + import Data.Tree import Data.List -import Data.Map(Map) import Data.IntMap(IntMap) import Data.IntSet(IntSet) -import qualified Data.Map as M -import qualified Data.IntMap as IM +import qualified Data.IntMap.Strict as IM import qualified Data.IntSet as IS -import Data.Monoid(Monoid(..)) -import Control.Applicative + import Control.Monad +import Control.Monad.ST.Strict + import Data.Array.ST import Data.Array.Base (unsafeNewArray_ ,unsafeWrite,unsafeRead) -import Control.Monad.ST.Strict ----------------------------------------------------------------------------- @@ -100,7 +108,7 @@ -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)] -ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (mapsnd predG rg))) +ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) ----------------------------------------------------------------------------- @@ -338,7 +346,7 @@ fromEnv = do dom <- gets domE rn <- gets rnE - r <- gets rootE + -- r <- gets rootE (_,n) <- st (getBounds dom) forM [1..n] (\i-> do j <- st(rn!:i) @@ -364,8 +372,8 @@ sizeM = fetch sizeE sdnoM :: Node -> Dom s Int sdnoM = fetch sdnoE -dfnM :: Node -> Dom s Int -dfnM = fetch dfnE +-- dfnM :: Node -> Dom s Int +-- dfnM = fetch dfnE ndfsM :: Int -> Dom s Node ndfsM = fetch ndfsE childM :: Node -> Dom s Node @@ -408,28 +416,28 @@ newI :: Int -> ST s (Arr s Int) newI = new -newD :: Int -> ST s (Arr s Double) -newD = new +-- newD :: Int -> ST s (Arr s Double) +-- newD = new -dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] -dump a = do - (m,n) <- getBounds a - forM [m..n] (\i -> a!:i) +-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] +-- dump a = do +-- (m,n) <- getBounds a +-- forM [m..n] (\i -> a!:i) writes :: (MArray (A s) a (ST s)) => Arr s a -> [(Int,a)] -> ST s () writes a xs = forM_ xs (\(i,x) -> (a.=x) i) -arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) -arr xs = do - let n = length xs - a <- new n - go a n 0 xs - return a - where go _ _ _ [] = return () - go a n i (x:xs) - | i <= n = (a.=x) i >> go a n (i+1) xs - | otherwise = return () +-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) +-- arr xs = do +-- let n = length xs +-- a <- new n +-- go a n 0 xs +-- return a +-- where go _ _ _ [] = return () +-- go a n i (x:xs) +-- | i <= n = (a.=x) i >> go a n (i+1) xs +-- | otherwise = return () ----------------------------------------------------------------------------- @@ -437,25 +445,27 @@ (!) g n = maybe mempty id (IM.lookup n g) fromAdj :: [(Node, [Node])] -> Graph -fromAdj = IM.fromList . fmap (mapsnd IS.fromList) +fromAdj = IM.fromList . fmap (second IS.fromList) fromEdges :: [Edge] -> Graph fromEdges = collectI IS.union fst (IS.singleton . snd) toAdj :: Graph -> [(Node, [Node])] -toAdj = fmap (mapsnd IS.toList) . IM.toList +toAdj = fmap (second IS.toList) . IM.toList + +toEdges :: Graph -> [Edge] toEdges = concatMap (uncurry (fmap . (,))) . toAdj predG :: Graph -> Graph - -toEdges :: Graph -> [Edge] predG g = IM.unionWith IS.union (go g) g0 where g0 = fmap (const mempty) g - go = flip IM.foldWithKey mempty (\i a m -> - foldl' (\m p -> IM.insertWith mappend p + f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet + f m i a = foldl' (\m p -> IM.insertWith mappend p (IS.singleton i) m) m - (IS.toList a)) + (IS.toList a) + go :: IntMap IntSet -> IntMap IntSet + go = flip IM.foldlWithKey' mempty f pruneReach :: Rooted -> Rooted pruneReach (r,g) = (r,g2) @@ -463,7 +473,7 @@ (maybe mempty id . flip IM.lookup g) $ r g2 = IM.fromList - . fmap (mapsnd (IS.filter (`IS.member`is))) + . fmap (second (IS.filter (`IS.member`is))) . filter ((`IS.member`is) . fst) . IM.toList $ g @@ -505,43 +515,38 @@ (f a) (g a) m) mempty -collect :: (Ord b) => (c -> c -> c) - -> (a -> b) -> (a -> c) -> [a] -> Map b c -collect (<>) f g - = foldl' (\m a -> M.insertWith' (<>) - (f a) - (g a) m) mempty - -swap :: (a,b) -> (b,a) -swap = uncurry (flip (,)) - -mapfst :: (a -> c) -> (a,b) -> (c,b) -mapfst f = \(a,b) -> (f a, b) - -mapsnd :: (b -> c) -> (a,b) -> (a,c) -mapsnd f = \(a,b) -> (a, f b) +-- collect :: (Ord b) => (c -> c -> c) +-- -> (a -> b) -> (a -> c) -> [a] -> Map b c +-- collect (<>) f g +-- = foldl' (\m a -> SM.insertWith (<>) +-- (f a) +-- (g a) m) mempty -- (renamed, old -> new) renum :: Int -> Graph -> (Graph, NodeMap Node) renum from = (\(_,m,g)->(g,m)) - . IM.foldWithKey - (\i ss (!n,!env,!new)-> - let (j,n2,env2) = go n env i - (n3,env3,ss2) = IS.fold - (\k (!n,!env,!new)-> - case go n env k of - (l,n2,env2)-> (n2,env2,l `IS.insert` new)) - (n2,env2,mempty) ss - new2 = IM.insertWith IS.union j ss2 new - in (n3,env3,new2)) (from,mempty,mempty) - where go :: Int - -> NodeMap Node - -> Node - -> (Node,Int,NodeMap Node) - go !n !env i = - case IM.lookup i env of - Just j -> (j,n,env) - Nothing -> (n,n+1,IM.insert i n env) + . IM.foldlWithKey' + f (from,mempty,mempty) + where + f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet + -> (Int, NodeMap Node, IntMap IntSet) + f (!n,!env,!new) i ss = + let (j,n2,env2) = go n env i + (n3,env3,ss2) = IS.fold + (\k (!n,!env,!new)-> + case go n env k of + (l,n2,env2)-> (n2,env2,l `IS.insert` new)) + (n2,env2,mempty) ss + new2 = IM.insertWith IS.union j ss2 new + in (n3,env3,new2) + go :: Int + -> NodeMap Node + -> Node + -> (Node,Int,NodeMap Node) + go !n !env i = + case IM.lookup i env of + Just j -> (j,n,env) + Nothing -> (n,n+1,IM.insert i n env) ----------------------------------------------------------------------------- @@ -554,20 +559,20 @@ instance Applicative (S z s) where pure = return (<*>) = ap -get :: S z s s -get = S (\k s -> k s s) +-- get :: S z s s +-- get = S (\k s -> k s s) gets :: (s -> a) -> S z s a gets f = S (\k s -> k (f s) s) -set :: s -> S z s () -set s = S (\k _ -> k () s) +-- set :: s -> S z s () +-- set s = S (\k _ -> k () s) modify :: (s -> s) -> S z s () modify f = S (\k -> k () . f) -runS :: S z s a -> s -> ST z (a, s) -runS (S g) = g (\a s -> return (a,s)) +-- runS :: S z s a -> s -> ST z (a, s) +-- runS (S g) = g (\a s -> return (a,s)) evalS :: S z s a -> s -> ST z a evalS (S g) = g ((return .) . const) -execS :: S z s a -> s -> ST z s -execS (S g) = g ((return .) . flip const) +-- execS :: S z s a -> s -> ST z s +-- execS (S g) = g ((return .) . flip const) st :: ST z a -> S z s a st m = S (\k s-> do a <- m @@ -585,26 +590,26 @@ ----------------------------------------------------------------------------- -g0 = fromAdj - [(1,[2,3]) - ,(2,[3]) - ,(3,[4]) - ,(4,[3,5,6]) - ,(5,[7]) - ,(6,[7]) - ,(7,[4,8]) - ,(8,[3,9,10]) - ,(9,[1]) - ,(10,[7])] +-- g0 = fromAdj +-- [(1,[2,3]) +-- ,(2,[3]) +-- ,(3,[4]) +-- ,(4,[3,5,6]) +-- ,(5,[7]) +-- ,(6,[7]) +-- ,(7,[4,8]) +-- ,(8,[3,9,10]) +-- ,(9,[1]) +-- ,(10,[7])] -g1 = fromAdj - [(0,[1]) - ,(1,[2,3]) - ,(2,[7]) - ,(3,[4]) - ,(4,[5,6]) - ,(5,[7]) - ,(6,[4]) - ,(7,[])] +-- g1 = fromAdj +-- [(0,[1]) +-- ,(1,[2,3]) +-- ,(2,[7]) +-- ,(3,[4]) +-- ,(4,[5,6]) +-- ,(5,[7]) +-- ,(6,[4]) +-- ,(7,[])] ----------------------------------------------------------------------------- diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,53 @@ +module Main(main) where + +import Data.Graph.Dom +import Control.DeepSeq +import Criterion.Main + +g0 :: Rooted +g0 = (1, + fromAdj + [(1,[2,3]) + ,(2,[3]) + ,(3,[4]) + ,(4,[3,5,6]) + ,(5,[7]) + ,(6,[7]) + ,(7,[4,8]) + ,(8,[3,9,10]) + ,(9,[1]) + ,(10,[7])] + ) + +g1 :: Rooted +g1 = (0, + fromAdj + [(0,[1]) + ,(1,[2,3]) + ,(2,[7]) + ,(3,[4]) + ,(4,[5,6]) + ,(5,[7]) + ,(6,[4]) + ,(7,[])] + ) + +-- Our benchmark harness. +main :: IO () +main = g0 `deepseq` g1 `deepseq` + defaultMain [ + bgroup "g0" [ bench "dom" $ nf dom g0 + , bench "pdom" $ nf pdom g0 + , bench "idom" $ nf idom g0 + , bench "ipdom" $ nf ipdom g0 + , bench "domTree" $ nf domTree g0 + , bench "pdomTree" $ nf pdomTree g0 + ], + bgroup "g1" [ bench "dom" $ nf dom g1 + , bench "pdom" $ nf pdom g1 + , bench "idom" $ nf idom g1 + , bench "ipdom" $ nf ipdom g1 + , bench "domTree" $ nf domTree g1 + , bench "pdomTree" $ nf pdomTree g1 + ] + ] diff --git a/dom-lt.cabal b/dom-lt.cabal --- a/dom-lt.cabal +++ b/dom-lt.cabal @@ -1,23 +1,60 @@ name: dom-lt -version: 0.1.3 -cabal-version: >= 1.6 +version: 0.2.0 +cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE category: Algorithms, Graphs author: Matt Morrow copyright: (c) Matt Morrow, 2009 -maintainer: Matt Morrow -stability: experimental +maintainer: Andreas Klebinger +bug-reports: https://github.com/AndreasPK/dom-lt/issues +stability: stable synopsis: The Lengauer-Tarjan graph dominators algorithm. -description: . +description: + The Lengauer-Tarjan graph dominators algorithm. + Included are ways to compute domination and post-domination relationships. + +Extra-Source-Files: + Changelog.md + +source-repository head + type: git + location: https://github.com/AndreasPK/dom-lt + library + Default-Language: Haskell2010 includes: build-tools: extra-libraries: hs-source-dirs: . ghc-options: -O2 -funbox-strict-fields - extensions: RankNTypes - build-depends: base==4.*, array, containers + default-extensions: RankNTypes + build-depends: base >= 4.9 && < 5, array, containers >= 0.5 exposed-modules: Data.Graph.Dom + +test-suite dom-lt-tests + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + + Main-Is: Main.hs + hs-source-dirs: tests + + Build-Depends: base, dom-lt, containers + + default-extensions: + Ghc-Options: -Wall + +benchmark dom-lt-bench + Default-Language: Haskell2010 + type: exitcode-stdio-1.0 + + Main-Is: Main.hs + hs-source-dirs: benchmarks + + Build-Depends: base, dom-lt, containers, criterion >= 1.4, deepseq + default-extensions: + + Ghc-Options: -O2 -fno-full-laziness + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,61 @@ +module Main (main) where + +import Data.Graph.Dom as G +import Data.Tree +import System.Exit + +g0 :: Graph +g0 = fromAdj + [(1,[2,3]) + ,(2,[3]) + ,(3,[4]) + ,(4,[3,5,6]) + ,(5,[7]) + ,(6,[7]) + ,(7,[4,8]) + ,(8,[3,9,10]) + ,(9,[1]) + ,(10,[7])] + +g1 :: Graph +g1 = fromAdj + [(0,[1]) + ,(1,[2,3]) + ,(2,[7]) + ,(3,[4]) + ,(4,[5,6]) + ,(5,[7]) + ,(6,[4]) + ,(7,[])] + +applyDomFunctions :: Rooted + -> ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node) +applyDomFunctions g = (dom g, pdom g, idom g, ipdom g, domTree g, pdomTree g) + +g0_expected :: ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node) +g0_expected = ( + [(2,[1]),(3,[1]),(4,[3,1]),(5,[4,3,1]),(6,[4,3,1]),(7,[4,3,1]),(8,[7,4,3,1]),(9,[8,7,4,3,1]),(10,[8,7,4,3,1])], + [(9,[1]),(8,[9,1]),(7,[8,9,1]),(4,[7,8,9,1]),(5,[7,8,9,1]),(6,[7,8,9,1]),(10,[7,8,9,1]),(3,[4,7,8,9,1]),(2,[3,4,7,8,9,1])], + [(10,8),(7,4),(9,8),(1,1),(8,7),(3,1),(4,3),(6,4),(5,4),(2,1)], + [(10,7),(8,9),(9,1),(7,8),(6,7),(5,7),(4,7),(3,4),(2,3),(1,1)], + Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []},Node {rootLabel = 7, subForest = [Node {rootLabel = 8, subForest = [Node {rootLabel = 9, subForest = []},Node {rootLabel = 10, subForest = []}]}]}]}]}]}, + Node {rootLabel = 1, subForest = [Node {rootLabel = 9, subForest = [Node {rootLabel = 8, subForest = [Node {rootLabel = 7, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 3, subForest = [Node {rootLabel = 2, subForest = []}]}]},Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []},Node {rootLabel = 10, subForest = []}]}]}]}]} + ) + +g1_expected :: ([(Node, Path)], [(Node, Path)], [(Node, Node)], [(Node, Node)], Tree Node, Tree Node) +g1_expected = ( + [(1,[0]),(2,[1,0]),(3,[1,0]),(7,[1,0]),(4,[3,1,0]),(5,[4,3,1,0]),(6,[4,3,1,0])], + [],[(7,1),(6,4),(4,3),(5,4),(3,1),(2,1),(1,0),(0,0)],[(0,0)], + Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []},Node {rootLabel = 3, subForest = [Node {rootLabel = 4, subForest = [Node {rootLabel = 5, subForest = []},Node {rootLabel = 6, subForest = []}]}]}, + Node {rootLabel = 7, subForest = []}]}]},Node {rootLabel = 0, subForest = []}) + +main :: IO () +main = do + let g0_result = applyDomFunctions (1,g0) + let g1_result = applyDomFunctions (0,g1) + if g0_result == g0_expected && g1_result == g1_expected + then exitWith ExitSuccess + else exitWith $ ExitFailure 1 + + +