dom-lt 0.1.1 → 0.1.2

raw patch · 2 files changed

+244/−140 lines, 2 filesdep +arrayPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: array

API changes (from Hackage documentation)

Files

• Data/Graph/Dom.hs +242/−138
• dom-lt.cabal +2/−2

@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts #-}  {- |   Module      :  Data.Graph.Dom@@ -19,8 +19,6 @@     \[3\] Brisk, Sarrafzadeh,       /Interference Graphs for Procedures in Static Single/       /Information Form are Interval Graphs/, 2007.--  TODO: An ST version. -}  module Data.Graph.Dom (@@ -37,6 +35,7 @@ ) where  import Data.Tree+import Data.List import Data.Map(Map) import Data.IntMap(IntMap) import Data.IntSet(IntSet)@@ -46,7 +45,11 @@ import Data.Monoid(Monoid(..)) import Control.Applicative import Control.Monad-import Data.List+import Data.Array.ST+import Data.Array.Base+  (unsafeNewArray_+  ,unsafeWrite,unsafeRead)+import Control.Monad.ST.Strict  ----------------------------------------------------------------------------- @@ -92,21 +95,12 @@ -- using @IntMap@, it has an additional /lg |V|/ factor -- somewhere in there. I'm not sure where. idom :: Rooted -> [(Node,Node)]-idom = IM.toList-     . domE-     . execS idomM-     . initEnv-     . pruneReach+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))  -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)]-ipdom = IM.toList-      . domE-      . execS idomM-      . initEnv-      . pruneReach-      . mapsnd predG+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (mapsnd predG rg)))  ----------------------------------------------------------------------------- @@ -120,30 +114,30 @@  ----------------------------------------------------------------------------- -type Dom a = S Env a+type Dom s a = S s (Env s) a type NodeSet    = IntSet type NodeMap a  = IntMap a-data Env = Env-  {dfsE       :: !Int-  ,zeroE      :: !Node-  ,rootE      :: !Node-  ,succE      :: !Graph+data Env s = Env+  {succE      :: !Graph   ,predE      :: !Graph   ,bucketE    :: !Graph-  ,labelE     :: !(NodeMap Node)-  ,parentE    :: !(NodeMap Node)-  ,ancestorE  :: !(NodeMap Node)-  ,childE     :: !(NodeMap Node)-  ,ndfsE      :: !(IntMap  Node)-  ,dfnE       :: !(NodeMap Int)-  ,sdnoE      :: !(NodeMap Int)-  ,sizeE      :: !(NodeMap Int)-  ,domE       :: !(NodeMap Node)}-  deriving(Eq,Ord,Read,Show)+  ,dfsE       :: {-# UNPACK #-}!Int+  ,zeroE      :: {-# UNPACK #-}!Node+  ,rootE      :: {-# UNPACK #-}!Node+  ,labelE     :: {-# UNPACK #-}!(Arr s Node)+  ,parentE    :: {-# UNPACK #-}!(Arr s Node)+  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)+  ,childE     :: {-# UNPACK #-}!(Arr s Node)+  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)+  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)+  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)+  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)+  ,domE       :: {-# UNPACK #-}!(Arr s Node)+  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}  ----------------------------------------------------------------------------- -idomM :: Dom ()+idomM :: Dom s [(Node,Node)] idomM = do   dfsDom =<< rootM   n <- gets dfsE@@ -155,11 +149,11 @@       u <- eval v       su <- sdnoM u       when (su < sw)-        (modify(\e->e{sdnoE-          =IM.insert w su (sdnoE e)})))+        (store sdnoE w su))     z <- ndfsM =<< sdnoM w-    modify(\e->e{bucketE-      =IM.adjust (w`IS.insert`) z (bucketE e)})+    modify(\e->e{bucketE=IM.adjust+                      (w`IS.insert`)+                      z (bucketE e)})     pw <- parentM w     link pw w     bps <- bucketM pw@@ -170,8 +164,7 @@       let dv = case su < sv of                 True-> u                 False-> pw-      modify(\e->e{domE-        =IM.insert v dv (domE e)})))+      store domE v dv))   forM_ [1..n] (\i-> do     w <- ndfsM i     j <- sdnoM w@@ -179,12 +172,12 @@     dw <- domM w     when (dw /= z)       (do ddw <- domM dw-          modify(\e->e{domE-            =IM.insert w ddw (domE e)})))+          store domE w ddw))+  fromEnv  ----------------------------------------------------------------------------- -eval :: Node -> Dom Node+eval :: Node -> Dom s Node eval v = do   n0 <- zeroM   a  <- ancestorM v@@ -201,7 +194,7 @@         True-> return l         False-> return la -compress :: Node -> Dom ()+compress :: Node -> Dom s () compress v = do   n0  <- zeroM   a   <- ancestorM v@@ -215,14 +208,12 @@     sl  <- sdnoM l     sla <- sdnoM la     when (sla < sl)-      (modify(\e->e{labelE-        =IM.insert v la (labelE e)}))-    modify(\e->e{ancestorE-      =IM.insert v aa (ancestorE e)}))+      (store labelE v la)+    store ancestorE v aa)  ----------------------------------------------------------------------------- -link :: Node -> Node -> Dom ()+link :: Node -> Node -> Dom s () link v w = do   n0  <- zeroM   lw  <- labelM w@@ -240,124 +231,153 @@             zcc <- sizeM cc             case 2*zc <= zs+zcc of               True-> do-                modify(\e->e-                  {ancestorE=IM.insert c s (ancestorE e)-                  ,childE=IM.insert s cc (childE e)})+                store ancestorE c s+                store childE s cc                 balance s               False-> do-                modify(\e->e-                  {sizeE=IM.insert c zs (sizeE e)-                  ,ancestorE=IM.insert s c (ancestorE e)})+                store sizeE c zs+                store ancestorE s c                 balance c   s   <- balance w   lw  <- labelM w   zw  <- sizeM w-  modify(\e->e-    {labelE=IM.insert s lw (labelE e)-    ,sizeE=IM.adjust (+zw) v (sizeE e)})+  store labelE s lw+  sv <- sizeM v+  store sizeE v . (+zw) =<< sizeM v   let follow s = do         when (s /= n0) (do-          modify(\e->e{ancestorE-            =IM.insert s v (ancestorE e)})+          store ancestorE s v           follow =<< childM s)   zv  <- sizeM v   follow =<< case zv < 2*zw of               False-> return s               True-> do                 cv <- childM v-                modify(\e->e{childE-                  =IM.insert v s (childE e)})+                store childE v s                 return cv  ----------------------------------------------------------------------------- -dfsDom :: Node -> Dom ()+dfsDom :: Node -> Dom s () dfsDom i = do   _   <- go i   n0  <- zeroM   r   <- rootM-  modify(\e->e{parentE-    =IM.insert r n0 (parentE e)})+  store parentE r n0   where go i = do           n <- nextM-          modify(\e->e-            {dfnE   = IM.insert i n (dfnE e)-            ,sdnoE  = IM.insert i n (sdnoE e)-            ,ndfsE  = IM.insert n i (ndfsE e)-            ,labelE = IM.insert i i (labelE e)})+          store dfnE   i n+          store sdnoE  i n+          store ndfsE  n i+          store labelE i i           ss <- succsM i           forM_ ss (\j-> do             s <- sdnoM j             case s==0 of               False-> return()               True-> do-                modify(\e->e{parentE=-                  IM.insert j i (parentE e)})+                store parentE j i                 go j)  ----------------------------------------------------------------------------- -initEnv :: Rooted -> Env-initEnv (r,g) =-  let n = IM.size g-      ks = IM.keys g-      n0 = 1 + maximum ks-      ns = n0:ks-      doms      = IM.singleton r r-      sdno      = IM.fromList (zip ns (repeat 0))-      bucket    = IM.fromList (zip ns (repeat mempty))-      size      = IM.fromList (zip ns (0 : repeat 1))-      ancestor  = IM.fromList (zip ns (repeat n0))-      child     = ancestor-      label     = IM.singleton n0 n0+initEnv :: Rooted -> ST s (Env s)+initEnv (r0,g0) = do+  let (g,rnmap) = renum 1 g0       pred      = predG g- in Env {dfsE       = 0-        ,zeroE      = n0-        ,rootE      = r-        ,labelE     = label-        ,parentE    = mempty-        ,ancestorE  = ancestor-        ,childE     = child-        ,ndfsE      = mempty-        ,dfnE       = mempty-        ,sdnoE      = sdno-        ,sizeE      = size-        ,succE      = g-        ,predE      = pred-        ,bucketE    = bucket-        ,domE       = doms}+      r         = rnmap IM.! r0+      n         = IM.size g+      ns        = [0..n]+      m         = n+1 +  let bucket = IM.fromList+        (zip ns (repeat mempty))++  rna <- newI m+  writes rna (fmap swap+        (IM.toList rnmap))++  doms      <- newI m+  sdno      <- newI m+  size      <- newI m+  parent    <- newI m+  ancestor  <- newI m+  child     <- newI m+  label     <- newI m+  ndfs      <- newI m+  dfn       <- newI m++  forM_ [0..n] (doms.=0)+  forM_ [0..n] (sdno.=0)+  forM_ [1..n] (size.=1)+  forM_ [0..n] (ancestor.=0)+  forM_ [0..n] (child.=0)++  (doms.=r) r+  (size.=0) 0+  (label.=0) 0++  return (Env+    {rnE        = rna+    ,dfsE       = 0+    ,zeroE      = 0+    ,rootE      = r+    ,labelE     = label+    ,parentE    = parent+    ,ancestorE  = ancestor+    ,childE     = child+    ,ndfsE      = ndfs+    ,dfnE       = dfn+    ,sdnoE      = sdno+    ,sizeE      = size+    ,succE      = g+    ,predE      = pred+    ,bucketE    = bucket+    ,domE       = doms})++fromEnv :: Dom s [(Node,Node)]+fromEnv = do+  dom   <- gets domE+  rn    <- gets rnE+  r     <- gets rootE+  (_,n) <- st (getBounds dom)+  forM [1..n] (\i-> do+    j <- st(rn!:i)+    d <- st(dom!:i)+    k <- st(rn!:d)+    return (j,k))+ ----------------------------------------------------------------------------- -zeroM :: Dom Node+zeroM :: Dom s Node zeroM = gets zeroE-domM :: Node -> Dom Node-domM i = gets ((IM.!i) . domE)-rootM :: Dom Node+domM :: Node -> Dom s Node+domM = fetch domE+rootM :: Dom s Node rootM = gets rootE-succsM :: Node -> Dom [Node]+succsM :: Node -> Dom s [Node] succsM i = gets (IS.toList . (!i) . succE)-predsM :: Node -> Dom [Node]+predsM :: Node -> Dom s [Node] predsM i = gets (IS.toList . (!i) . predE)-bucketM :: Node -> Dom [Node]+bucketM :: Node -> Dom s [Node] bucketM i = gets (IS.toList . (!i) . bucketE)-sizeM :: Node -> Dom Int-sizeM i = gets ((IM.!i) . sizeE)-sdnoM :: Node -> Dom Int-sdnoM i = gets ((IM.!i) . sdnoE)-dfnM :: Node -> Dom Int-dfnM i = gets ((IM.!i) . dfnE)-ndfsM :: Int -> Dom Node-ndfsM i = gets ((IM.!i) . ndfsE)-childM :: Node -> Dom Node-childM i = gets ((IM.!i) . childE)-ancestorM :: Node -> Dom Node-ancestorM i = gets ((IM.!i) . ancestorE)-parentM :: Node -> Dom Node-parentM i = gets ((IM.!i) . parentE)-labelM :: Node -> Dom Node-labelM i = gets ((IM.!i) . labelE)-nextM :: Dom Int+sizeM :: Node -> Dom s Int+sizeM = fetch sizeE+sdnoM :: Node -> Dom s Int+sdnoM = fetch sdnoE+dfnM :: Node -> Dom s Int+dfnM = fetch dfnE+ndfsM :: Int -> Dom s Node+ndfsM = fetch ndfsE+childM :: Node -> Dom s Node+childM = fetch childE+ancestorM :: Node -> Dom s Node+ancestorM = fetch ancestorE+parentM :: Node -> Dom s Node+parentM = fetch parentE+labelM :: Node -> Dom s Node+labelM = fetch labelE+nextM :: Dom s Int nextM = do   n <- gets dfsE   let n' = n+1@@ -366,6 +386,54 @@  ----------------------------------------------------------------------------- +type A = STUArray+type Arr s a = A s Int a++infixl 9 !:+infixr 2 .=++(.=) :: (MArray (A s) a (ST s))+     => Arr s a -> a -> Int -> ST s ()+(v .= x) i = unsafeWrite v i x++(!:) :: (MArray (A s) a (ST s))+     => A s Int a -> Int -> ST s a+a !: i = do+  o <- unsafeRead a i+  return $! o++new :: (MArray (A s) a (ST s))+    => Int -> ST s (Arr s a)+new n = unsafeNewArray_ (0,n-1)++newI :: Int -> ST s (Arr s Int)+newI = 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)++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 ()++-----------------------------------------------------------------------------+ (!) :: Monoid a => IntMap a -> Int -> a (!) g n = maybe mempty id (IM.lookup n g) @@ -377,11 +445,11 @@  toAdj :: Graph -> [(Node, [Node])] toAdj = fmap (mapsnd 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 ->@@ -454,31 +522,67 @@ mapsnd :: (b -> c) -> (a,b) -> (a,c) mapsnd f = \(a,b) -> (a, f b) +-- (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)+ ----------------------------------------------------------------------------- -newtype S s a = S {unS :: forall o. (a -> s -> o) -> s -> o}-instance Functor (S s) where+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}+instance Functor (S z s) where   fmap f (S g) = S (\k -> g (k . f))-instance Monad (S s) where+instance Monad (S z s) where   return a = S (\k -> k a)   S g >>= f = S (\k -> g (\a -> unS (f a) k))-instance Applicative (S s) where+instance Applicative (S z s) where   pure = return   (<*>) = ap-get :: S s s+get :: S z s s get = S (\k s -> k s s)-gets :: (s -> a) -> S s a+gets :: (s -> a) -> S z s a gets f = S (\k s -> k (f s) s)-set :: s -> S s ()+set :: s -> S z s () set s = S (\k _ -> k () s)-modify :: (s -> s) -> S s ()+modify :: (s -> s) -> S z s () modify f = S (\k -> k () . f)-runS :: S s a -> s -> (a, s)-runS (S g) = g (,)-evalS :: S s a -> s -> a-evalS (S g) = g const-execS :: S s a -> s -> s-execS (S g) = g (flip const)+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)+st :: ST z a -> S z s a+st m = S (\k s-> do+  a <- m+  k a s)+store :: (MArray (A z) a (ST z))+      => (s -> Arr z a) -> Int -> a -> S z s ()+store f i x = do+  a <- gets f+  st ((a.=x) i)+fetch :: (MArray (A z) a (ST z))+      => (s -> Arr z a) -> Int -> S z s a+fetch f i = do+  a <- gets f+  st (a!:i)  ----------------------------------------------------------------------------- 

@@ -1,5 +1,5 @@ name:               dom-lt
-version:            0.1.1
+version:            0.1.2
 cabal-version:      >= 1.6
 build-type:         Simple
 license:            BSD3
@@ -19,5 +19,5 @@   hs-source-dirs:   .
   ghc-options:      -O2
   extensions:       RankNTypes
-  build-depends:    base==4.*, containers
+  build-depends:    base==4.*, array, containers
   exposed-modules:  Data.Graph.Dom