{-# LANGUAGE CPP, GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Compiler.Hoopl.Passes.Dominator
( Doms, DPath(..), domPath, domEntry, domLattice, extendDom
, DominatorNode(..), DominatorTree(..), tree
, immediateDominators
, domPass
)
where
import Data.Maybe
import Compiler.Hoopl
type Doms = WithBot DPath
-- ^ List of labels, extended with a standard bottom element
-- | The fact that goes into the entry of a dominator analysis: the first node
-- is dominated only by the entry point, which is represented by the empty list
-- of labels.
domEntry :: Doms
domEntry = PElem (DPath [])
newtype DPath = DPath [Label]
-- ^ represents part of the domination relation: each label
-- in a list is dominated by all its successors. This is a newtype only so
-- we can give it a fancy Show instance.
instance Show DPath where
show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls)
domPath :: Doms -> [Label]
domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry
domPath (PElem (DPath ls)) = ls
extendDom :: Label -> DPath -> DPath
extendDom l (DPath ls) = DPath (l:ls)
domLattice :: DataflowLattice Doms
domLattice = addPoints "dominators" extend
extend :: JoinFun DPath
extend _ (OldFact (DPath l)) (NewFact (DPath l')) =
(changeIf (l `lengthDiffers` j), DPath j)
where j = lcs l l'
lcs :: [Label] -> [Label] -> [Label] -- longest common suffix
lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l'
| length l < length l' = lcs l' l
| otherwise = dropUnlike l l' l
dropUnlike [] [] maybe_like = maybe_like
dropUnlike (x:xs) (y:ys) maybe_like =
dropUnlike xs ys (if x == y then maybe_like else xs)
dropUnlike _ _ _ = error "this can't happen"
lengthDiffers [] [] = False
lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys
lengthDiffers [] (_:_) = True
lengthDiffers (_:_) [] = True
-- | Dominator pass
domPass :: (NonLocal n, Monad m) => FwdPass m n Doms
domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite
where first n = fmap (extendDom $ entryLabel n)
----------------------------------------------------------------
data DominatorNode = Entry | Labelled Label
data DominatorTree = Dominates DominatorNode [DominatorTree]
-- ^ This data structure is a *rose tree* in which each node may have
-- arbitrarily many children. Each node dominates all its descendants.
-- | Map from a FactBase for dominator lists into a
-- dominator tree.
tree :: [(Label, Doms)] -> DominatorTree
tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts
-- This code has been lightly tested. The key insight is this: to
-- find lists that all have the same head, convert from a list of
-- lists to a finite map, in 'children'. Then, to convert from the
-- finite map to list of dominator trees, use the invariant that
-- each key dominates all the lists of values.
where merge lists = mapTree $ children $ filter (not . null) lists
children = foldl addList noFacts
addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]]
addList map (x:xs) = mapInsert x (xs:existing) map
where existing = fromMaybe [] $ lookupFact x map
addList _ [] = error "this can't happen"
mapTree :: FactBase [[Label]] -> [DominatorTree]
mapTree map = [Dominates (Labelled x) (merge lists) |
(x, lists) <- mapToList map]
mkList (l, doms) = l : domPath doms
instance Show DominatorTree where
show = tree2dot
-- | Given a dominator tree, produce a string representation, in the
-- input language of dot, that will enable dot to produce a
-- visualization of the tree. For more info about dot see
-- http://www.graphviz.org.
tree2dot :: DominatorTree -> String
tree2dot t = concat $ "digraph {\n" : dot t ["}\n"]
where
dot :: DominatorTree -> [String] -> [String]
dot (Dominates root trees) =
(dotnode root :) . outedges trees . flip (foldl subtree) trees
where outedges [] = id
outedges (Dominates n _ : ts) =
\s -> " " : show root : " -> " : show n : "\n" : outedges ts s
dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n"
dotnode (Labelled l) = " " ++ show l ++ "\n"
subtree = flip dot
instance Show DominatorNode where
show Entry = "entryNode"
show (Labelled l) = show l
----------------------------------------------------------------
-- | Takes FactBase from dominator analysis and returns a map from each
-- label to its immediate dominator, if any
immediateDominators :: FactBase Doms -> LabelMap Label
immediateDominators = mapFoldWithKey add mapEmpty
where add l (PElem (DPath (idom:_))) = mapInsert l idom
add _ _ = id