------------------------------------------------------------------------
-- |
-- 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 :: (Int -> Ordering) -> Int -> Int -> Maybe Int
binarySearch Int -> Ordering
f = Int -> Int -> Maybe Int
go
  where go :: Int -> Int -> Maybe Int
go Int
l Int
h | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
h = Maybe Int
forall a. Maybe a
Nothing
               | Bool
otherwise = case Int -> Ordering
f Int
i of
                               -- Index is less than one f is searching for
                               Ordering
LT -> Int -> Int -> Maybe Int
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
h
                               Ordering
EQ -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
                               -- Index is greater than one f is searching for.
                               Ordering
GT -> Int -> Int -> Maybe Int
go Int
l Int
i
          where i :: Int
i = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

ppIdent :: L.Ident -> Doc ann
ppIdent :: forall ann. Ident -> Doc ann
ppIdent = Doc -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Doc -> Doc ann) -> (Ident -> Doc) -> Ident -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Doc
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 (SymType -> SymType -> Bool
(SymType -> SymType -> Bool)
-> (SymType -> SymType -> Bool) -> Eq SymType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SymType -> SymType -> Bool
== :: SymType -> SymType -> Bool
$c/= :: SymType -> SymType -> Bool
/= :: SymType -> SymType -> Bool
Eq, Eq SymType
Eq SymType =>
(SymType -> SymType -> Ordering)
-> (SymType -> SymType -> Bool)
-> (SymType -> SymType -> Bool)
-> (SymType -> SymType -> Bool)
-> (SymType -> SymType -> Bool)
-> (SymType -> SymType -> SymType)
-> (SymType -> SymType -> SymType)
-> Ord SymType
SymType -> SymType -> Bool
SymType -> SymType -> Ordering
SymType -> SymType -> SymType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SymType -> SymType -> Ordering
compare :: SymType -> SymType -> Ordering
$c< :: SymType -> SymType -> Bool
< :: SymType -> SymType -> Bool
$c<= :: SymType -> SymType -> Bool
<= :: SymType -> SymType -> Bool
$c> :: SymType -> SymType -> Bool
> :: SymType -> SymType -> Bool
$c>= :: SymType -> SymType -> Bool
>= :: SymType -> SymType -> Bool
$cmax :: SymType -> SymType -> SymType
max :: SymType -> SymType -> SymType
$cmin :: SymType -> SymType -> SymType
min :: SymType -> SymType -> SymType
Ord)

instance Show SymType where
  show :: SymType -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (SymType -> Doc Any) -> SymType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymType -> Doc Any
forall ann. SymType -> Doc ann
ppSymType

instance Pretty SymType where
  pretty :: forall ann. SymType -> Doc ann
pretty = SymType -> Doc ann
forall ann. SymType -> Doc ann
ppSymType

-- | Pretty-print a 'SymType'.
ppSymType :: SymType -> Doc ann
ppSymType :: forall ann. SymType -> Doc ann
ppSymType (MemType MemType
tp) = MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType MemType
tp
ppSymType (Alias Ident
i) = Ident -> Doc ann
forall ann. Ident -> Doc ann
ppIdent Ident
i
ppSymType (FunType FunDecl
d) = FunDecl -> Doc ann
forall ann. FunDecl -> Doc ann
ppFunDecl FunDecl
d
ppSymType SymType
VoidType = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"void"
ppSymType SymType
OpaqueType = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"opaque"
ppSymType (UnsupportedType Type
tp) = Doc -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Type -> Doc
LPP.ppType Type
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 (MemType -> MemType -> Bool
(MemType -> MemType -> Bool)
-> (MemType -> MemType -> Bool) -> Eq MemType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MemType -> MemType -> Bool
== :: MemType -> MemType -> Bool
$c/= :: MemType -> MemType -> Bool
/= :: MemType -> MemType -> Bool
Eq, Eq MemType
Eq MemType =>
(MemType -> MemType -> Ordering)
-> (MemType -> MemType -> Bool)
-> (MemType -> MemType -> Bool)
-> (MemType -> MemType -> Bool)
-> (MemType -> MemType -> Bool)
-> (MemType -> MemType -> MemType)
-> (MemType -> MemType -> MemType)
-> Ord MemType
MemType -> MemType -> Bool
MemType -> MemType -> Ordering
MemType -> MemType -> MemType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MemType -> MemType -> Ordering
compare :: MemType -> MemType -> Ordering
$c< :: MemType -> MemType -> Bool
< :: MemType -> MemType -> Bool
$c<= :: MemType -> MemType -> Bool
<= :: MemType -> MemType -> Bool
$c> :: MemType -> MemType -> Bool
> :: MemType -> MemType -> Bool
$c>= :: MemType -> MemType -> Bool
>= :: MemType -> MemType -> Bool
$cmax :: MemType -> MemType -> MemType
max :: MemType -> MemType -> MemType
$cmin :: MemType -> MemType -> MemType
min :: MemType -> MemType -> MemType
Ord)

