module LLVM.Analysis.PointsTo.TrivialFunction (
TrivialFunction,
runPointsToAnalysis
) where
import Data.HashMap.Strict ( HashMap )
import Data.Set ( Set )
import qualified Data.HashMap.Strict as M
import qualified Data.Set as S
import LLVM.Analysis
import LLVM.Analysis.PointsTo
newtype TrivialFunction = TrivialFunction (HashMap Type (Set Value))
instance PointsToAnalysis TrivialFunction where
mayAlias = trivialMayAlias
pointsTo = trivialPointsTo
runPointsToAnalysis :: Module -> TrivialFunction
runPointsToAnalysis m = TrivialFunction finalMap
where
externMap = foldr buildMap M.empty (moduleExternalFunctions m)
finalMap = foldr buildMap externMap (moduleDefinedFunctions m)
buildMap :: (IsValue a) => a -> HashMap Type (Set Value) -> HashMap Type (Set Value)
buildMap v =
M.insertWith S.union vtype (S.singleton (toValue v))
where
vtype = valueType v
trivialMayAlias :: TrivialFunction -> Value -> Value -> Bool
trivialMayAlias _ v1 v2 = valueType v1 == valueType v2
trivialPointsTo :: TrivialFunction -> Value -> [Value]
trivialPointsTo p@(TrivialFunction m) v =
case valueContent v of
FunctionC _ -> [v]
ExternalFunctionC _ -> [v]
GlobalAliasC ga -> trivialPointsTo p (toValue ga)
InstructionC BitcastInst { castedValue = c } ->
case valueContent c of
FunctionC _ -> trivialPointsTo p c
ExternalFunctionC _ -> trivialPointsTo p c
GlobalAliasC _ -> trivialPointsTo p c
_ -> S.toList $ M.lookupDefault S.empty (derefPointer v) m
_ -> S.toList $ M.lookupDefault S.empty (derefPointer v) m
derefPointer :: Value -> Type
derefPointer v = case valueType v of
TypePointer p _ -> p
_ -> error ("LLVM.Analysis.PointsTo.TrivialPointer.derefPointer: Non-pointer type given to trivalPointsTo: " ++ show v)