module LLVM.Analysis.Dominance (
DominatorTree,
PostdominatorTree,
HasDomTree(..),
HasPostdomTree(..),
dominatorTree,
postdominatorTree,
dominates,
dominators,
dominatorsFor,
immediateDominatorFor,
immediateDominators,
postdominates,
postdominators,
postdominatorsFor,
immediatePostdominatorFor,
immediatePostdominators
) where
import Control.Arrow ( (&&&) )
import qualified Data.Graph.Inductive.Graph as G
import qualified Data.Graph.Inductive.Basic as G
import qualified Data.Graph.Inductive.PatriciaTree as G
import qualified Data.Graph.Inductive.Query.Dominators as G
import Data.IntMap ( IntMap )
import qualified Data.IntMap as IM
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Maybe ( fromMaybe )
import Data.Monoid
import Data.GraphViz
import LLVM.Analysis
import LLVM.Analysis.CFG
data DominatorTree = DT CFG (Map Instruction Instruction)
class HasDomTree a where
getDomTree :: a -> DominatorTree
instance HasDomTree DominatorTree where
getDomTree = id
instance HasDomTree CFG where
getDomTree = dominatorTree
instance HasCFG DominatorTree where
getCFG (DT cfg _) = cfg
instance HasFunction DominatorTree where
getFunction = getFunction . getCFG
dominatorTree :: (HasCFG cfg) => cfg -> DominatorTree
dominatorTree f = DT cfg idomMap
where
cfg = getCFG f
(g, revmap) = cfgToGraph cfg
idoms = G.iDom g (instructionUniqueId entryInst)
idomMap = foldr (remapInst revmap) mempty idoms
entryBlock : _ = functionBody (getFunction cfg)
entryInst : _ = basicBlockInstructions entryBlock
immediateDominatorFor :: (HasDomTree t) => t -> Instruction -> Maybe Instruction
immediateDominatorFor dt i = M.lookup i t
where
DT _ t = getDomTree dt
immediateDominators :: (HasDomTree t) => t -> [(Instruction, Instruction)]
immediateDominators dt = M.toList t
where
DT _ t = getDomTree dt
dominates :: (HasDomTree t) => t -> Instruction -> Instruction -> Bool
dominates dt n m = checkDom m
where
(DT _ t) = getDomTree dt
checkDom i
| i == n = True
| otherwise = maybe False checkDom (M.lookup i t)
dominators :: (HasDomTree t) => t -> [(Instruction, [Instruction])]
dominators pt =
zip is (map (getDominators t) is)
where
dt@(DT _ t) = getDomTree pt
f = getFunction dt
is = functionInstructions f
dominatorsFor :: (HasDomTree t) => t -> Instruction -> [Instruction]
dominatorsFor pt = getDominators t
where
DT _ t = getDomTree pt
data PostdominatorTree = PDT CFG (Map Instruction Instruction)
class HasPostdomTree a where
getPostdomTree :: a -> PostdominatorTree
instance HasPostdomTree CFG where
getPostdomTree = postdominatorTree
instance HasPostdomTree PostdominatorTree where
getPostdomTree = id
instance HasCFG PostdominatorTree where
getCFG (PDT cfg _) = cfg
instance HasFunction PostdominatorTree where
getFunction = getFunction . getCFG
postdominatorTree :: (HasCFG f) => f -> PostdominatorTree
postdominatorTree f = (PDT cfg idomMap)
where
cfg = getCFG f
(g, revmap) = cfgToGraph cfg
idoms = G.iDom (G.grev g) (1)
idomMap = foldr (remapInst revmap) mempty idoms
remapInst :: (Ord a) => IntMap a -> (Int, Int) -> Map a a -> Map a a
remapInst revmap (n, d) acc = fromMaybe acc $ do
nI <- IM.lookup n revmap
dI <- IM.lookup d revmap
return $ M.insert nI dI acc
immediatePostdominatorFor :: (HasPostdomTree t) => t -> Instruction -> Maybe Instruction
immediatePostdominatorFor pt i = M.lookup i t
where
PDT _ t = getPostdomTree pt
immediatePostdominators :: (HasPostdomTree t) => t -> [(Instruction, Instruction)]
immediatePostdominators pt = M.toList t
where
PDT _ t = getPostdomTree pt
postdominates :: (HasPostdomTree t) => t -> Instruction -> Instruction -> Bool
postdominates pdt n m = checkPDom m
where
PDT _ t = getPostdomTree pdt
checkPDom i
| i == n = True
| otherwise = maybe False checkPDom (M.lookup i t)
postdominators :: (HasPostdomTree t) => t -> [(Instruction, [Instruction])]
postdominators pt =
zip is (map (getDominators t) is)
where
pdt@(PDT _ t) = getPostdomTree pt
f = getFunction pdt
is = functionInstructions f
postdominatorsFor :: (HasPostdomTree t) => t -> Instruction -> [Instruction]
postdominatorsFor pt = getDominators t
where
PDT _ t = getPostdomTree pt
getDominators :: Map Instruction Instruction
-> Instruction
-> [Instruction]
getDominators m = go
where
go i =
case M.lookup i m of
Nothing -> []
Just dom -> dom : go dom
cfgToGraph :: CFG -> (G.Gr () (), IntMap Instruction)
cfgToGraph cfg = (G.mkGraph ns es, revMap)
where
f = getFunction cfg
blocks = functionBody f
is = functionInstructions f
revMap = foldr (\i -> IM.insert (instructionUniqueId i) i) mempty is
ns = (1, ()) : map (\i -> (instructionUniqueId i, ())) is
es = concatMap (blockEdges cfg) blocks
blockEdges :: (HasCFG cfg) => cfg -> BasicBlock -> [(UniqueId, UniqueId, ())]
blockEdges cfg b =
addSuccessorEdges internalEdges
where
mkEdge s d = (s, d, ())
is = map instructionUniqueId $ basicBlockInstructions b
ti = instructionUniqueId $ basicBlockTerminatorInstruction b
succs = map blockEntryId $ basicBlockSuccessors cfg b
internalEdges = map (\(s, d) -> mkEdge s d) (zip is (tail is))
addSuccessorEdges a
| null succs = mkEdge ti (1) : a
| otherwise = map (\sb -> mkEdge ti sb) succs ++ a
blockEntryId :: BasicBlock -> UniqueId
blockEntryId bb = instructionUniqueId ei
where
ei : _ = basicBlockInstructions bb
domTreeParams :: GraphvizParams n Instruction el () Instruction
domTreeParams =
nonClusteredParams { fmtNode = \(_, l) -> [ toLabel (toValue l) ] }
treeToGraphviz :: CFG -> Map Instruction Instruction -> DotGraph Int
treeToGraphviz cfg t = graphElemsToDot domTreeParams ns es
where
f = getFunction cfg
is = functionInstructions f
ns = map (instructionUniqueId &&& id) is
es = foldr toDomEdge [] is
toDomEdge i acc =
case M.lookup i t of
Nothing -> acc
Just d ->
(instructionUniqueId i, instructionUniqueId d, ()) : acc
instance ToGraphviz DominatorTree where
toGraphviz (DT cfg t) = treeToGraphviz cfg t
instance ToGraphviz PostdominatorTree where
toGraphviz (PDT cfg t) = treeToGraphviz cfg t