instance Show MemType where
  show :: MemType -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (MemType -> Doc Any) -> MemType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemType -> Doc Any
forall ann. MemType -> Doc ann
ppMemType

instance Pretty MemType where
  pretty :: forall ann. MemType -> Doc ann
pretty = MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType

-- | Pretty-print a 'MemType'.
ppMemType :: MemType -> Doc ann
ppMemType :: forall ann. MemType -> Doc ann
ppMemType MemType
mtp =
  case MemType
mtp of
    IntType Natural
w -> Natural -> Doc ann
forall a ann. Integral a => a -> Doc ann
ppIntType Natural
w
    MemType
FloatType -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"float"
    MemType
DoubleType -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"double"
    MemType
X86_FP80Type -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"long double"
    PtrType SymType
tp -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
ppPtrType (SymType -> Doc ann
forall ann. SymType -> Doc ann
ppSymType SymType
tp)
    MemType
PtrOpaqueType -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"ptr"
    ArrayType Natural
n MemType
tp -> Natural -> Doc ann -> Doc ann
forall ann. Natural -> Doc ann -> Doc ann
ppArrayType Natural
n (MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType MemType
tp)
    VecType Natural
n MemType
tp  -> Natural -> Doc ann -> Doc ann
forall ann. Natural -> Doc ann -> Doc ann
ppVectorType Natural
n (MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType MemType
tp)
    StructType StructInfo
si -> StructInfo -> Doc ann
forall ann. StructInfo -> Doc ann
ppStructInfo StructInfo
si
    MemType
MetadataType -> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"metadata"

-- | 1-bit integer type.
i1 :: MemType
i1 :: MemType
i1 = Natural -> MemType
IntType Natural
1

-- | 8-bit integer type.
i8 :: MemType
i8 :: MemType
i8 = Natural -> MemType
IntType Natural
8

-- | 16-bit integer type.
i16 :: MemType
i16 :: MemType
i16 = Natural -> MemType
IntType Natural
16

-- | 32-bit integer type.
i32 :: MemType
i32 :: MemType
i32 = Natural -> MemType
IntType Natural
32

-- | 64-bit integer type.
i64 :: MemType
i64 :: MemType
i64 = Natural -> MemType
IntType Natural
64

-- | Pointer to 8-bit integer.
i8p :: MemType
i8p :: MemType
i8p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i8)

-- | Pointer to 16-bit integer.
i16p :: MemType
i16p :: MemType
i16p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i16)

-- | Pointer to 32-bit integer.
i32p :: MemType
i32p :: MemType
i32p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i32)

-- | Pointer to 64-bit integer.
i64p :: MemType
i64p :: MemType
i64p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i64)

