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