1{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-} 2 3{- | 4 Module : Dominators 5 Copyright : (c) Matt Morrow 2009 6 License : BSD3 7 Maintainer : <morrow@moonpatio.com> 8 Stability : experimental 9 Portability : portable 10 11 Taken from the dom-lt package. 12 13 The Lengauer-Tarjan graph dominators algorithm. 14 15 \[1\] Lengauer, Tarjan, 16 /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979. 17 18 \[2\] Muchnick, 19 /Advanced Compiler Design and Implementation/, 1997. 20 21 \[3\] Brisk, Sarrafzadeh, 22 /Interference Graphs for Procedures in Static Single/ 23 /Information Form are Interval Graphs/, 2007. 24 25 Originally taken from the dom-lt package. 26-} 27 28module Dominators ( 29 Node,Path,Edge 30 ,Graph,Rooted 31 ,idom,ipdom 32 ,domTree,pdomTree 33 ,dom,pdom 34 ,pddfs,rpddfs 35 ,fromAdj,fromEdges 36 ,toAdj,toEdges 37 ,asTree,asGraph 38 ,parents,ancestors 39) where 40 41import GhcPrelude 42 43import Data.Bifunctor 44import Data.Tuple (swap) 45 46import Data.Tree 47import Data.IntMap(IntMap) 48import Data.IntSet(IntSet) 49import qualified Data.IntMap.Strict as IM 50import qualified Data.IntSet as IS 51 52import Control.Monad 53import Control.Monad.ST.Strict 54 55import Data.Array.ST 56import Data.Array.Base hiding ((!)) 57 -- (unsafeNewArray_ 58 -- ,unsafeWrite,unsafeRead 59 -- ,readArray,writeArray) 60 61import Util (debugIsOn) 62 63----------------------------------------------------------------------------- 64 65type Node = Int 66type Path = [Node] 67type Edge = (Node,Node) 68type Graph = IntMap IntSet 69type Rooted = (Node, Graph) 70 71----------------------------------------------------------------------------- 72 73-- | /Dominators/. 74-- Complexity as for @idom@ 75dom :: Rooted -> [(Node, Path)] 76dom = ancestors . domTree 77 78-- | /Post-dominators/. 79-- Complexity as for @idom@. 80pdom :: Rooted -> [(Node, Path)] 81pdom = ancestors . pdomTree 82 83-- | /Dominator tree/. 84-- Complexity as for @idom@. 85domTree :: Rooted -> Tree Node 86domTree a@(r,_) = 87 let is = filter ((/=r).fst) (idom a) 88 tg = fromEdges (fmap swap is) 89 in asTree (r,tg) 90 91-- | /Post-dominator tree/. 92-- Complexity as for @idom@. 93pdomTree :: Rooted -> Tree Node 94pdomTree a@(r,_) = 95 let is = filter ((/=r).fst) (ipdom a) 96 tg = fromEdges (fmap swap is) 97 in asTree (r,tg) 98 99-- | /Immediate dominators/. 100-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is 101-- \"a functional inverse of Ackermann's function\". 102-- 103-- This Complexity bound assumes /O(1)/ indexing. Since we're 104-- using @IntMap@, it has an additional /lg |V|/ factor 105-- somewhere in there. I'm not sure where. 106idom :: Rooted -> [(Node,Node)] 107idom rg = runST (evalS idomM =<< initEnv (pruneReach rg)) 108 109-- | /Immediate post-dominators/. 110-- Complexity as for @idom@. 111ipdom :: Rooted -> [(Node,Node)] 112ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg))) 113 114----------------------------------------------------------------------------- 115 116-- | /Post-dominated depth-first search/. 117pddfs :: Rooted -> [Node] 118pddfs = reverse . rpddfs 119 120-- | /Reverse post-dominated depth-first search/. 121rpddfs :: Rooted -> [Node] 122rpddfs = concat . levels . pdomTree 123 124----------------------------------------------------------------------------- 125 126type Dom s a = S s (Env s) a 127type NodeSet = IntSet 128type NodeMap a = IntMap a 129data Env s = Env 130 {succE :: !Graph 131 ,predE :: !Graph 132 ,bucketE :: !Graph 133 ,dfsE :: {-# UNPACK #-}!Int 134 ,zeroE :: {-# UNPACK #-}!Node 135 ,rootE :: {-# UNPACK #-}!Node 136 ,labelE :: {-# UNPACK #-}!(Arr s Node) 137 ,parentE :: {-# UNPACK #-}!(Arr s Node) 138 ,ancestorE :: {-# UNPACK #-}!(Arr s Node) 139 ,childE :: {-# UNPACK #-}!(Arr s Node) 140 ,ndfsE :: {-# UNPACK #-}!(Arr s Node) 141 ,dfnE :: {-# UNPACK #-}!(Arr s Int) 142 ,sdnoE :: {-# UNPACK #-}!(Arr s Int) 143 ,sizeE :: {-# UNPACK #-}!(Arr s Int) 144 ,domE :: {-# UNPACK #-}!(Arr s Node) 145 ,rnE :: {-# UNPACK #-}!(Arr s Node)} 146 147----------------------------------------------------------------------------- 148 149idomM :: Dom s [(Node,Node)] 150idomM = do 151 dfsDom =<< rootM 152 n <- gets dfsE 153 forM_ [n,n-1..1] (\i-> do 154 w <- ndfsM i 155 sw <- sdnoM w 156 ps <- predsM w 157 forM_ ps (\v-> do 158 u <- eval v 159 su <- sdnoM u 160 when (su < sw) 161 (store sdnoE w su)) 162 z <- ndfsM =<< sdnoM w 163 modify(\e->e{bucketE=IM.adjust 164 (w`IS.insert`) 165 z (bucketE e)}) 166 pw <- parentM w 167 link pw w 168 bps <- bucketM pw 169 forM_ bps (\v-> do 170 u <- eval v 171 su <- sdnoM u 172 sv <- sdnoM v 173 let dv = case su < sv of 174 True-> u 175 False-> pw 176 store domE v dv)) 177 forM_ [1..n] (\i-> do 178 w <- ndfsM i 179 j <- sdnoM w 180 z <- ndfsM j 181 dw <- domM w 182 when (dw /= z) 183 (do ddw <- domM dw 184 store domE w ddw)) 185 fromEnv 186 187----------------------------------------------------------------------------- 188 189eval :: Node -> Dom s Node 190eval v = do 191 n0 <- zeroM 192 a <- ancestorM v 193 case a==n0 of 194 True-> labelM v 195 False-> do 196 compress v 197 a <- ancestorM v 198 l <- labelM v 199 la <- labelM a 200 sl <- sdnoM l 201 sla <- sdnoM la 202 case sl <= sla of 203 True-> return l 204 False-> return la 205 206compress :: Node -> Dom s () 207compress v = do 208 n0 <- zeroM 209 a <- ancestorM v 210 aa <- ancestorM a 211 when (aa /= n0) (do 212 compress a 213 a <- ancestorM v 214 aa <- ancestorM a 215 l <- labelM v 216 la <- labelM a 217 sl <- sdnoM l 218 sla <- sdnoM la 219 when (sla < sl) 220 (store labelE v la) 221 store ancestorE v aa) 222 223----------------------------------------------------------------------------- 224 225link :: Node -> Node -> Dom s () 226link v w = do 227 n0 <- zeroM 228 lw <- labelM w 229 slw <- sdnoM lw 230 let balance s = do 231 c <- childM s 232 lc <- labelM c 233 slc <- sdnoM lc 234 case slw < slc of 235 False-> return s 236 True-> do 237 zs <- sizeM s 238 zc <- sizeM c 239 cc <- childM c 240 zcc <- sizeM cc 241 case 2*zc <= zs+zcc of 242 True-> do 243 store ancestorE c s 244 store childE s cc 245 balance s 246 False-> do 247 store sizeE c zs 248 store ancestorE s c 249 balance c 250 s <- balance w 251 lw <- labelM w 252 zw <- sizeM w 253 store labelE s lw 254 store sizeE v . (+zw) =<< sizeM v 255 let follow s = do 256 when (s /= n0) (do 257 store ancestorE s v 258 follow =<< childM s) 259 zv <- sizeM v 260 follow =<< case zv < 2*zw of 261 False-> return s 262 True-> do 263 cv <- childM v 264 store childE v s 265 return cv 266 267----------------------------------------------------------------------------- 268 269dfsDom :: Node -> Dom s () 270dfsDom i = do 271 _ <- go i 272 n0 <- zeroM 273 r <- rootM 274 store parentE r n0 275 where go i = do 276 n <- nextM 277 store dfnE i n 278 store sdnoE i n 279 store ndfsE n i 280 store labelE i i 281 ss <- succsM i 282 forM_ ss (\j-> do 283 s <- sdnoM j 284 case s==0 of 285 False-> return() 286 True-> do 287 store parentE j i 288 go j) 289 290----------------------------------------------------------------------------- 291 292initEnv :: Rooted -> ST s (Env s) 293initEnv (r0,g0) = do 294 let (g,rnmap) = renum 1 g0 295 pred = predG g 296 r = rnmap IM.! r0 297 n = IM.size g 298 ns = [0..n] 299 m = n+1 300 301 let bucket = IM.fromList 302 (zip ns (repeat mempty)) 303 304 rna <- newI m 305 writes rna (fmap swap 306 (IM.toList rnmap)) 307 308 doms <- newI m 309 sdno <- newI m 310 size <- newI m 311 parent <- newI m 312 ancestor <- newI m 313 child <- newI m 314 label <- newI m 315 ndfs <- newI m 316 dfn <- newI m 317 318 forM_ [0..n] (doms.=0) 319 forM_ [0..n] (sdno.=0) 320 forM_ [1..n] (size.=1) 321 forM_ [0..n] (ancestor.=0) 322 forM_ [0..n] (child.=0) 323 324 (doms.=r) r 325 (size.=0) 0 326 (label.=0) 0 327 328 return (Env 329 {rnE = rna 330 ,dfsE = 0 331 ,zeroE = 0 332 ,rootE = r 333 ,labelE = label 334 ,parentE = parent 335 ,ancestorE = ancestor 336 ,childE = child 337 ,ndfsE = ndfs 338 ,dfnE = dfn 339 ,sdnoE = sdno 340 ,sizeE = size 341 ,succE = g 342 ,predE = pred 343 ,bucketE = bucket 344 ,domE = doms}) 345 346fromEnv :: Dom s [(Node,Node)] 347fromEnv = do 348 dom <- gets domE 349 rn <- gets rnE 350 -- r <- gets rootE 351 (_,n) <- st (getBounds dom) 352 forM [1..n] (\i-> do 353 j <- st(rn!:i) 354 d <- st(dom!:i) 355 k <- st(rn!:d) 356 return (j,k)) 357 358----------------------------------------------------------------------------- 359 360zeroM :: Dom s Node 361zeroM = gets zeroE 362domM :: Node -> Dom s Node 363domM = fetch domE 364rootM :: Dom s Node 365rootM = gets rootE 366succsM :: Node -> Dom s [Node] 367succsM i = gets (IS.toList . (! i) . succE) 368predsM :: Node -> Dom s [Node] 369predsM i = gets (IS.toList . (! i) . predE) 370bucketM :: Node -> Dom s [Node] 371bucketM i = gets (IS.toList . (! i) . bucketE) 372sizeM :: Node -> Dom s Int 373sizeM = fetch sizeE 374sdnoM :: Node -> Dom s Int 375sdnoM = fetch sdnoE 376-- dfnM :: Node -> Dom s Int 377-- dfnM = fetch dfnE 378ndfsM :: Int -> Dom s Node 379ndfsM = fetch ndfsE 380childM :: Node -> Dom s Node 381childM = fetch childE 382ancestorM :: Node -> Dom s Node 383ancestorM = fetch ancestorE 384parentM :: Node -> Dom s Node 385parentM = fetch parentE 386labelM :: Node -> Dom s Node 387labelM = fetch labelE 388nextM :: Dom s Int 389nextM = do 390 n <- gets dfsE 391 let n' = n+1 392 modify(\e->e{dfsE=n'}) 393 return n' 394 395----------------------------------------------------------------------------- 396 397type A = STUArray 398type Arr s a = A s Int a 399 400infixl 9 !: 401infixr 2 .= 402 403(.=) :: (MArray (A s) a (ST s)) 404 => Arr s a -> a -> Int -> ST s () 405(v .= x) i 406 | debugIsOn = writeArray v i x 407 | otherwise = unsafeWrite v i x 408 409(!:) :: (MArray (A s) a (ST s)) 410 => A s Int a -> Int -> ST s a 411a !: i 412 | debugIsOn = do 413 o <- readArray a i 414 return $! o 415 | otherwise = do 416 o <- unsafeRead a i 417 return $! o 418 419new :: (MArray (A s) a (ST s)) 420 => Int -> ST s (Arr s a) 421new n = unsafeNewArray_ (0,n-1) 422 423newI :: Int -> ST s (Arr s Int) 424newI = new 425 426-- newD :: Int -> ST s (Arr s Double) 427-- newD = new 428 429-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a] 430-- dump a = do 431-- (m,n) <- getBounds a 432-- forM [m..n] (\i -> a!:i) 433 434writes :: (MArray (A s) a (ST s)) 435 => Arr s a -> [(Int,a)] -> ST s () 436writes a xs = forM_ xs (\(i,x) -> (a.=x) i) 437 438-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a) 439-- arr xs = do 440-- let n = length xs 441-- a <- new n 442-- go a n 0 xs 443-- return a 444-- where go _ _ _ [] = return () 445-- go a n i (x:xs) 446-- | i <= n = (a.=x) i >> go a n (i+1) xs 447-- | otherwise = return () 448 449----------------------------------------------------------------------------- 450 451(!) :: Monoid a => IntMap a -> Int -> a 452(!) g n = maybe mempty id (IM.lookup n g) 453 454fromAdj :: [(Node, [Node])] -> Graph 455fromAdj = IM.fromList . fmap (second IS.fromList) 456 457fromEdges :: [Edge] -> Graph 458fromEdges = collectI IS.union fst (IS.singleton . snd) 459 460toAdj :: Graph -> [(Node, [Node])] 461toAdj = fmap (second IS.toList) . IM.toList 462 463toEdges :: Graph -> [Edge] 464toEdges = concatMap (uncurry (fmap . (,))) . toAdj 465 466predG :: Graph -> Graph 467predG g = IM.unionWith IS.union (go g) g0 468 where g0 = fmap (const mempty) g 469 f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet 470 f m i a = foldl' (\m p -> IM.insertWith mappend p 471 (IS.singleton i) m) 472 m 473 (IS.toList a) 474 go :: IntMap IntSet -> IntMap IntSet 475 go = flip IM.foldlWithKey' mempty f 476 477pruneReach :: Rooted -> Rooted 478pruneReach (r,g) = (r,g2) 479 where is = reachable 480 (maybe mempty id 481 . flip IM.lookup g) $ r 482 g2 = IM.fromList 483 . fmap (second (IS.filter (`IS.member`is))) 484 . filter ((`IS.member`is) . fst) 485 . IM.toList $ g 486 487tip :: Tree a -> (a, [Tree a]) 488tip (Node a ts) = (a, ts) 489 490parents :: Tree a -> [(a, a)] 491parents (Node i xs) = p i xs 492 ++ concatMap parents xs 493 where p i = fmap (flip (,) i . rootLabel) 494 495ancestors :: Tree a -> [(a, [a])] 496ancestors = go [] 497 where go acc (Node i xs) 498 = let acc' = i:acc 499 in p acc' xs ++ concatMap (go acc') xs 500 p is = fmap (flip (,) is . rootLabel) 501 502asGraph :: Tree Node -> Rooted 503asGraph t@(Node a _) = let g = go t in (a, fromAdj g) 504 where go (Node a ts) = let as = (fst . unzip . fmap tip) ts 505 in (a, as) : concatMap go ts 506 507asTree :: Rooted -> Tree Node 508asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a)) 509 f = (g !) 510 in go r 511 512reachable :: (Node -> NodeSet) -> (Node -> NodeSet) 513reachable f a = go (IS.singleton a) a 514 where go seen a = let s = f a 515 as = IS.toList (s `IS.difference` seen) 516 in foldl' go (s `IS.union` seen) as 517 518collectI :: (c -> c -> c) 519 -> (a -> Int) -> (a -> c) -> [a] -> IntMap c 520collectI (<>) f g 521 = foldl' (\m a -> IM.insertWith (<>) 522 (f a) 523 (g a) m) mempty 524 525-- collect :: (Ord b) => (c -> c -> c) 526-- -> (a -> b) -> (a -> c) -> [a] -> Map b c 527-- collect (<>) f g 528-- = foldl' (\m a -> SM.insertWith (<>) 529-- (f a) 530-- (g a) m) mempty 531 532-- (renamed, old -> new) 533renum :: Int -> Graph -> (Graph, NodeMap Node) 534renum from = (\(_,m,g)->(g,m)) 535 . IM.foldlWithKey' 536 f (from,mempty,mempty) 537 where 538 f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet 539 -> (Int, NodeMap Node, IntMap IntSet) 540 f (!n,!env,!new) i ss = 541 let (j,n2,env2) = go n env i 542 (n3,env3,ss2) = IS.fold 543 (\k (!n,!env,!new)-> 544 case go n env k of 545 (l,n2,env2)-> (n2,env2,l `IS.insert` new)) 546 (n2,env2,mempty) ss 547 new2 = IM.insertWith IS.union j ss2 new 548 in (n3,env3,new2) 549 go :: Int 550 -> NodeMap Node 551 -> Node 552 -> (Node,Int,NodeMap Node) 553 go !n !env i = 554 case IM.lookup i env of 555 Just j -> (j,n,env) 556 Nothing -> (n,n+1,IM.insert i n env) 557 558----------------------------------------------------------------------------- 559 560newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} 561instance Functor (S z s) where 562 fmap f (S g) = S (\k -> g (k . f)) 563instance Monad (S z s) where 564 return = pure 565 S g >>= f = S (\k -> g (\a -> unS (f a) k)) 566instance Applicative (S z s) where 567 pure a = S (\k -> k a) 568 (<*>) = ap 569-- get :: S z s s 570-- get = S (\k s -> k s s) 571gets :: (s -> a) -> S z s a 572gets f = S (\k s -> k (f s) s) 573-- set :: s -> S z s () 574-- set s = S (\k _ -> k () s) 575modify :: (s -> s) -> S z s () 576modify f = S (\k -> k () . f) 577-- runS :: S z s a -> s -> ST z (a, s) 578-- runS (S g) = g (\a s -> return (a,s)) 579evalS :: S z s a -> s -> ST z a 580evalS (S g) = g ((return .) . const) 581-- execS :: S z s a -> s -> ST z s 582-- execS (S g) = g ((return .) . flip const) 583st :: ST z a -> S z s a 584st m = S (\k s-> do 585 a <- m 586 k a s) 587store :: (MArray (A z) a (ST z)) 588 => (s -> Arr z a) -> Int -> a -> S z s () 589store f i x = do 590 a <- gets f 591 st ((a.=x) i) 592fetch :: (MArray (A z) a (ST z)) 593 => (s -> Arr z a) -> Int -> S z s a 594fetch f i = do 595 a <- gets f 596 st (a!:i) 597 598