-- | An LLVM function type.
data FunDecl = FunDecl { FunDecl -> RetType
fdRetType  :: !RetType
                       , FunDecl -> [MemType]
fdArgTypes :: ![MemType]
                       , FunDecl -> Bool
fdVarArgs  :: !Bool
                       }
 deriving (FunDecl -> FunDecl -> Bool
(FunDecl -> FunDecl -> Bool)
-> (FunDecl -> FunDecl -> Bool) -> Eq FunDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunDecl -> FunDecl -> Bool
== :: FunDecl -> FunDecl -> Bool
$c/= :: FunDecl -> FunDecl -> Bool
/= :: FunDecl -> FunDecl -> Bool
Eq, Eq FunDecl
Eq FunDecl =>
(FunDecl -> FunDecl -> Ordering)
-> (FunDecl -> FunDecl -> Bool)
-> (FunDecl -> FunDecl -> Bool)
-> (FunDecl -> FunDecl -> Bool)
-> (FunDecl -> FunDecl -> Bool)
-> (FunDecl -> FunDecl -> FunDecl)
-> (FunDecl -> FunDecl -> FunDecl)
-> Ord FunDecl
FunDecl -> FunDecl -> Bool
FunDecl -> FunDecl -> Ordering
FunDecl -> FunDecl -> FunDecl
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FunDecl -> FunDecl -> Ordering
compare :: FunDecl -> FunDecl -> Ordering
$c< :: FunDecl -> FunDecl -> Bool
< :: FunDecl -> FunDecl -> Bool
$c<= :: FunDecl -> FunDecl -> Bool
<= :: FunDecl -> FunDecl -> Bool
$c> :: FunDecl -> FunDecl -> Bool
> :: FunDecl -> FunDecl -> Bool
$c>= :: FunDecl -> FunDecl -> Bool
>= :: FunDecl -> FunDecl -> Bool
$cmax :: FunDecl -> FunDecl -> FunDecl
max :: FunDecl -> FunDecl -> FunDecl
$cmin :: FunDecl -> FunDecl -> FunDecl
min :: FunDecl -> FunDecl -> FunDecl
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 :: MemType -> Maybe Natural
memTypeBitwidth (IntType Natural
w)  = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
w
memTypeBitwidth MemType
FloatType    = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
32
memTypeBitwidth MemType
DoubleType   = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
64
memTypeBitwidth MemType
X86_FP80Type = Natural -> Maybe Natural
forall a. a -> Maybe a
Just Natural
80
memTypeBitwidth (VecType Natural
n MemType
tp) = (Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
*) (Natural -> Natural) -> Maybe Natural -> Maybe Natural
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MemType -> Maybe Natural
memTypeBitwidth MemType
tp
memTypeBitwidth MemType
_ = Maybe Natural
forall a. Maybe a
Nothing

-- | Returns 'True' if this is a pointer type.
isPointerMemType :: MemType -> Bool
isPointerMemType :: MemType -> Bool
isPointerMemType (PtrType SymType
_)   = Bool
True
isPointerMemType MemType
PtrOpaqueType = Bool
True
isPointerMemType MemType
_             = Bool
False

-- | Return type if any.
type RetType = Maybe MemType

-- | Declare function that returns void.
voidFunDecl :: [MemType] -> FunDecl
voidFunDecl :: [MemType] -> FunDecl
voidFunDecl [MemType]
tps = FunDecl { fdRetType :: RetType
fdRetType = RetType
forall a. Maybe a
Nothing
                          , fdArgTypes :: [MemType]
fdArgTypes = [MemType]
tps
                          , fdVarArgs :: Bool
fdVarArgs = Bool
False
                          }

-- | Declare function that returns a value.
funDecl :: MemType -> [MemType] -> FunDecl
funDecl :: MemType -> [MemType] -> FunDecl
funDecl MemType
rtp [MemType]
tps = FunDecl { fdRetType :: RetType
fdRetType = MemType -> RetType
forall a. a -> Maybe a
Just MemType
rtp
                          , fdArgTypes :: [MemType]
fdArgTypes = [MemType]
tps
                          , fdVarArgs :: Bool
fdVarArgs = Bool
False
                          }

-- | Declare function that returns a value.
varArgsFunDecl :: MemType -> [MemType] -> FunDecl
varArgsFunDecl :: MemType -> [MemType] -> FunDecl
varArgsFunDecl MemType
rtp [MemType]
tps = FunDecl { fdRetType :: RetType
fdRetType = MemType -> RetType
forall a. a -> Maybe a
Just MemType
rtp
                                 , fdArgTypes :: [MemType]
fdArgTypes = [MemType]
tps
                                 , fdVarArgs :: Bool
fdVarArgs = Bool
True
                                 }

-- | Pretty-print a function type.
ppFunDecl :: FunDecl -> Doc ann
ppFunDecl :: forall ann. FunDecl -> Doc ann
ppFunDecl (FunDecl RetType
rtp [MemType]
args Bool
va) = Doc ann
rdoc Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
commas ((MemType -> Doc ann) -> [MemType] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType [MemType]
args [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ [Doc ann]
vad))
  where rdoc :: Doc ann
rdoc = Doc ann -> (MemType -> Doc ann) -> RetType -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"void") MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType RetType
rtp
        vad :: [Doc ann]
vad = if Bool
va then [String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"..."] else []

-- | Pretty print a return type.
ppRetType :: RetType -> Doc ann
ppRetType :: forall ann. RetType -> Doc ann
ppRetType = Doc ann -> (MemType -> Doc ann) -> RetType -> Doc ann
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"void") MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType

