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)