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