-- | Returns size of a 'MemType' in bytes.
memTypeSize :: DataLayout -> MemType -> Bytes
memTypeSize :: DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
mtp =
  case MemType
mtp of
    IntType Natural
w -> Natural -> Bytes
intWidthSize Natural
w
    MemType
FloatType -> Bytes
4
    MemType
DoubleType -> Bytes
8
    MemType
X86_FP80Type -> Bytes
10
    PtrType{} -> DataLayout
dl DataLayout -> Getting Bytes DataLayout Bytes -> Bytes
forall s a. s -> Getting a s a -> a
^. Getting Bytes DataLayout Bytes
Lens' DataLayout Bytes
ptrSize
    PtrOpaqueType{} -> DataLayout
dl DataLayout -> Getting Bytes DataLayout Bytes -> Bytes
forall s a. s -> Getting a s a -> a
^. Getting Bytes DataLayout Bytes
Lens' DataLayout Bytes
ptrSize
    ArrayType Natural
n MemType
tp -> Natural -> Bytes -> Bytes
natBytesMul Natural
n (DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
tp)
    VecType Natural
n MemType
tp -> Natural -> Bytes -> Bytes
natBytesMul Natural
n (DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
tp)
    StructType StructInfo
si -> StructInfo -> Bytes
structSize StructInfo
si
    MemType
MetadataType -> Bytes
0

memTypeSizeInBits :: DataLayout -> MemType -> Natural
memTypeSizeInBits :: DataLayout -> MemType -> Natural
memTypeSizeInBits DataLayout
dl MemType
tp = Bytes -> Natural
bytesToBits (DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
tp)

-- | Returns ABI byte alignment constraint in bytes.
memTypeAlign :: DataLayout -> MemType -> Alignment
memTypeAlign :: DataLayout -> MemType -> Alignment
memTypeAlign DataLayout
dl MemType
mtp =
  case MemType
mtp of
    IntType Natural
w -> DataLayout -> Natural -> Alignment
integerAlignment DataLayout
dl (Natural -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
w)
    MemType
FloatType -> case DataLayout -> Natural -> Maybe Alignment
floatAlignment DataLayout
dl Natural
32 of
                   Just Alignment
a -> Alignment
a
                   Maybe Alignment
Nothing -> String -> [String] -> Alignment
forall a. HasCallStack => String -> [String] -> a
panic String
"crucible-llvm:memTypeAlign.float32"
                              [ String
"Invalid 32-bit float alignment from datalayout" ]
    MemType
DoubleType -> case DataLayout -> Natural -> Maybe Alignment
floatAlignment DataLayout
dl Natural
64 of
                    Just Alignment
a -> Alignment
a
                    Maybe Alignment
Nothing -> String -> [String] -> Alignment
forall a. HasCallStack => String -> [String] -> a
panic String
"crucible-llvm:memTypeAlign.float64"
                               [ String
"Invalid 64-bit float alignment from datalayout" ]
    MemType
X86_FP80Type -> case DataLayout -> Natural -> Maybe Alignment
floatAlignment DataLayout
dl Natural
80 of
                      Just Alignment
a -> Alignment
a
                      Maybe Alignment
Nothing -> String -> [String] -> Alignment
forall a. HasCallStack => String -> [String] -> a
panic String
"crucible-llvm:memTypeAlign.float80"
                                 [ String
"Invalid 80-bit float alignment from datalayout" ]
    PtrType{} -> DataLayout
dl DataLayout -> Getting Alignment DataLayout Alignment -> Alignment
forall s a. s -> Getting a s a -> a
^. Getting Alignment DataLayout Alignment
Lens' DataLayout Alignment
ptrAlign
    PtrOpaqueType{} -> DataLayout
dl DataLayout -> Getting Alignment DataLayout Alignment -> Alignment
forall s a. s -> Getting a s a -> a
^. Getting Alignment DataLayout Alignment
Lens' DataLayout Alignment
ptrAlign
    ArrayType Natural
_ MemType
tp -> DataLayout -> MemType -> Alignment
memTypeAlign DataLayout
dl MemType
tp
    VecType Natural
_n MemType
_tp -> DataLayout -> Natural -> Alignment
vectorAlignment DataLayout
dl (DataLayout -> MemType -> Natural
memTypeSizeInBits DataLayout
dl MemType
mtp)
    StructType StructInfo
