module LLVM.Analysis.AccessPath (
AccessPath(..),
accessPathComponents,
AbstractAccessPath(..),
abstractAccessPathComponents,
AccessType(..),
AccessPathError(..),
accessPath,
abstractAccessPath,
appendAccessPath,
followAccessPath,
reduceAccessPath,
externalizeAccessPath
) where
import Control.DeepSeq
import Control.Exception
import Control.Failure hiding ( failure )
import qualified Control.Failure as F
import Data.Hashable
import qualified Data.List as L
import qualified Data.Text as T
import Data.Typeable
import Text.PrettyPrint.GenericPretty
import LLVM.Analysis
data AccessPathError = NoPathError Value
| NotMemoryInstruction Instruction
| CannotFollowPath AbstractAccessPath Value
| BaseTypeMismatch Type Type
| NonConstantInPath AbstractAccessPath Value
| EndpointTypeMismatch Type Type
| IrreducableAccessPath AbstractAccessPath
| CannotExternalizeType Type
deriving (Typeable, Show)
instance Exception AccessPathError
data AbstractAccessPath =
AbstractAccessPath { abstractAccessPathBaseType :: Type
, abstractAccessPathEndType :: Type
, abstractAccessPathTaggedComponents :: [(Type, AccessType)]
}
deriving (Eq, Ord, Generic)
abstractAccessPathComponents :: AbstractAccessPath -> [AccessType]
abstractAccessPathComponents = map snd . abstractAccessPathTaggedComponents
instance Out AbstractAccessPath
instance Show AbstractAccessPath where
show = pretty
instance Hashable AbstractAccessPath where
hashWithSalt s (AbstractAccessPath bt et cs) =
s `hashWithSalt` bt `hashWithSalt` et `hashWithSalt` cs
appendAccessPath :: (Failure AccessPathError m)
=> AbstractAccessPath
-> AbstractAccessPath
-> m AbstractAccessPath
appendAccessPath (AbstractAccessPath bt1 et1 cs1) (AbstractAccessPath bt2 et2 cs2) =
case et1 == bt2 of
True -> return $ AbstractAccessPath bt1 et2 (cs1 ++ cs2)
False -> F.failure $ EndpointTypeMismatch et1 bt2
reduceAccessPath :: (Failure AccessPathError m)
=> AbstractAccessPath -> m AbstractAccessPath
reduceAccessPath (AbstractAccessPath (TypePointer t _) et ((_, AccessDeref):cs)) =
return $! AbstractAccessPath t et cs
reduceAccessPath p@(AbstractAccessPath (TypeStruct _ ts _) et ((_,AccessField fldNo):cs)) =
case fldNo < length ts of
True -> return $! AbstractAccessPath (ts !! fldNo) et cs
False -> F.failure $ IrreducableAccessPath p
reduceAccessPath (AbstractAccessPath (TypeArray _ t) et ((_,AccessArray):cs)) =
return $! AbstractAccessPath t et cs
reduceAccessPath p = F.failure $ IrreducableAccessPath p
instance NFData AbstractAccessPath where
rnf a@(AbstractAccessPath _ _ ts) = ts `deepseq` a `seq` ()
data AccessPath =
AccessPath { accessPathBaseValue :: Value
, accessPathBaseType :: Type
, accessPathEndType :: Type
, accessPathTaggedComponents :: [(Type, AccessType)]
}
deriving (Generic, Eq, Ord)
accessPathComponents :: AccessPath -> [AccessType]
accessPathComponents = map snd . accessPathTaggedComponents
instance Out AccessPath
instance Show AccessPath where
show = pretty
instance NFData AccessPath where
rnf a@(AccessPath _ _ _ ts) = ts `deepseq` a `seq` ()
instance Hashable AccessPath where
hashWithSalt s (AccessPath bv bt ev cs) =
s `hashWithSalt` bv `hashWithSalt` bt `hashWithSalt` ev `hashWithSalt` cs
data AccessType = AccessField !Int
| AccessUnion
| AccessArray
| AccessDeref
deriving (Read, Show, Eq, Ord, Generic)
instance Out AccessType
instance NFData AccessType where
rnf a@(AccessField i) = i `seq` a `seq` ()
rnf _ = ()
instance Hashable AccessType where
hashWithSalt s (AccessField ix) =
s `hashWithSalt` (1 :: Int) `hashWithSalt` ix
hashWithSalt s AccessUnion = s `hashWithSalt` (154 :: Int)
hashWithSalt s AccessArray = s `hashWithSalt` (26 :: Int)
hashWithSalt s AccessDeref = s `hashWithSalt` (300 :: Int)
followAccessPath :: (Failure AccessPathError m) => AbstractAccessPath -> Value -> m Value
followAccessPath aap@(AbstractAccessPath bt _ components) val =
case derefPointerType bt /= valueType val of
True -> F.failure (BaseTypeMismatch bt (valueType val))
False -> walk components val
where
walk [] v = return v
walk ((_, AccessField ix) : rest) v =
case valueContent' v of
ConstantC ConstantStruct { constantStructValues = vs } ->
case ix < length vs of
False -> error $ concat [ "LLVM.Analysis.AccessPath.followAccessPath.walk: "
," Invalid access path: ", show aap, " / ", show val
]
True -> walk rest (vs !! ix)
_ -> F.failure (NonConstantInPath aap val)
walk _ _ = F.failure (CannotFollowPath aap val)
abstractAccessPath :: AccessPath -> AbstractAccessPath
abstractAccessPath (AccessPath _ vt t p) =
AbstractAccessPath vt t p
accessPath :: (Failure AccessPathError m) => Instruction -> m AccessPath
accessPath i =
case i of
StoreInst { storeAddress = sa, storeValue = sv } ->
return $! addDeref $ go (AccessPath sa (valueType sa) (valueType sv) []) (valueType sa) sa
LoadInst { loadAddress = la } ->
return $! addDeref $ go (AccessPath la (valueType la) (valueType i) []) (valueType la) la
AtomicCmpXchgInst { atomicCmpXchgPointer = p
, atomicCmpXchgNewValue = nv
} ->
return $! addDeref $ go (AccessPath p (valueType p) (valueType nv) []) (valueType p) p
AtomicRMWInst { atomicRMWPointer = p
, atomicRMWValue = v
} ->
return $! addDeref $ go (AccessPath p (valueType p) (valueType v) []) (valueType p) p
GetElementPtrInst {} ->
return $! addDeref $ go (AccessPath (toValue i) (valueType i) (valueType i) []) (valueType i) (toValue i)
BitcastInst { castedValue = (valueContent' -> InstructionC i') } ->
accessPath i'
_ -> F.failure (NotMemoryInstruction i)
where
addDeref p =
let t = accessPathBaseType p
cs' = (t, AccessDeref) : accessPathTaggedComponents p
in p { accessPathTaggedComponents = cs' }
go p vt v =
case valueContent v of
InstructionC BitcastInst { castedValue = cv }
| isUnionPointerType (valueType cv) ->
let p' = p { accessPathTaggedComponents =
(valueType v, AccessUnion) : accessPathTaggedComponents p
}
in go p' (valueType v) cv
| otherwise -> go p (valueType v) cv
ConstantC ConstantValue { constantInstruction = BitcastInst { castedValue = cv } } ->
go p (valueType v) cv
InstructionC GetElementPtrInst { getElementPtrValue = base
, getElementPtrIndices = [_]
} ->
let p' = p { accessPathBaseValue = base
, accessPathTaggedComponents = (valueType v, AccessArray) : accessPathTaggedComponents p
}
in go p' (valueType base) base
InstructionC GetElementPtrInst { getElementPtrValue = base
, getElementPtrIndices = ixs
} ->
let p' = p { accessPathBaseValue = base
, accessPathTaggedComponents =
gepIndexFold base ixs ++ accessPathTaggedComponents p
}
in go p' (valueType base) base
ConstantC ConstantValue { constantInstruction =
GetElementPtrInst { getElementPtrValue = base
, getElementPtrIndices = ixs
} } ->
let p' = p { accessPathBaseValue = base
, accessPathTaggedComponents =
gepIndexFold base ixs ++ accessPathTaggedComponents p
}
in go p' (valueType base) base
InstructionC LoadInst { loadAddress = la } ->
let p' = p { accessPathBaseValue = la
, accessPathTaggedComponents =
(vt, AccessDeref) : accessPathTaggedComponents p
}
in go p' (valueType la) la
_ -> p { accessPathBaseValue = v
, accessPathBaseType = vt
}
isUnionPointerType :: Type -> Bool
isUnionPointerType t =
case t of
TypePointer (TypeStruct (Right name) _ _) _ ->
T.isPrefixOf (T.pack "union.") name
_ -> False
externalizeAccessPath :: (Failure AccessPathError m)
=> AbstractAccessPath
-> m (String, [AccessType])
externalizeAccessPath accPath =
maybe (F.failure (CannotExternalizeType bt)) return $ do
baseName <- structTypeToName (stripPointerTypes bt)
return (baseName, abstractAccessPathComponents accPath)
where
bt = abstractAccessPathBaseType accPath
derefPointerType :: Type -> Type
derefPointerType (TypePointer p _) = p
derefPointerType t = error ("LLVM.Analysis.AccessPath.derefPointerType: Type is not a pointer type: " ++ show t)
gepIndexFold :: Value -> [Value] -> [(Type, AccessType)]
gepIndexFold base (ptrIx : ixs) =
let ty@(TypePointer baseType _) = valueType base
in case valueContent ptrIx of
ConstantC ConstantInt { constantIntValue = 0 } ->
snd $ L.foldl' walkGep (baseType, []) ixs
_ ->
snd $ L.foldl' walkGep (baseType, [(ty, AccessArray)]) ixs
where
walkGep (ty, acc) ix =
case ty of
TypePointer ty' _ -> (ty', (ty, AccessArray) : acc)
TypeArray _ ty' -> (ty', (ty, AccessArray) : acc)
TypeStruct _ ts _ ->
case valueContent ix of
ConstantC ConstantInt { constantIntValue = fldNo } ->
let fieldNumber = fromIntegral fldNo
ty' = ts !! fieldNumber
in (ty', (ty', AccessField fieldNumber) : acc)
_ -> error ("LLVM.Analysis.AccessPath.gepIndexFold.walkGep: Invalid non-constant GEP index for struct: " ++ show ty)
_ -> error ("LLVM.Analysis.AccessPath.gepIndexFold.walkGep: Unexpected type in GEP: " ++ show ty)
gepIndexFold v [] =
error ("LLVM.Analysis.AccessPath.gepIndexFold: GEP instruction/base with empty index list: " ++ show v)