module LLVM.Analysis.CallGraph.Internal (
CallGraph(..),
CG,
CallEdge(..),
CallNode(..),
callGraph,
callGraphRepr,
callValueTargets,
callSiteTargets,
callGraphFunctions,
functionCallees,
allFunctionCallees,
functionCallers,
allFunctionCallers,
ComposableAnalysis,
callGraphSCCTraversal,
parallelCallGraphSCCTraversal,
callGraphAnalysis,
callGraphAnalysisM,
callGraphComposeAnalysis,
composableAnalysis,
composableDependencyAnalysis,
composableAnalysisM,
composableDependencyAnalysisM
) where
import Control.DeepSeq
import Control.Lens ( Getter, Lens', set, (^.) )
import Control.Monad ( foldM, replicateM )
import Control.Monad.Par.Scheds.Direct
import Data.GraphViz ( Labellable(..) )
import qualified Data.GraphViz as GV
import qualified Data.Graph.Inductive as FGL
import Data.Graph.Inductive.PatriciaTree ( Gr )
import Data.IntMap ( IntMap )
import qualified Data.IntMap as IM
import qualified Data.List as L
import Data.Maybe ( fromMaybe, mapMaybe )
import Data.Hashable
import Data.HashSet ( HashSet )
import qualified Data.HashSet as HS
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as HM
import Data.Map ( Map )
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Monoid
import LLVM.Analysis
import LLVM.Analysis.PointsTo
type CG = Gr CallNode CallEdge
data CallNode = DefinedFunction Function
| ExtFunction ExternalFunction
| UnknownFunction
deriving (Eq)
instance Show CallNode where
show (DefinedFunction v) = show $ functionName v
show (ExtFunction v) = "extern " ++ show (externalFunctionName v)
show UnknownFunction = "unknown"
instance Labellable CallNode where
toLabelValue = toLabelValue . show
data CallEdge = DirectCall
| IndirectCall
| UnknownCall
deriving (Ord, Eq)
instance Hashable CallEdge where
hashWithSalt s DirectCall = s `hashWithSalt` (1 :: Int)
hashWithSalt s IndirectCall = s `hashWithSalt` (2 :: Int)
hashWithSalt s UnknownCall = s `hashWithSalt` (3 :: Int)
instance Show CallEdge where
show DirectCall = ""
show IndirectCall = "?"
show UnknownCall = "??"
instance Labellable CallEdge where
toLabelValue = toLabelValue . show
data CallGraph = forall pta . (PointsToAnalysis pta) => CallGraph CG pta
instance ToGraphviz CallGraph where
toGraphviz = cgGraphvizRepr
callGraphFunctions :: CallGraph -> [Function]
callGraphFunctions (CallGraph cg _) =
mapMaybe extractDefinedFunction (FGL.labNodes cg)
where
extractDefinedFunction (_, DefinedFunction f) = Just f
extractDefinedFunction _ = Nothing
callGraphRepr :: CallGraph -> CG
callGraphRepr (CallGraph g _) = g
callSiteTargets :: CallGraph -> Instruction -> [Value]
callSiteTargets cg (CallInst { callFunction = f }) =
callValueTargets cg f
callSiteTargets cg (InvokeInst { invokeFunction = f}) =
callValueTargets cg f
callSiteTargets _ i =
error ("LLVM.Analysis.CallGraph.callSiteTargets: Expected a Call or Invoke instruction: " ++ show i)
callValueTargets :: CallGraph -> Value -> [Value]
callValueTargets (CallGraph _ pta) v =
let v' = stripBitcasts v
in case valueContent v' of
FunctionC _ -> [v']
ExternalFunctionC _ -> [v']
_ -> pointsTo pta v
functionCallees :: CallGraph -> Function -> [Value]
functionCallees (CallGraph g _) =
mapMaybe (toCallValue g) . FGL.suc g . functionUniqueId
allFunctionCallees :: CallGraph -> Function -> [Value]
allFunctionCallees (CallGraph g _) =
mapMaybe (toCallValue g) . flip FGL.dfs g . (:[]) . functionUniqueId
functionCallers :: CallGraph -> Function -> [Value]
functionCallers (CallGraph g _) =
mapMaybe (toCallValue g) . FGL.pre g . functionUniqueId
allFunctionCallers :: CallGraph -> Function -> [Value]
allFunctionCallers (CallGraph g _) =
mapMaybe (toCallValue g) . flip FGL.rdfs g . (:[]) . functionUniqueId
toCallValue :: CG -> Vertex -> Maybe Value
toCallValue g v = do
l <- FGL.lab g v
case l of
DefinedFunction f -> return (toValue f)
ExtFunction ef -> return (toValue ef)
_ -> Nothing
callGraph :: (PointsToAnalysis a)
=> Module
-> a
-> [Function]
-> CallGraph
callGraph m pta _ =
CallGraph (FGL.mkGraph allNodes (unique allEdges)) pta
where
allNodes = concat [ knownNodes, unknownNodes, externNodes ]
(allEdges, unknownNodes) = buildEdges pta funcs
knownNodes = map (\f -> (valueUniqueId f, DefinedFunction f)) funcs
externNodes = map mkExternFunc $ moduleExternalFunctions m
funcs = moduleDefinedFunctions m
unique :: (Hashable a, Eq a) => [a] -> [a]
unique = HS.toList . HS.fromList
type Vertex = FGL.Node
type Edge = FGL.LEdge CallEdge
unknownNodeId :: Vertex
unknownNodeId = 100
mkExternFunc :: ExternalFunction -> (Vertex, CallNode)
mkExternFunc v = (valueUniqueId v, ExtFunction v)
buildEdges :: (PointsToAnalysis a) => a -> [Function] -> ([Edge], [(Vertex, CallNode)])
buildEdges pta funcs = do
let es = map (buildFuncEdges pta) funcs
unknownNodes = [(unknownNodeId, UnknownFunction)]
(concat es, unknownNodes)
isCall :: Instruction -> Bool
isCall CallInst {} = True
isCall InvokeInst {} = True
isCall _ = False
buildFuncEdges :: (PointsToAnalysis a) => a -> Function -> [Edge]
buildFuncEdges pta f = concat es
where
insts = concatMap basicBlockInstructions $ functionBody f
calls = filter isCall insts
es = map (buildCallEdges pta f) calls
getCallee :: Instruction -> Value
getCallee CallInst { callFunction = f } = f
getCallee InvokeInst { invokeFunction = f } = f
getCallee i = error ("LLVM.Analysis.CallGraph.getCallee: Expected a function in getCallee: " ++ show i)
buildCallEdges :: (PointsToAnalysis a) => a -> Function -> Instruction -> [Edge]
buildCallEdges pta caller callInst = build' (getCallee callInst)
where
callerId = valueUniqueId caller
build' calledFunc =
case valueContent' calledFunc of
FunctionC f ->
[(callerId, valueUniqueId f, DirectCall)]
GlobalAliasC GlobalAlias { globalAliasTarget = aliasee } ->
[(callerId, valueUniqueId aliasee, DirectCall)]
ExternalFunctionC ef ->
[(callerId, valueUniqueId ef, DirectCall)]
InstructionC BitcastInst { castedValue = bcv } -> build' bcv
_ ->
let targets = resolveIndirectCall pta callInst
indirectEdges = map (\t -> (callerId, valueUniqueId t, IndirectCall)) targets
unknownEdge = (callerId, unknownNodeId, UnknownCall)
in unknownEdge : indirectEdges
cgGraphvizParams :: HashMap Int Int -> HashSet Int -> GV.GraphvizParams Int CallNode CallEdge Int CallNode
cgGraphvizParams compMap singletons =
GV.defaultParams { GV.fmtNode = \(_,l) -> [GV.toLabel l]
, GV.fmtEdge = \(_,_,l) -> [GV.toLabel l]
, GV.clusterBy = clusterByFunc
, GV.clusterID = clusterIDFunc
}
where
clusterIDFunc cid =
case cid `HS.member` singletons of
True -> GV.Str ""
False -> GV.Int cid
clusterByFunc n@(nid, _) =
let cid = HM.lookupDefault (1) nid compMap
in case cid `HS.member` singletons of
True -> GV.N n
False -> GV.C cid (GV.N n)
cgGraphvizRepr :: CallGraph -> GV.DotGraph Int
cgGraphvizRepr (CallGraph g _) =
GV.graphElemsToDot (cgGraphvizParams compMap singletons) ns es
where
ns = FGL.labNodes g
es = FGL.labEdges g
comps = zip [0..] $ FGL.scc g
singletons = HS.fromList $ map fst $ filter ((==0) . length . snd) comps
compMap = foldr assignComponent mempty comps
assignComponent :: (Int, [Int]) -> HashMap Int Int -> HashMap Int Int
assignComponent (compId, nodeIds) acc =
foldr (\nid -> HM.insert nid compId) acc nodeIds
type FunctionGraph = Gr Function ()
type SCCGraph = Gr [(Vertex, Function)] ()
data ComposableAnalysis compSumm funcLike =
forall summary m . (NFData summary, Monoid summary, Eq summary, Monad m)
=> ComposableAnalysisM { analysisUnwrap :: m summary -> summary
, analysisFunctionM :: funcLike -> summary -> m summary
, summaryLens :: Lens' compSumm summary
}
| forall summary deps m . (NFData summary, Monoid summary, Eq summary, Monad m)
=> ComposableAnalysisDM { analysisUnwrap :: m summary -> summary
, analysisFunctionDM :: deps -> funcLike -> summary -> m summary
, summaryLens :: Lens' compSumm summary
, dependencyLens :: Getter compSumm deps
}
| forall summary . (NFData summary, Monoid summary, Eq summary)
=> ComposableAnalysis { analysisFunction :: funcLike -> summary -> summary
, summaryLens :: Lens' compSumm summary
}
| forall summary deps . (NFData summary, Monoid summary, Eq summary)
=> ComposableAnalysisD { analysisFunctionD :: deps -> funcLike -> summary -> summary
, summaryLens :: Lens' compSumm summary
, dependencyLens :: Getter compSumm deps
}
callGraphSCCTraversal :: (FuncLike funcLike)
=> CallGraph
-> ([funcLike] -> summary -> summary)
-> summary
-> summary
callGraphSCCTraversal callgraph f seed =
foldr applyAnalysis seed sccList
where
cg = definedCallGraph callgraph
sccList = FGL.topsort' cg
applyAnalysis component =
f (map (fromFunction . snd) component)
definedCallGraph :: CallGraph -> SCCGraph
definedCallGraph = condense . projectDefinedFunctions . callGraphRepr
parallelCallGraphSCCTraversal :: (NFData summary, Monoid summary, FuncLike funcLike)
=> CallGraph
-> ([funcLike] -> summary -> summary)
-> summary
-> summary
parallelCallGraphSCCTraversal callgraph f seed = runPar $ do
outputVars <- replicateM (FGL.noNodes cg) new
let sccs = FGL.labNodes cg
varMap = M.fromList (zip (map fst sccs) outputVars)
sccsWithVars = map (attachVars cg varMap) sccs
rootOutVars <- foldM (forkSCC f seed) [] (force sccsWithVars)
finalVals <- mapM get rootOutVars
return $! mconcat finalVals
where
cg = definedCallGraph callgraph
attachVars :: SCCGraph -> Map Int (IVar summary) -> (Vertex, [(Vertex, Function)])
-> ([Function], [IVar summary], IVar summary, Bool)
attachVars cg varMap (nid, component) =
(map snd component, inVars, outVar, isRoot)
where
outVar = varMap M.! nid
inVars = map (getDep varMap) deps
deps = filter (/=nid) $ FGL.suc cg nid
isRoot = null (FGL.pre cg nid)
forkSCC :: (NFData summary, Monoid summary, FuncLike funcLike)
=> ([funcLike] -> summary -> summary)
-> summary
-> [IVar summary]
-> ([Function], [IVar summary], IVar summary, Bool)
-> Par [IVar summary]
forkSCC f val0 acc (component, inVars, outVar, isRoot) = do
fork $ do
depVals <- mapM get inVars
let seed = case null inVars of
True -> val0
False -> force $ mconcat depVals
funcLikes = map fromFunction component
sccSummary = f funcLikes seed
put outVar sccSummary
case isRoot of
False -> return acc
True -> return (outVar : acc)
callGraphAnalysisM :: (FuncLike funcLike, Eq summary, Monad m)
=> (m summary -> summary)
-> (funcLike -> summary -> m summary)
-> ([funcLike] -> summary -> summary)
callGraphAnalysisM unwrap analyzeFunc = f
where
f [singleFunc] summ = unwrap $ analyzeFunc singleFunc summ
f funcs summ = unwrap $ go funcs summ
go funcs summ = do
newSumm <- foldM (flip analyzeFunc) summ funcs
case newSumm == summ of
True -> return summ
False -> go funcs newSumm
callGraphAnalysis :: (FuncLike funcLike, Eq summary)
=> (funcLike -> summary -> summary)
-> ([funcLike] -> summary -> summary)
callGraphAnalysis analyzeFunc = f
where
f [singleFunc] summ = analyzeFunc singleFunc summ
f funcs summ =
let newSumm = foldr analyzeFunc summ funcs
in case newSumm == summ of
True -> summ
False -> f funcs newSumm
callGraphComposeAnalysis :: (FuncLike funcLike, Monoid compSumm, Eq compSumm)
=> [ComposableAnalysis compSumm funcLike]
-> ([funcLike] -> compSumm -> compSumm)
callGraphComposeAnalysis analyses = f
where
f funcs summ =
L.foldl' (applyAnalysisN funcs) summ analyses
applyAnalysisN funcs summ a@ComposableAnalysisM { analysisUnwrap = unwrap
, analysisFunctionM = af
, summaryLens = lns
} =
let inputSummary = summ ^. lns
res = unwrap $ foldM (flip af) inputSummary funcs
in case res == inputSummary of
True -> summ
False -> applyAnalysisN funcs (set lns res summ) a
applyAnalysisN funcs summ a@ComposableAnalysisDM { analysisUnwrap = unwrap
, analysisFunctionDM = af
, summaryLens = lns
, dependencyLens = dlns
} =
let inputSummary = summ ^. lns
deps = summ ^. dlns
af' = af deps
res = unwrap $ foldM (flip af') inputSummary funcs
in case res == inputSummary of
True -> summ
False -> applyAnalysisN funcs (set lns res summ) a
applyAnalysisN funcs summ a@ComposableAnalysis { analysisFunction = af
, summaryLens = lns
} =
let inputSummary = summ ^. lns
res = foldr af inputSummary funcs
in case res == inputSummary of
True -> summ
False -> applyAnalysisN funcs (set lns res summ) a
applyAnalysisN funcs summ a@ComposableAnalysisD { analysisFunctionD = af
, summaryLens = lns
, dependencyLens = dlns
} =
let inputSummary = summ ^. lns
deps = summ ^. dlns
res = foldr (af deps) inputSummary funcs
in case res == inputSummary of
True -> summ
False -> applyAnalysisN funcs (set lns res summ) a
composableAnalysisM :: (NFData summary, Monoid summary, Eq summary, Monad m, FuncLike funcLike)
=> (m summary -> summary)
-> (funcLike -> summary -> m summary)
-> Lens' compSumm summary
-> ComposableAnalysis compSumm funcLike
composableAnalysisM = ComposableAnalysisM
composableDependencyAnalysisM :: (NFData summary, Monoid summary, Eq summary, Monad m, FuncLike funcLike)
=> (m summary -> summary)
-> (deps -> funcLike -> summary -> m summary)
-> Lens' compSumm summary
-> Getter compSumm deps
-> ComposableAnalysis compSumm funcLike
composableDependencyAnalysisM = ComposableAnalysisDM
composableAnalysis :: (NFData summary, Monoid summary, Eq summary, FuncLike funcLike)
=> (funcLike -> summary -> summary)
-> Lens' compSumm summary
-> ComposableAnalysis compSumm funcLike
composableAnalysis = ComposableAnalysis
composableDependencyAnalysis :: (NFData summary, Monoid summary, Eq summary, FuncLike funcLike)
=> (deps -> funcLike -> summary -> summary)
-> Lens' compSumm summary
-> Getter compSumm deps
-> ComposableAnalysis compSumm funcLike
composableDependencyAnalysis = ComposableAnalysisD
projectDefinedFunctions :: CG -> FunctionGraph
projectDefinedFunctions g = FGL.mkGraph ns' es'
where
es = FGL.labEdges g
ns = FGL.labNodes g
ns' = foldr keepDefinedFunctions [] ns
es' = map (\(s, d, _) -> (s, d, ())) $ filter (edgeIsBetweenDefined m) es
m = M.fromList ns
keepDefinedFunctions :: (Vertex, CallNode)
-> [(Vertex, Function)]
-> [(Vertex, Function)]
keepDefinedFunctions (nid, DefinedFunction f) acc = (nid, f) : acc
keepDefinedFunctions _ acc = acc
edgeIsBetweenDefined :: Map Int CallNode -> Edge -> Bool
edgeIsBetweenDefined m (src, dst, _) =
nodeIsDefined m src && nodeIsDefined m dst
nodeIsDefined :: Map Int CallNode -> Int -> Bool
nodeIsDefined m n =
case M.lookup n m of
Just (DefinedFunction _) -> True
_ -> False
getDep :: Map Int c -> Int -> c
getDep m n = fromMaybe errMsg (M.lookup n m)
where
errMsg = error ("LLVM.Analysis.CallGraphSCCTraversal.getDep: Missing expected output var for node: " ++ show n)
condense :: FunctionGraph -> SCCGraph
condense gr = FGL.mkGraph ns es
where
sccIds = zip [0..] (FGL.scc gr)
nodeToSccMap = foldr buildSccIdMap mempty sccIds
ns = map (sccToNode gr) sccIds
es = S.toList $ foldr (collectEdges nodeToSccMap) mempty (FGL.edges gr)
buildSccIdMap :: (Int, [Vertex]) -> IntMap Int -> IntMap Int
buildSccIdMap (cid, ns) acc =
foldr (\n -> IM.insert n cid) acc ns
sccToNode :: (FGL.Graph gr) => gr a b -> (t, [FGL.Node]) -> (t, [FGL.LNode a])
sccToNode g (sccId, ns) = (sccId, map toNode ns)
where
toNode = FGL.labNode' . FGL.context g
collectEdges :: IntMap Vertex
-> FGL.Edge
-> S.Set (FGL.LEdge ())
-> S.Set (FGL.LEdge ())
collectEdges nodeToSccMap (s, d) !acc =
let Just s' = IM.lookup s nodeToSccMap
Just d' = IM.lookup d nodeToSccMap
in S.insert (s', d', ()) acc