si  -> StructInfo -> Alignment
structAlign StructInfo
si
    MemType
MetadataType   -> Alignment
noAlignment

-- | Information about size, alignment, and fields of a struct.
data StructInfo = StructInfo
  { StructInfo -> Bool
siIsPacked   :: !Bool
  , StructInfo -> Bytes
structSize   :: !Bytes -- ^ Size in bytes.
  , StructInfo -> Alignment
structAlign  :: !Alignment
  , StructInfo -> Vector FieldInfo
siFields     :: !(V.Vector FieldInfo)
  }
  deriving (StructInfo -> StructInfo -> Bool
(StructInfo -> StructInfo -> Bool)
-> (StructInfo -> StructInfo -> Bool) -> Eq StructInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StructInfo -> StructInfo -> Bool
== :: StructInfo -> StructInfo -> Bool
$c/= :: StructInfo -> StructInfo -> Bool
/= :: StructInfo -> StructInfo -> Bool
Eq, Eq StructInfo
Eq StructInfo =>
(StructInfo -> StructInfo -> Ordering)
-> (StructInfo -> StructInfo -> Bool)
-> (StructInfo -> StructInfo -> Bool)
-> (StructInfo -> StructInfo -> Bool)
-> (StructInfo -> StructInfo -> Bool)
-> (StructInfo -> StructInfo -> StructInfo)
-> (StructInfo -> StructInfo -> StructInfo)
-> Ord StructInfo
StructInfo -> StructInfo -> Bool
StructInfo -> StructInfo -> Ordering
StructInfo -> StructInfo -> StructInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StructInfo -> StructInfo -> Ordering
compare :: StructInfo -> StructInfo -> Ordering
$c< :: StructInfo -> StructInfo -> Bool
< :: StructInfo -> StructInfo -> Bool
$c<= :: StructInfo -> StructInfo -> Bool
<= :: StructInfo -> StructInfo -> Bool
$c> :: StructInfo -> StructInfo -> Bool
> :: StructInfo -> StructInfo -> Bool
$c>= :: StructInfo -> StructInfo -> Bool
>= :: StructInfo -> StructInfo -> Bool
$cmax :: StructInfo -> StructInfo -> StructInfo
max :: StructInfo -> StructInfo -> StructInfo
$cmin :: StructInfo -> StructInfo -> StructInfo
min :: StructInfo -> StructInfo -> StructInfo
Ord, Int -> StructInfo -> ShowS
[StructInfo] -> ShowS
StructInfo -> String
(Int -> StructInfo -> ShowS)
-> (StructInfo -> String)
-> ([StructInfo] -> ShowS)
-> Show StructInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StructInfo -> ShowS
showsPrec :: Int -> StructInfo -> ShowS
$cshow :: StructInfo -> String
show :: StructInfo -> String
$cshowList :: [StructInfo] -> ShowS
showList :: [StructInfo] -> ShowS
Show)

data FieldInfo = FieldInfo
  { FieldInfo -> Bytes
fiOffset    :: !Offset  -- ^ Byte offset of field relative to start of struct.
  , FieldInfo -> MemType
fiType      :: !MemType -- ^ Type of field.
  , FieldInfo -> Bytes
fiPadding   :: !Bytes   -- ^ Number of bytes of padding at end of field.
  }
  deriving (FieldInfo -> FieldInfo -> Bool
(FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool) -> Eq FieldInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FieldInfo -> FieldInfo -> Bool
== :: FieldInfo -> FieldInfo -> Bool
$c/= :: FieldInfo -> FieldInfo -> Bool
/= :: FieldInfo -> FieldInfo -> Bool
Eq, Eq FieldInfo
Eq FieldInfo =>
(FieldInfo -> FieldInfo -> Ordering)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> Bool)
-> (FieldInfo -> FieldInfo -> FieldInfo)
-> (FieldInfo -> FieldInfo -> FieldInfo)
-> Ord FieldInfo
FieldInfo -> FieldInfo -> Bool
FieldInfo -> FieldInfo -> Ordering
FieldInfo -> FieldInfo -> FieldInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FieldInfo -> FieldInfo -> Ordering
compare :: FieldInfo -> FieldInfo -> Ordering
$c< :: FieldInfo -> FieldInfo -> Bool
< :: FieldInfo -> FieldInfo -> Bool
$c<= :: FieldInfo -> FieldInfo -> Bool
<= :: FieldInfo -> FieldInfo -> Bool
$c> :: FieldInfo -> FieldInfo -> Bool
> :: FieldInfo -> FieldInfo -> Bool
$c>= :: FieldInfo -> FieldInfo -> Bool
>= :: FieldInfo -> FieldInfo -> Bool
$cmax :: FieldInfo -> FieldInfo -> FieldInfo
max :: FieldInfo -> FieldInfo -> FieldInfo
$cmin :: FieldInfo -> FieldInfo -> FieldInfo
min :: FieldInfo -> FieldInfo -> FieldInfo
Ord, Int -> FieldInfo -> ShowS
[FieldInfo] -> ShowS
FieldInfo -> String
(Int -> FieldInfo -> ShowS)
-> (FieldInfo -> String)
-> ([FieldInfo] -> ShowS)
-> Show FieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FieldInfo -> ShowS
showsPrec :: Int -> FieldInfo -> ShowS
$cshow :: FieldInfo -> String
show :: FieldInfo -> String
$cshowList :: [FieldInfo] -> ShowS
showList :: [FieldInfo] -> ShowS
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 :: DataLayout -> Bool -> [MemType] -> StructInfo
mkStructInfo DataLayout
dl Bool
packed [MemType]
tps0 = [FieldInfo] -> Bytes -> Alignment -> [MemType] -> StructInfo
go [] Bytes
0 Alignment
a0 [MemType]
tps0
  where a0 :: Alignment
