diff --git a/.gitignore b/.gitignore index 13a35bd..35969d0 100644 --- a/.gitignore +++ b/.gitignore @@ -8,5 +8,6 @@ cabal-dev .hsenv .cabal-sandbox/ cabal.sandbox.config +.stack-work cabal.config TAGS diff --git a/Data/Graph/Inductive/Internal/Heap.hs b/Data/Graph/Inductive/Internal/Heap.hs index 613a522..45600c3 100644 --- a/Data/Graph/Inductive/Internal/Heap.hs +++ b/Data/Graph/Inductive/Internal/Heap.hs @@ -14,18 +14,14 @@ module Data.Graph.Inductive.Internal.Heap( import Text.Show (showListWith) -#if MIN_VERSION_containers (0,4,2) import Control.DeepSeq (NFData (..)) -#endif data Heap a b = Empty | Node a b [Heap a b] deriving (Eq, Show, Read) -#if MIN_VERSION_containers (0,4,2) instance (NFData a, NFData b) => NFData (Heap a b) where rnf Empty = () rnf (Node a b hs) = rnf a `seq` rnf b `seq` rnf hs -#endif prettyHeap :: (Show a, Show b) => Heap a b -> String prettyHeap = (`showsHeap` "") diff --git a/Data/Graph/Inductive/NodeMap.hs b/Data/Graph/Inductive/NodeMap.hs index 86db233..fbd13db 100644 --- a/Data/Graph/Inductive/NodeMap.hs +++ b/Data/Graph/Inductive/NodeMap.hs @@ -34,19 +34,15 @@ import qualified Prelude as P (map) import Data.Map (Map) import qualified Data.Map as M -#if MIN_VERSION_containers (0,4,2) import Control.DeepSeq (NFData (..)) -#endif data NodeMap a = NodeMap { map :: Map a Node, key :: Int } deriving (Eq, Show, Read) -#if MIN_VERSION_containers (0,4,2) instance (NFData a) => NFData (NodeMap a) where rnf (NodeMap mp k) = rnf mp `seq` rnf k -#endif -- | Create a new, empty mapping. new :: NodeMap a diff --git a/Data/Graph/Inductive/PatriciaTree.hs b/Data/Graph/Inductive/PatriciaTree.hs index cb47f5e..f0c53fc 100644 --- a/Data/Graph/Inductive/PatriciaTree.hs +++ b/Data/Graph/Inductive/PatriciaTree.hs @@ -30,12 +30,12 @@ import Data.Graph.Inductive.Graph import Control.Applicative (liftA2) import Data.IntMap (IntMap) import qualified Data.IntMap as IM +import qualified Data.IntMap.Strict as IMS import Data.List (sort) import Data.Maybe (fromMaybe) +import Data.Foldable (foldl') -#if MIN_VERSION_containers (0,4,2) import Control.DeepSeq (NFData (..)) -#endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) @@ -115,15 +115,15 @@ instance Graph Gr where instance DynGraph Gr where (p, v, l, s) & (Gr g) - = let !g1 = IM.insert v (fromAdj p, l, fromAdj s) g - !g2 = addSucc g1 v p - !g3 = addPred g2 v s + = let !g1 = IM.insert v (preds, l, succs) g + !g2 = addSucc g1 v np preds + !g3 = addPred g2 v succs + !(np, preds) = fromAdjCounting p + !(ns, succs) = fromAdjCounting s in Gr g3 -#if MIN_VERSION_containers (0,4,2) instance (NFData a, NFData b) => NFData (Gr a b) where rnf (Gr g) = rnf g -#endif #if MIN_VERSION_base (4,8,0) instance Bifunctor Gr where @@ -144,8 +144,8 @@ matchGr node (Gr g) -> let !g1 = IM.delete node g !p' = IM.delete node p !s' = IM.delete node s - !g2 = clearPred g1 node (IM.keys s') - !g3 = clearSucc g2 node (IM.keys p') + !g2 = clearPred g1 node s' + !g3 = clearSucc g2 node p' in (Just (toAdj p', node, label, toAdj s), Gr g3) ---------------------------------------------------------------------- @@ -220,6 +220,25 @@ toAdj = concatMap expand . IM.toList fromAdj :: Adj b -> IntMap [b] fromAdj = IM.fromListWith addLists . map (second (:[]) . swap) +data FromListCounting a = FromListCounting !Int !(IntMap a) + +getFromListCounting :: FromListCounting a -> (Int, IntMap a) +getFromListCounting (FromListCounting i m) = (i, m) +{-# INLINE getFromListCounting #-} + +fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty) + where + ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t) +{-# INLINE fromListWithKeyCounting #-} + +fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y) +{-# INLINE fromListWithCounting #-} + +fromAdjCounting :: Adj b -> (Int, IntMap [b]) +fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap) + toContext :: Node -> Context' a b -> Context a b toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss) @@ -238,33 +257,33 @@ addLists [a] as = a : as addLists as [a] = a : as addLists xs ys = xs ++ ys -addSucc :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b -addSucc g _ [] = g -addSucc g v ((l, p) : rest) = addSucc g' v rest - where - g' = IM.adjust f p g - f (ps, l', ss) = (ps, l', IM.insertWith addLists v [l] ss) - +-- We use differenceWith to modify a graph more than bulkThreshold times, +-- and repeated insertWith to modify fewer times. +bulkThreshold :: Int +bulkThreshold = 5 -addPred :: GraphRep a b -> Node -> [(b, Node)] -> GraphRep a b -addPred g _ [] = g -addPred g v ((l, s) : rest) = addPred g' v rest +addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addSucc g v numAdd + | numAdd < +addSucc g v numAdd xs = IM.differenceWith go g xs where - g' = IM.adjust f s g - f (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) - + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = Just (ps, l', IM.insertWith (++) v l ss) -clearSucc :: GraphRep a b -> Node -> [Node] -> GraphRep a b -clearSucc g _ [] = g -clearSucc g v (p:rest) = clearSucc g' v rest +addPred :: forall a b . GraphRep a b -> Node -> IM.IntMap [b] -> GraphRep a b +addPred g v = IM.differenceWith go g where - g' = IM.adjust f p g - f (ps, l, ss) = (ps, l, IM.delete v ss) + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = Just (IM.insertWith (++) v l ps, l', ss) +clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearSucc g v = IM.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = Just (ps, l, IM.delete v ss) -clearPred :: GraphRep a b -> Node -> [Node] -> GraphRep a b -clearPred g _ [] = g -clearPred g v (s:rest) = clearPred g' v rest +clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearPred g v = IM.differenceWith go g where - g' = IM.adjust f s g - f (ps, l, ss) = (IM.delete v ps, l, ss) + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = Just (IM.delete v ps, l, ss) diff --git a/Data/Graph/Inductive/Tree.hs b/Data/Graph/Inductive/Tree.hs index f8f9087..979162b 100644 --- a/Data/Graph/Inductive/Tree.hs +++ b/Data/Graph/Inductive/Tree.hs @@ -19,9 +19,7 @@ import Data.Map (Map) import qualified Data.Map as M import Data.Maybe (fromMaybe) -#if MIN_VERSION_containers (0,4,2) import Control.DeepSeq (NFData (..)) -#endif #if __GLASGOW_HASKELL__ >= 702 import GHC.Generics (Generic) @@ -130,10 +128,8 @@ instance DynGraph Gr where (const (error ("Node Exception, Node: "++show v))) cntxt' = (p,l,s) -#if MIN_VERSION_containers (0,4,2) instance (NFData a, NFData b) => NFData (Gr a b) where rnf (Gr g) = rnf g -#endif #if MIN_VERSION_base (4,8,0) instance Bifunctor Gr where diff --git a/fgl.cabal b/fgl.cabal index 5ab6d5f..cd06c89 100644 --- a/fgl.cabal +++ b/fgl.cabal @@ -24,11 +24,6 @@ source-repository head type: git location: git://github.com/haskell/fgl.git -flag containers042 { - manual: False - default: True -} - library { default-language: Haskell98 @@ -69,17 +64,14 @@ library { , transformers , array - if flag(containers042) - build-depends: containers >= 0.4.2 - , deepseq >= 1.1.0.0 && < 1.5 - else - build-depends: containers < 0.4.2 + build-depends: containers >= 0.5.0 + , deepseq >= 1.1.0.0 && < 1.5 if impl(ghc >= 7.2) && impl(ghc < 7.6) build-depends: ghc-prim - ghc-options: -Wall + ghc-options: -Wall -O2 } @@ -104,6 +96,24 @@ test-suite fgl-tests { , Data.Graph.Inductive.Proxy , Data.Graph.Inductive.Query.Properties - ghc-options: -Wall + ghc-options: -Wall -O2 + +} + +benchmark fgl-benchmark { + default-language: Haskell98 + + type: exitcode-stdio-1.0 + + hs-source-dirs: test + + main-is: benchmark.hs + + build-depends: fgl + , base + , microbench + , deepseq + + ghc-options: -Wall -O2 } diff --git a/test/benchmark.hs b/test/benchmark.hs index 5102049..73e3ed0 100644 --- a/test/benchmark.hs +++ b/test/benchmark.hs @@ -1,7 +1,15 @@ {- - Install microbench to build this program: + This program should generally be run using `cabal bench` or + `stack bench`. To use `stack bench`, edit stack.yaml to include + + extra-deps: + - microbench-0.1 + + To run run benchmarks manually, install microbench from http://hackage.haskell.org/cgi-bin/hackage-scripts/package/microbench + then run + % ghc -O --make benchmark % ./benchmark [1 of 1] Compiling Main ( benchmark.hs, benchmark.o ) @@ -27,18 +35,25 @@ * emap on PATRICIA tree: ................... 4.532ns per iteration / 220663.09 per second. -} +{-# LANGUAGE ScopedTypeVariables #-} import Data.Graph.Inductive.Graph import qualified Data.Graph.Inductive.Tree as AVL import qualified Data.Graph.Inductive.PatriciaTree as Patricia import Microbench - +import Data.Foldable (foldl') +import Control.DeepSeq +import Data.Proxy main :: IO () main = do microbench "insNode into AVL tree" insNodeAVL microbench "insNode into PATRICIA tree" insNodePatricia - microbench "insEdge into AVL tree" insEdgeAVL + microbench "buildFull into PATRICIA tree 100" (buildFullPatricia 100) + microbench "buildFull into PATRICIA tree 500" (buildFullPatricia 500) + microbench "buildFull into PATRICIA tree 1000" (buildFullPatricia 1000) + +-- microbench "insEdge into AVL tree" insEdgeAVL microbench "insEdge into PATRICIA tree" insEdgePatricia microbench "gmap on AVL tree" gmapAVL @@ -47,17 +62,27 @@ main = do microbench "insNode into AVL tree" insNodeAVL microbench "nmap on AVL tree" nmapAVL microbench "nmap on PATRICIA tree" nmapPatricia - microbench "emap on AVL tree" emapAVL +-- microbench "emap on AVL tree" emapAVL microbench "emap on PATRICIA tree" emapPatricia insNodeAVL :: Int -> AVL.UGr insNodeAVL = insNodes' empty +buildFullPatricia :: Int -> Int -> () +buildFullPatricia sz i = buildFull (Proxy :: Proxy Patricia.Gr) sz i insNodePatricia :: Int -> Patricia.UGr insNodePatricia = insNodes' empty +buildFull :: forall gr proxy . (DynGraph gr, NFData (gr Int ())) => proxy gr -> Int -> Int -> () +buildFull _ sz ntimes = rnf [buildFull' i (empty :: gr Int ()) 0 sz | i <- [0..ntimes-1]] + +buildFull' :: DynGraph gr => a -> gr a () -> Int -> Int -> gr a () +buildFull' a g n limit + | n == limit = empty + | otherwise = ([((), k) | k <- [0..n-1]],n,a,[((),k) | k <- [0..n-1]]) & buildFull' a g (n + 1) limit + {-# INLINE insNodes' #-} insNodes' :: DynGraph gr => gr () b -> Int -> gr () b @@ -135,4 +160,4 @@ emapPatricia n g' = emap f g f _ = n in - g' \ No newline at end of file + g'