crucible-llvm-0.6: src/Lang/Crucible/LLVM/MemType.hs
------------------------------------------------------------------------
-- |
-- Module : Lang.Crucible.LLVM.MemType
-- Description : Basic datatypes for describing LLVM types
-- Copyright : (c) Galois, Inc 2011-2013
-- License : BSD3
-- Maintainer : Rob Dockins <rdockins@galois.com>
-- Stability : provisional
------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Lang.Crucible.LLVM.MemType
( -- * Type information.
SymType(..)
, MemType(..)
, memTypeAlign
, memTypeSize
, ppSymType
, ppMemType
, memTypeBitwidth
, isPointerMemType
-- ** Function type information.
, FunDecl(..)
, RetType
, voidFunDecl
, funDecl
, varArgsFunDecl
, ppFunDecl
, ppRetType
-- ** Struct type information.
, StructInfo
, siIsPacked
, mkStructInfo
, siFieldCount
, FieldInfo
, fiOffset
, fiType
, fiPadding
, siFieldInfo
, siFieldTypes
, siFieldOffset
, siFields
, siIndexOfOffset
-- ** Common memory types.
, i1, i8, i16, i32, i64
, i8p, i16p, i32p, i64p
-- * Re-exports
, L.Ident(..)
, ppIdent
) where
import Control.Lens
import Data.Vector (Vector)
import qualified Data.Vector as V
import Numeric.Natural
import qualified Text.LLVM as L
import Prettyprinter
import Lang.Crucible.LLVM.Bytes
import Lang.Crucible.LLVM.DataLayout
import qualified Lang.Crucible.LLVM.PrettyPrint as LPP
import Lang.Crucible.LLVM.PrettyPrint hiding (ppIdent, ppType)
import Lang.Crucible.Panic ( panic )
-- | Performs a binary search on a range of ints.
binarySearch :: (Int -> Ordering)
-> Int -- ^ Lower bound (included in range)
-> Int -- ^ Upper bound (excluded from range)
-> Maybe Int
binarySearch f = go
where go l h | l == h = Nothing
| otherwise = case f i of
-- Index is less than one f is searching for
LT -> go (i+1) h
EQ -> Just i
-- Index is greater than one f is searching for.
GT -> go l i
where i = l + (h - l) `div` 2
ppIdent :: L.Ident -> Doc ann
ppIdent = viaShow . LPP.ppIdent
-- TODO: update if llvm-pretty switches to prettyprinter
-- | LLVM types supported by symbolic simulator.
data SymType
= MemType MemType
| Alias L.Ident
| FunType FunDecl
| VoidType
-- | A type that LLVM does not know the structure of such as
-- a struct that is declared, but not defined.
| OpaqueType
-- | A type not supported by the symbolic simulator.
| UnsupportedType L.Type
deriving (Eq, Ord)
instance Show SymType where
show = show . ppSymType
instance Pretty SymType where
pretty = ppSymType
-- | Pretty-print a 'SymType'.
ppSymType :: SymType -> Doc ann
ppSymType (MemType tp) = ppMemType tp
ppSymType (Alias i) = ppIdent i
ppSymType (FunType d) = ppFunDecl d
ppSymType VoidType = pretty "void"
ppSymType OpaqueType = pretty "opaque"
ppSymType (UnsupportedType tp) = viaShow (LPP.ppType tp)
-- TODO: update if llvm-pretty switches to prettyprinter
-- | LLVM types supported by simulator with a defined size and alignment.
data MemType
= IntType Natural
| PtrType SymType
-- ^ A pointer with an explicit pointee type, corresponding to LLVM's
-- 'L.PtrTo'.
| PtrOpaqueType
-- ^ An opaque pointer type, corresponding to LLVM's 'L.PtrOpaque'.
| FloatType
| DoubleType
| X86_FP80Type
| ArrayType Natural MemType
| VecType Natural MemType
| StructType StructInfo
| MetadataType
deriving (Eq, Ord)
instance Show MemType where
show = show . ppMemType
instance Pretty MemType where
pretty = ppMemType
-- | Pretty-print a 'MemType'.
ppMemType :: MemType -> Doc ann
ppMemType mtp =
case mtp of
IntType w -> ppIntType w
FloatType -> pretty "float"
DoubleType -> pretty "double"
X86_FP80Type -> pretty "long double"
PtrType tp -> ppPtrType (ppSymType tp)
PtrOpaqueType -> pretty "ptr"
ArrayType n tp -> ppArrayType n (ppMemType tp)
VecType n tp -> ppVectorType n (ppMemType tp)
StructType si -> ppStructInfo si
MetadataType -> pretty "metadata"
-- | 1-bit integer type.
i1 :: MemType
i1 = IntType 1
-- | 8-bit integer type.
i8 :: MemType
i8 = IntType 8
-- | 16-bit integer type.
i16 :: MemType
i16 = IntType 16
-- | 32-bit integer type.
i32 :: MemType
i32 = IntType 32
-- | 64-bit integer type.
i64 :: MemType
i64 = IntType 64
-- | Pointer to 8-bit integer.
i8p :: MemType
i8p = PtrType (MemType i8)
-- | Pointer to 16-bit integer.
i16p :: MemType
i16p = PtrType (MemType i16)
-- | Pointer to 32-bit integer.
i32p :: MemType
i32p = PtrType (MemType i32)
-- | Pointer to 64-bit integer.
i64p :: MemType
i64p = PtrType (MemType i64)
-- | An LLVM function type.
data FunDecl = FunDecl { fdRetType :: !RetType
, fdArgTypes :: ![MemType]
, fdVarArgs :: !Bool
}
deriving (Eq, Ord)
-- | Return the number of bits that represent the given memtype, which
-- must be either integer types, floating point types or vectors of
-- the same.
memTypeBitwidth :: MemType -> Maybe Natural
memTypeBitwidth (IntType w) = Just w
memTypeBitwidth FloatType = Just 32
memTypeBitwidth DoubleType = Just 64
memTypeBitwidth X86_FP80Type = Just 80
memTypeBitwidth (VecType n tp) = (fromIntegral n *) <$> memTypeBitwidth tp
memTypeBitwidth _ = Nothing
-- | Returns 'True' if this is a pointer type.
isPointerMemType :: MemType -> Bool
isPointerMemType (PtrType _) = True
isPointerMemType PtrOpaqueType = True
isPointerMemType _ = False
-- | Return type if any.
type RetType = Maybe MemType
-- | Declare function that returns void.
voidFunDecl :: [MemType] -> FunDecl
voidFunDecl tps = FunDecl { fdRetType = Nothing
, fdArgTypes = tps
, fdVarArgs = False
}
-- | Declare function that returns a value.
funDecl :: MemType -> [MemType] -> FunDecl
funDecl rtp tps = FunDecl { fdRetType = Just rtp
, fdArgTypes = tps
, fdVarArgs = False
}
-- | Declare function that returns a value.
varArgsFunDecl :: MemType -> [MemType] -> FunDecl
varArgsFunDecl rtp tps = FunDecl { fdRetType = Just rtp
, fdArgTypes = tps
, fdVarArgs = True
}
-- | Pretty-print a function type.
ppFunDecl :: FunDecl -> Doc ann
ppFunDecl (FunDecl rtp args va) = rdoc <> parens (commas (fmap ppMemType args ++ vad))
where rdoc = maybe (pretty "void") ppMemType rtp
vad = if va then [pretty "..."] else []
-- | Pretty print a return type.
ppRetType :: RetType -> Doc ann
ppRetType = maybe (pretty "void") ppMemType
-- | Returns size of a 'MemType' in bytes.
memTypeSize :: DataLayout -> MemType -> Bytes
memTypeSize dl mtp =
case mtp of
IntType w -> intWidthSize w
FloatType -> 4
DoubleType -> 8
X86_FP80Type -> 10
PtrType{} -> dl ^. ptrSize
PtrOpaqueType{} -> dl ^. ptrSize
ArrayType n tp -> natBytesMul n (memTypeSize dl tp)
VecType n tp -> natBytesMul n (memTypeSize dl tp)
StructType si -> structSize si
MetadataType -> 0
memTypeSizeInBits :: DataLayout -> MemType -> Natural
memTypeSizeInBits dl tp = bytesToBits (memTypeSize dl tp)
-- | Returns ABI byte alignment constraint in bytes.
memTypeAlign :: DataLayout -> MemType -> Alignment
memTypeAlign dl mtp =
case mtp of
IntType w -> integerAlignment dl (fromIntegral w)
FloatType -> case floatAlignment dl 32 of
Just a -> a
Nothing -> panic "crucible-llvm:memTypeAlign.float32"
[ "Invalid 32-bit float alignment from datalayout" ]
DoubleType -> case floatAlignment dl 64 of
Just a -> a
Nothing -> panic "crucible-llvm:memTypeAlign.float64"
[ "Invalid 64-bit float alignment from datalayout" ]
X86_FP80Type -> case floatAlignment dl 80 of
Just a -> a
Nothing -> panic "crucible-llvm:memTypeAlign.float80"
[ "Invalid 80-bit float alignment from datalayout" ]
PtrType{} -> dl ^. ptrAlign
PtrOpaqueType{} -> dl ^. ptrAlign
ArrayType _ tp -> memTypeAlign dl tp
VecType _n _tp -> vectorAlignment dl (memTypeSizeInBits dl mtp)
StructType si -> structAlign si
MetadataType -> noAlignment
-- | Information about size, alignment, and fields of a struct.
data StructInfo = StructInfo
{ siIsPacked :: !Bool
, structSize :: !Bytes -- ^ Size in bytes.
, structAlign :: !Alignment
, siFields :: !(V.Vector FieldInfo)
}
deriving (Eq, Ord, Show)
data FieldInfo = FieldInfo
{ fiOffset :: !Offset -- ^ Byte offset of field relative to start of struct.
, fiType :: !MemType -- ^ Type of field.
, fiPadding :: !Bytes -- ^ Number of bytes of padding at end of field.
}
deriving (Eq, Ord, Show)
-- | Constructs a function for obtaining target-specific size/alignment
-- information about structs. The function produced corresponds to the
-- @StructLayout@ object constructor in TargetData.cpp.
mkStructInfo :: DataLayout
-> Bool -- ^ @True@ = packed, @False@ = unpacked
-> [MemType] -- ^ Field types
-> StructInfo
mkStructInfo dl packed tps0 = go [] 0 a0 tps0
where a0 | packed = noAlignment
| otherwise = nextAlign noAlignment tps0 `max` aggregateAlignment dl
-- Padding after each field depends on the alignment of the
-- type of the next field, if there is one. Padding after the
-- last field depends on the alignment of the whole struct
-- (i.e. the maximum alignment of any field). Alignment value
-- of n means to align on 2^n byte boundaries.
nextAlign :: Alignment -> [MemType] -> Alignment
nextAlign _ _ | packed = noAlignment
nextAlign maxAlign [] = maxAlign
nextAlign _ (tp:_) = memTypeAlign dl tp
-- Process fields
go :: [FieldInfo] -- ^ Fields so far in reverse order.
-> Bytes -- ^ Total size so far (aligned to next element)
-> Alignment -- ^ Maximum alignment so far
-> [MemType] -- ^ Field types to process
-> StructInfo
go flds sz maxAlign (tp:tpl) =
go (fi:flds) sz' (max maxAlign fieldAlign) tpl
where
fi = FieldInfo
{ fiOffset = sz
, fiType = tp
, fiPadding = sz' - e
}
-- End of field for tp
e = sz + memTypeSize dl tp
-- Alignment of next field
fieldAlign = nextAlign maxAlign tpl
-- Size of field at alignment for next thing.
sz' = padToAlignment e fieldAlign
go flds sz maxAlign [] =
StructInfo { siIsPacked = packed
, structSize = sz
, structAlign = maxAlign
, siFields = V.fromList (reverse flds)
}
-- | The types of a struct type's fields.
siFieldTypes :: StructInfo -> Vector MemType
siFieldTypes si = fiType <$> siFields si
-- | Number of fields in a struct type.
siFieldCount :: StructInfo -> Int
siFieldCount = V.length . siFields
-- | Returns information for field with given index, if it is defined.
siFieldInfo :: StructInfo -> Int -> Maybe FieldInfo
siFieldInfo si i = siFields si V.!? i
-- | Returns offset of field with given index, if it is defined.
siFieldOffset :: StructInfo -> Int -> Maybe Offset
siFieldOffset si i = fiOffset <$> siFieldInfo si i
-- | Returns index of field at the given byte offset (if any).
siIndexOfOffset :: StructInfo -> Offset -> Maybe Int
siIndexOfOffset si o = binarySearch f 0 (V.length flds)
where flds = siFields si
f i | e <= o = LT -- Index too low if field ends before offset.
| o < s = GT -- Index too high if field starts after offset.
| otherwise = EQ
where s = fiOffset (flds V.! i)
e | i+1 == V.length flds = structSize si
| otherwise = fiOffset (flds V.! i)
commas :: [Doc ann] -> Doc ann
commas = hsep . punctuate (pretty ',')
structBraces :: Bool -> Doc ann -> Doc ann
structBraces False b = pretty '{' <+> b <+> pretty '}'
structBraces True b = pretty "<{" <+> b <+> pretty "}>"
-- | Pretty print struct info.
ppStructInfo :: StructInfo -> Doc ann
ppStructInfo si = structBraces (siIsPacked si) $ commas (V.toList fields)
where fields = ppMemType <$> siFieldTypes si