a0 | Bool
packed    = Alignment
noAlignment
           | Bool
otherwise = Alignment -> [MemType] -> Alignment
nextAlign Alignment
noAlignment [MemType]
tps0 Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
`max` DataLayout -> Alignment
aggregateAlignment DataLayout
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 :: Alignment -> [MemType] -> Alignment
nextAlign Alignment
_ [MemType]
_ | Bool
packed = Alignment
noAlignment
        nextAlign Alignment
maxAlign [] = Alignment
maxAlign
        nextAlign Alignment
_ (MemType
tp:[MemType]
_) = DataLayout -> MemType -> Alignment
memTypeAlign DataLayout
dl MemType
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 :: [FieldInfo] -> Bytes -> Alignment -> [MemType] -> StructInfo
go [FieldInfo]
flds Bytes
sz Alignment
maxAlign (MemType
tp:[MemType]
tpl) =
          [FieldInfo] -> Bytes -> Alignment -> [MemType] -> StructInfo
go (FieldInfo
fiFieldInfo -> [FieldInfo] -> [FieldInfo]
forall a. a -> [a] -> [a]
:[FieldInfo]
flds) Bytes
sz' (Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
max Alignment
maxAlign Alignment
fieldAlign) [MemType]
tpl

          where
            fi :: FieldInfo
fi = FieldInfo
                   { fiOffset :: Bytes
fiOffset  = Bytes
sz
                   , fiType :: MemType
fiType    = MemType
tp
                   , fiPadding :: Bytes
fiPadding = Bytes
sz' Bytes -> Bytes -> Bytes
forall a. Num a => a -> a -> a
- Bytes
e
                   }

            -- End of field for tp
            e :: Bytes
e = Bytes
sz Bytes -> Bytes -> Bytes
forall a. Num a => a -> a -> a
+ DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
tp

            -- Alignment of next field
            fieldAlign :: Alignment
fieldAlign = Alignment -> [MemType] -> Alignment
nextAlign Alignment
maxAlign [MemType]
tpl

            -- Size of field at alignment for next thing.
            sz' :: Bytes
sz' = Bytes -> Alignment -> Bytes
padToAlignment Bytes
e Alignment
fieldAlign

        go [FieldInfo]
flds Bytes
sz Alignment
maxAlign [] =
            StructInfo { siIsPacked :: Bool
siIsPacked = Bool
packed
                       , structSize :: Bytes
structSize = Bytes
sz
                       , structAlign :: Alignment
structAlign = Alignment
maxAlign
                       , siFields :: Vector FieldInfo
siFields = [FieldInfo] -> Vector FieldInfo
forall a. [a] -> Vector a
V.fromList ([FieldInfo] -> [FieldInfo]
forall a. [a] -> [a]
reverse [FieldInfo]
flds)
                       }

