{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module Lang.Crucible.LLVM.MemType
(
SymType(..)
, MemType(..)
, memTypeAlign
, memTypeSize
, ppSymType
, ppMemType
, memTypeBitwidth
, isPointerMemType
, FunDecl(..)
, RetType
, voidFunDecl
, funDecl
, varArgsFunDecl
, ppFunDecl
, ppRetType
, StructInfo
, siIsPacked
, mkStructInfo
, siFieldCount
, FieldInfo
, fiOffset
, fiType
, fiPadding
, siFieldInfo
, siFieldTypes
, siFieldOffset
, siFields
, siIndexOfOffset
, i1, i8, i16, i32, i64
, i8p, i16p, i32p, i64p
, 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 )
binarySearch :: (Int -> Ordering)
-> Int
-> Int
-> 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
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
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
data SymType
= MemType MemType
| Alias L.Ident
| FunType FunDecl
| VoidType
| OpaqueType
| 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
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)
data MemType
= IntType Natural
| PtrType SymType
| PtrOpaqueType
| 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
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"
i1 :: MemType
i1 :: MemType
i1 = Natural -> MemType
IntType Natural
1
i8 :: MemType
i8 :: MemType
i8 = Natural -> MemType
IntType Natural
8
i16 :: MemType
i16 :: MemType
i16 = Natural -> MemType
IntType Natural
16
i32 :: MemType
i32 :: MemType
i32 = Natural -> MemType
IntType Natural
32
i64 :: MemType
i64 :: MemType
i64 = Natural -> MemType
IntType Natural
64
i8p :: MemType
i8p :: MemType
i8p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i8)
i16p :: MemType
i16p :: MemType
i16p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i16)
i32p :: MemType
i32p :: MemType
i32p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i32)
i64p :: MemType
i64p :: MemType
i64p = SymType -> MemType
PtrType (MemType -> SymType
MemType MemType
i64)
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)
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
isPointerMemType :: MemType -> Bool
isPointerMemType :: MemType -> Bool
isPointerMemType (PtrType SymType
_) = Bool
True
isPointerMemType MemType
PtrOpaqueType = Bool
True
isPointerMemType MemType
_ = Bool
False
type RetType = Maybe MemType
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
}
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
}
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
}
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 []
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
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)
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
data StructInfo = StructInfo
{ StructInfo -> Bool
siIsPacked :: !Bool
, StructInfo -> Bytes
structSize :: !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
, FieldInfo -> MemType
fiType :: !MemType
, FieldInfo -> Bytes
fiPadding :: !Bytes
}
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)
mkStructInfo :: DataLayout
-> Bool
-> [MemType]
-> 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
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
go :: [FieldInfo]
-> Bytes
-> Alignment
-> [MemType]
-> 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
}
e :: Bytes
e = Bytes
sz Bytes -> Bytes -> Bytes
forall a. Num a => a -> a -> a
+ DataLayout -> MemType -> Bytes
memTypeSize DataLayout
dl MemType
tp
fieldAlign :: Alignment
fieldAlign = Alignment -> [MemType] -> Alignment
nextAlign Alignment
maxAlign [MemType]
tpl
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)
}
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
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
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
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
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
| Bytes
o Bytes -> Bytes -> Bool
forall a. Ord a => a -> a -> Bool
< Bytes
s = Ordering
GT
| 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
"}>"
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