module LLVM.Analysis.CDG (
CDG,
HasCDG(..),
controlDependenceGraph,
directControlDependencies,
controlDependencies,
) where
import Control.Arrow ( (&&&) )
import qualified Data.Foldable as F
import Data.GraphViz
import Data.Map ( Map )
import qualified Data.Map as M
import Data.Monoid
import Data.Set ( Set )
import qualified Data.Set as S
import LLVM.Analysis
import LLVM.Analysis.CFG
import LLVM.Analysis.Dominance
class HasCDG a where
getCDG :: a -> CDG
instance HasCDG CDG where
getCDG = id
instance HasCDG PostdominatorTree where
getCDG = controlDependenceGraph
instance HasPostdomTree CDG where
getPostdomTree (CDG pdt _) = pdt
instance HasCFG CDG where
getCFG = getCFG . getPostdomTree
instance HasFunction CDG where
getFunction = getFunction . getCFG
data CDG = CDG PostdominatorTree (Map BasicBlock [BasicBlock])
controlDependenceGraph :: (HasCFG f, HasPostdomTree f) => f -> CDG
controlDependenceGraph flike =
CDG pdt $ fmap S.toList $ foldr addPairs mempty (functionBody f)
where
cfg = getCFG flike
f = getFunction cfg
pdoms = M.fromList $ postdominators pdt
pdt = getPostdomTree flike
addPairs bM acc =
foldr (addCDGEdge pdt pdoms bM) acc (basicBlockSuccessors cfg bM)
controlDependencies :: (HasCDG cdg) => cdg -> Instruction -> [Instruction]
controlDependencies cdgLike i =
go mempty (S.fromList directDeps) directDeps
where
cdg = getCDG cdgLike
directDeps = directControlDependencies cdg i
go _ acc [] = S.toList acc
go visited acc (cdep:rest)
| S.member cdep visited = go visited acc rest
| otherwise =
let newDeps = directControlDependencies cdg cdep
rest' = rest ++ newDeps
in go (S.insert cdep visited) (S.union acc (S.fromList newDeps)) rest'
directControlDependencies :: (HasCDG cdg) => cdg -> Instruction -> [Instruction]
directControlDependencies cdgLike i =
maybe [] (map basicBlockTerminatorInstruction) (M.lookup bb m)
where
CDG _ m = getCDG cdgLike
Just bb = instructionBasicBlock i
addCDGEdge :: PostdominatorTree
-> Map Instruction [Instruction]
-> BasicBlock
-> BasicBlock
-> Map BasicBlock (Set BasicBlock)
-> Map BasicBlock (Set BasicBlock)
addCDGEdge pdt pdoms bM bN acc
| postdominates pdt nEntry mTerm = acc
| otherwise = case commonAncestor mpdoms npdoms of
Just l ->
let cdepsOnM = bN : postdomBlocks (filter (/=l) npdoms)
in foldr addControlDep acc cdepsOnM
Nothing ->
let deps = bN : postdomBlocks npdoms
in foldr addControlDep acc deps
where
addControlDep b = M.insertWith S.union b (S.singleton bM)
mTerm = basicBlockTerminatorInstruction bM
nEntry : _ = basicBlockInstructions bN
Just mpdoms = M.lookup mTerm pdoms
Just npdoms = M.lookup nEntry pdoms
postdomBlocks :: [Instruction] -> [BasicBlock]
postdomBlocks = S.toList . foldr addInstBlock mempty
where
addInstBlock i acc =
let Just bb = instructionBasicBlock i
in S.insert bb acc
commonAncestor :: [Instruction] -> [Instruction] -> Maybe Instruction
commonAncestor l1 = F.find (`elem` l1)
instance ToGraphviz CDG where
toGraphviz = cdgGraphvizRepr
cdgGraphvizParams :: GraphvizParams n Instruction el BasicBlock Instruction
cdgGraphvizParams =
defaultParams { fmtNode = \(_,l) -> [ toLabel (toValue l) ]
, clusterID = Int . basicBlockUniqueId
, clusterBy = nodeCluster
, fmtCluster = formatCluster
}
where
nodeCluster l@(_, i) =
let Just bb = instructionBasicBlock i
in C bb (N l)
formatCluster bb = [GraphAttrs [toLabel (show (basicBlockName bb))]]
cdgGraphvizRepr :: CDG -> DotGraph Int
cdgGraphvizRepr cdg@(CDG _ bm) = graphElemsToDot cdgGraphvizParams ns es
where
f = getFunction cdg
ns = map (instructionUniqueId &&& id) (functionInstructions f)
es = concatMap blockEdges (functionBody f)
blockEdges bb =
case M.lookup bb bm of
Nothing -> []
Just deps ->
let depTerms = map basicBlockTerminatorInstruction deps
in concatMap (addEdges depTerms) (basicBlockInstructions bb)
addEdges depTerms i = map (addEdge i) depTerms
addEdge i dterm =
(instructionUniqueId i, instructionUniqueId dterm, ())