-- | The types of a struct type's fields.
siFieldTypes :: StructInfo -> Vector MemType
siFieldTypes :: StructInfo -> Vector MemType
siFieldTypes StructInfo
si = FieldInfo -> MemType
fiType (FieldInfo -> MemType) -> Vector FieldInfo -> Vector MemType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StructInfo -> Vector FieldInfo
siFields StructInfo
si

-- | Number of fields in a struct type.
siFieldCount :: StructInfo -> Int
siFieldCount :: StructInfo -> Int
siFieldCount = Vector FieldInfo -> Int
forall a. Vector a -> Int
V.length (Vector FieldInfo -> Int)
-> (StructInfo -> Vector FieldInfo) -> StructInfo -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StructInfo -> Vector FieldInfo
siFields

-- | Returns information for field with given index, if it is defined.
siFieldInfo :: StructInfo -> Int -> Maybe FieldInfo
siFieldInfo :: StructInfo -> Int -> Maybe FieldInfo
siFieldInfo StructInfo
si Int
i = StructInfo -> Vector FieldInfo
siFields StructInfo
si Vector FieldInfo -> Int -> Maybe FieldInfo
forall a. Vector a -> Int -> Maybe a
V.!? Int
i

-- | Returns offset of field with given index, if it is defined.
siFieldOffset :: StructInfo -> Int -> Maybe Offset
siFieldOffset :: StructInfo -> Int -> Maybe Bytes
siFieldOffset StructInfo
si Int
i = FieldInfo -> Bytes
fiOffset (FieldInfo -> Bytes) -> Maybe FieldInfo -> Maybe Bytes
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StructInfo -> Int -> Maybe FieldInfo
siFieldInfo StructInfo
si Int
i

-- | Returns index of field at the given byte offset (if any).
siIndexOfOffset :: StructInfo -> Offset -> Maybe Int
siIndexOfOffset :: StructInfo -> Bytes -> Maybe Int
siIndexOfOffset StructInfo
si Bytes
o = (Int -> Ordering) -> Int -> Int -> Maybe Int
binarySearch Int -> Ordering
f Int
0 (Vector FieldInfo -> Int
forall a. Vector a -> Int
V.length Vector FieldInfo
flds)
  where flds :: Vector FieldInfo
flds = StructInfo -> Vector FieldInfo
siFields StructInfo
si
        f :: Int -> Ordering
f Int
i | Bytes
e Bytes -> Bytes -> Bool
forall a. Ord a => a -> a -> Bool
<= Bytes
o = Ordering
LT -- Index too low if field ends before offset.
            | Bytes
o Bytes -> Bytes -> Bool
forall a. Ord a => a -> a -> Bool
< Bytes
s  = Ordering
GT -- Index too high if field starts after offset.
            | Bool
otherwise = Ordering
EQ
         where s :: Bytes
s = FieldInfo -> Bytes
fiOffset (Vector FieldInfo
flds Vector FieldInfo -> Int -> FieldInfo
forall a. Vector a -> Int -> a
V.! Int
i)
               e :: Bytes
e | Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector FieldInfo -> Int
forall a. Vector a -> Int
V.length Vector FieldInfo
flds = StructInfo -> Bytes
structSize StructInfo
si
                 | Bool
otherwise = FieldInfo -> Bytes
fiOffset (Vector FieldInfo
flds Vector FieldInfo -> Int -> FieldInfo
forall a. Vector a -> Int -> a
V.! Int
i)

commas :: [Doc ann] -> Doc ann
commas :: forall ann. [Doc ann] -> Doc ann
commas = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate (Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
',')

structBraces :: Bool -> Doc ann -> Doc ann
structBraces :: forall ann. Bool -> Doc ann -> Doc ann
structBraces Bool
False Doc ann
b = Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'{' Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
b Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
'}'
structBraces Bool
True  Doc ann
b = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"<{" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
b Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"}>"

-- | Pretty print struct info.
ppStructInfo :: StructInfo -> Doc ann
ppStructInfo :: forall ann. StructInfo -> Doc ann
ppStructInfo StructInfo
si = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
structBraces (StructInfo -> Bool
siIsPacked StructInfo
si) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
commas (Vector (Doc ann) -> [Doc ann]
forall a. Vector a -> [a]
V.toList Vector (Doc ann)
fields)
  where fields :: Vector (Doc ann)
fields = MemType -> Doc ann
forall ann. MemType -> Doc ann
ppMemType (MemType -> Doc ann) -> Vector MemType -> Vector (Doc ann)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> StructInfo -> Vector MemType
siFieldTypes StructInfo
si