------------------------------------------------------------------------
-- |
-- Module           : Lang.Crucible.LLVM.TypeContext
-- Description      : Provides simulator type information and conversions.
-- Copyright        : (c) Galois, Inc 2011-2018
-- License          : BSD3
-- Maintainer       : Joe Hendrix <jhendrix@galois.com>
-- Stability        : provisional
--
-- This module provides functionality for querying simulator type
-- information in a module, and converting llvm-pretty types into
-- simulator types.
------------------------------------------------------------------------
{-# LANGUAGE ImplicitParams             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeSynonymInstances       #-}

module Lang.Crucible.LLVM.TypeContext
  ( -- * LLVMContext
    TypeContext
  , mkTypeContext
  , typeContextFromModule
  , llvmDataLayout
  , llvmMetadataMap
  , AliasMap
  , llvmAliasMap
    -- * LLVMContext query functions.
  , compatMemTypes
  , compatRetTypes
  , compatMemTypeLists
  , lookupAlias
  , lookupMetadata
  , liftType
  , liftMemType
  , liftRetType
  , liftDeclare
  , asMemType
  ) where

import           Control.Lens
import           Control.Monad
import           Control.Monad.Except (MonadError(..))
import           Control.Monad.State (State, runState, modify, gets)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Vector as V
import qualified Text.LLVM as L
import qualified Text.LLVM.DebugUtils as L
import           Prettyprinter
import           Data.IntMap (IntMap)

import           Lang.Crucible.LLVM.MemType
import           Lang.Crucible.LLVM.DataLayout
import qualified Lang.Crucible.LLVM.PrettyPrint as LPP

data IdentStatus
  = Resolved SymType
  | Active
  | Pending L.Type

data TCState = TCS { TCState -> DataLayout
tcsDataLayout :: DataLayout
                   , TCState -> Map Ident IdentStatus
tcsMap :: Map Ident IdentStatus
                     -- | Set of types encountered that are not supported by
                     -- the
                   , TCState -> Set Type
tcsUnsupported :: Set L.Type
                   , TCState -> Set Ident
tcsUnresolvable :: Set Ident
                   }

runTC :: DataLayout
      -> Map Ident IdentStatus
      -> TC a
      -> ([Doc ann], a)
runTC :: forall a ann.
DataLayout -> Map Ident IdentStatus -> TC a -> ([Doc ann], a)
runTC DataLayout
pdl Map Ident IdentStatus
initMap TC a
m = ASetter (TCState, a) ([Doc ann], a) TCState [Doc ann]
-> (TCState -> [Doc ann]) -> (TCState, a) -> ([Doc ann], a)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (TCState, a) ([Doc ann], a) TCState [Doc ann]
forall s t a b. Field1 s t a b => Lens s t a b
Lens (TCState, a) ([Doc ann], a) TCState [Doc ann]
_1 TCState -> [Doc ann]
forall ann. TCState -> [Doc ann]
tcsErrors ((TCState, a) -> ([Doc ann], a))
-> ((a, TCState) -> (TCState, a)) -> (a, TCState) -> ([Doc ann], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (TCState, a) (a, TCState) (TCState, a)
-> (a, TCState) -> (TCState, a)
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view Getting (TCState, a) (a, TCState) (TCState, a)
forall (p :: Type -> Type -> Type) a b c d.
Swap p =>
Iso (p a b) (p c d) (p b a) (p d c)
Iso (a, TCState) (a, TCState) (TCState, a) (TCState, a)
swapped ((a, TCState) -> ([Doc ann], a)) -> (a, TCState) -> ([Doc ann], a)
forall a b. (a -> b) -> a -> b
$ TC a -> TCState -> (a, TCState)
forall s a. State s a -> s -> (a, s)
runState TC a
m TCState
tcs0
  where tcs0 :: TCState
tcs0 = TCS { tcsDataLayout :: DataLayout
tcsDataLayout = DataLayout
pdl
                   , tcsMap :: Map Ident IdentStatus
tcsMap =  Map Ident IdentStatus
initMap
                   , tcsUnsupported :: Set Type
tcsUnsupported = Set Type
forall a. Set a
Set.empty
                   , tcsUnresolvable :: Set Ident
tcsUnresolvable = Set Ident
forall a. Set a
Set.empty
                   }

tcsErrors :: TCState -> [Doc ann]
tcsErrors :: forall ann. TCState -> [Doc ann]
tcsErrors TCState
tcs = (Type -> Doc ann
forall {ann}. Type -> Doc ann
ppUnsupported (Type -> Doc ann) -> [Type] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Type -> [Type]
forall a. Set a -> [a]
Set.toList (TCState -> Set Type
tcsUnsupported TCState
tcs))
             [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. [a] -> [a] -> [a]
++ (Ident -> Doc ann
forall {ann}. Ident -> Doc ann
ppUnresolvable (Ident -> Doc ann) -> [Ident] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Ident -> [Ident]
forall a. Set a -> [a]
Set.toList (TCState -> Set Ident
tcsUnresolvable TCState
tcs))
  where ppUnsupported :: Type -> Doc ann
ppUnsupported Type
tp = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"Unsupported type:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Type -> Doc
LPP.ppType Type
tp)
        ppUnresolvable :: Ident -> Doc ann
ppUnresolvable Ident
i = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
"Could not resolve identifier:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Ident -> Doc
LPP.ppIdent Ident
i)
        -- TODO: update if llvm-pretty switches to prettyprinter

-- | Type lifter contains types that could not be parsed.
type TC = State TCState

recordUnsupported :: L.Type -> TC ()
recordUnsupported :: Type -> TC ()
recordUnsupported Type
tp = (TCState -> TCState) -> TC ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify TCState -> TCState
fn
  where fn :: TCState -> TCState
fn TCState
tcs = TCState
tcs { tcsUnsupported = Set.insert tp (tcsUnsupported tcs) }

-- | Returns the type bound to an identifier.
tcIdent :: Ident -> TC SymType
tcIdent :: Ident -> TC SymType
tcIdent Ident
i = do
  Map Ident IdentStatus
im <- (TCState -> Map Ident IdentStatus)
-> StateT TCState Identity (Map Ident IdentStatus)
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets TCState -> Map Ident IdentStatus
tcsMap
  let retUnsupported :: TC SymType
retUnsupported = SymType
tp SymType -> TC () -> TC SymType
forall a b.
a -> StateT TCState Identity b -> StateT TCState Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ (TCState -> TCState) -> TC ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify TCState -> TCState
fn
        where tp :: SymType
tp = Type -> SymType
UnsupportedType (Ident -> Type
forall ident. ident -> Type' ident
L.Alias Ident
i)
              fn :: TCState -> TCState
fn TCState
tcs = TCState
tcs { tcsUnresolvable = Set.insert i (tcsUnresolvable tcs) }
  case Ident -> Map Ident IdentStatus -> Maybe IdentStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
i Map Ident IdentStatus
im of
    Maybe IdentStatus
Nothing -> TC SymType
retUnsupported
    Just (Resolved SymType
tp) -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymType
tp
    Just IdentStatus
Active -> TC SymType
retUnsupported
    Just (Pending Type
tp) -> do
        (TCState -> TCState) -> TC ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (IdentStatus -> TCState -> TCState
ins IdentStatus
Active)
        SymType
stp <- Type -> TC SymType
tcType Type
tp
        SymType
stp SymType -> TC () -> TC SymType
forall a b.
a -> StateT TCState Identity b -> StateT TCState Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ (TCState -> TCState) -> TC ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
modify (IdentStatus -> TCState -> TCState
ins (SymType -> IdentStatus
Resolved SymType
stp))
      where ins :: IdentStatus -> TCState -> TCState
ins IdentStatus
v TCState
tcs = TCState
tcs { tcsMap = Map.insert i v (tcsMap tcs) }

resolveMemType :: SymType -> TC (Maybe MemType)
resolveMemType :: SymType -> TC (Maybe MemType)
resolveMemType = SymType -> TC (Maybe MemType)
resolve
  where resolve :: SymType -> TC (Maybe MemType)
resolve (MemType MemType
mt) = Maybe MemType -> TC (Maybe MemType)
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemType -> Maybe MemType
forall a. a -> Maybe a
Just MemType
mt)
        resolve (Alias Ident
i) = SymType -> TC (Maybe MemType)
resolve (SymType -> TC (Maybe MemType)) -> TC SymType -> TC (Maybe MemType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> TC SymType
tcIdent Ident
i
        resolve SymType
_ = Maybe MemType -> TC (Maybe MemType)
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe MemType
forall a. Maybe a
Nothing

resolveRetType :: SymType -> TC (Maybe RetType)
resolveRetType :: SymType -> TC (Maybe (Maybe MemType))
resolveRetType = SymType -> TC (Maybe (Maybe MemType))
resolve
  where resolve :: SymType -> TC (Maybe (Maybe MemType))
resolve (MemType MemType
mt) = Maybe (Maybe MemType) -> TC (Maybe (Maybe MemType))
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe MemType -> Maybe (Maybe MemType)
forall a. a -> Maybe a
Just (MemType -> Maybe MemType
forall a. a -> Maybe a
Just MemType
mt))
        resolve (Alias Ident
i) = SymType -> TC (Maybe (Maybe MemType))
resolve (SymType -> TC (Maybe (Maybe MemType)))
-> TC SymType -> TC (Maybe (Maybe MemType))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> TC SymType
tcIdent Ident
i
        resolve SymType
VoidType = Maybe (Maybe MemType) -> TC (Maybe (Maybe MemType))
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe MemType -> Maybe (Maybe MemType)
forall a. a -> Maybe a
Just Maybe MemType
forall a. Maybe a
Nothing)
        resolve SymType
_ = Maybe (Maybe MemType) -> TC (Maybe (Maybe MemType))
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (Maybe MemType)
forall a. Maybe a
Nothing

tcMemType :: L.Type -> TC (Maybe MemType)
tcMemType :: Type -> TC (Maybe MemType)
tcMemType = SymType -> TC (Maybe MemType)
resolveMemType (SymType -> TC (Maybe MemType))
-> (Type -> TC SymType) -> Type -> TC (Maybe MemType)
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Type -> TC SymType
tcType

tcType :: L.Type -> TC SymType
tcType :: Type -> TC SymType
tcType Type
tp0 = do
  let badType :: TC SymType
badType = Type -> SymType
UnsupportedType Type
tp0 SymType -> TC () -> TC SymType
forall a b.
a -> StateT TCState Identity b -> StateT TCState Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Type -> TC ()
recordUnsupported Type
tp0
  let maybeApp :: (a -> MemType) -> TC (Maybe a) -> TC SymType
      maybeApp :: forall a. (a -> MemType) -> TC (Maybe a) -> TC SymType
maybeApp a -> MemType
f TC (Maybe a)
mmr = TC SymType -> (a -> TC SymType) -> Maybe a -> TC SymType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TC SymType
badType (SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> (a -> SymType) -> a -> TC SymType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemType -> SymType
MemType (MemType -> SymType) -> (a -> MemType) -> a -> SymType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MemType
f) (Maybe a -> TC SymType) -> TC (Maybe a) -> TC SymType
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< TC (Maybe a)
mmr
  case Type
tp0 of
    L.PrimType PrimType
pt ->
      case PrimType
pt of
        L.FloatType FloatType
ft -> do
          case FloatType
ft of
            FloatType
L.Float -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType MemType
FloatType
            FloatType
L.Double -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType MemType
DoubleType
            FloatType
L.X86_fp80 -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType MemType
X86_FP80Type
            FloatType
_ -> TC SymType
badType
        L.Integer Word32
w -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType (MemType -> SymType) -> MemType -> SymType
forall a b. (a -> b) -> a -> b
$ Natural -> MemType
IntType (Word32 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
        PrimType
L.Void -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymType
VoidType
        PrimType
L.Metadata -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType MemType
MetadataType
        PrimType
_ -> TC SymType
badType
    L.Alias Ident
i -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Ident -> SymType
Alias Ident
i)
    L.Array Word64
n Type
etp -> (MemType -> MemType) -> TC (Maybe MemType) -> TC SymType
forall a. (a -> MemType) -> TC (Maybe a) -> TC SymType
maybeApp (Natural -> MemType -> MemType
ArrayType (Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)) (TC (Maybe MemType) -> TC SymType)
-> TC (Maybe MemType) -> TC SymType
forall a b. (a -> b) -> a -> b
$ Type -> TC (Maybe MemType)
tcMemType Type
etp
    L.FunTy Type
res [Type]
args Bool
va -> do
      Maybe (Maybe MemType)
mrt <- SymType -> TC (Maybe (Maybe MemType))
resolveRetType (SymType -> TC (Maybe (Maybe MemType)))
-> TC SymType -> TC (Maybe (Maybe MemType))
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> TC SymType
tcType Type
res
      [Maybe MemType]
margs <- (Type -> TC (Maybe MemType))
-> [Type] -> StateT TCState Identity [Maybe MemType]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> TC (Maybe MemType)
tcMemType [Type]
args
      TC SymType
-> (FunDecl -> TC SymType) -> Maybe FunDecl -> TC SymType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TC SymType
badType (SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType)
-> (FunDecl -> SymType) -> FunDecl -> TC SymType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FunDecl -> SymType
FunType) (Maybe FunDecl -> TC SymType) -> Maybe FunDecl -> TC SymType
forall a b. (a -> b) -> a -> b
$
        Maybe MemType -> [MemType] -> Bool -> FunDecl
FunDecl (Maybe MemType -> [MemType] -> Bool -> FunDecl)
-> Maybe (Maybe MemType) -> Maybe ([MemType] -> Bool -> FunDecl)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Maybe MemType)
mrt Maybe ([MemType] -> Bool -> FunDecl)
-> Maybe [MemType] -> Maybe (Bool -> FunDecl)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Maybe MemType] -> Maybe [MemType]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence [Maybe MemType]
margs Maybe (Bool -> FunDecl) -> Maybe Bool -> Maybe FunDecl
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
va
    L.PtrTo Type
tp ->  (MemType -> SymType
MemType (MemType -> SymType) -> (SymType -> MemType) -> SymType -> SymType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymType -> MemType
PtrType) (SymType -> SymType) -> TC SymType -> TC SymType
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> TC SymType
tcType Type
tp
    Type
L.PtrOpaque -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SymType -> TC SymType) -> SymType -> TC SymType
forall a b. (a -> b) -> a -> b
$ MemType -> SymType
MemType MemType
PtrOpaqueType
    L.Struct [Type]
tpl       -> (StructInfo -> MemType) -> TC (Maybe StructInfo) -> TC SymType
forall a. (a -> MemType) -> TC (Maybe a) -> TC SymType
maybeApp StructInfo -> MemType
StructType (TC (Maybe StructInfo) -> TC SymType)
-> TC (Maybe StructInfo) -> TC SymType
forall a b. (a -> b) -> a -> b
$ Bool -> [Type] -> TC (Maybe StructInfo)
tcStruct Bool
False [Type]
tpl
    L.PackedStruct [Type]
tpl -> (StructInfo -> MemType) -> TC (Maybe StructInfo) -> TC SymType
forall a. (a -> MemType) -> TC (Maybe a) -> TC SymType
maybeApp StructInfo -> MemType
StructType (TC (Maybe StructInfo) -> TC SymType)
-> TC (Maybe StructInfo) -> TC SymType
forall a b. (a -> b) -> a -> b
$ Bool -> [Type] -> TC (Maybe StructInfo)
tcStruct Bool
True  [Type]
tpl
    L.Vector Word64
n Type
etp -> (MemType -> MemType) -> TC (Maybe MemType) -> TC SymType
forall a. (a -> MemType) -> TC (Maybe a) -> TC SymType
maybeApp (Natural -> MemType -> MemType
VecType (Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)) (TC (Maybe MemType) -> TC SymType)
-> TC (Maybe MemType) -> TC SymType
forall a b. (a -> b) -> a -> b
$ Type -> TC (Maybe MemType)
tcMemType Type
etp
    Type
L.Opaque -> SymType -> TC SymType
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymType
OpaqueType

-- | Constructs a function for obtaining target-specific size/alignment
-- information about structs.  The function produced corresponds to the
-- StructLayout object constructor in TargetData.cpp.
tcStruct :: Bool -> [L.Type] -> TC (Maybe StructInfo)
tcStruct :: Bool -> [Type] -> TC (Maybe StructInfo)
tcStruct Bool
packed [Type]
fldTys = do
  DataLayout
pdl <- (TCState -> DataLayout) -> StateT TCState Identity DataLayout
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets TCState -> DataLayout
tcsDataLayout
  [Maybe MemType]
fieldMemTys <- (Type -> TC (Maybe MemType))
-> [Type] -> StateT TCState Identity [Maybe MemType]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> TC (Maybe MemType)
tcMemType [Type]
fldTys
  Maybe StructInfo -> TC (Maybe StructInfo)
forall a. a -> StateT TCState Identity a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (DataLayout -> Bool -> [MemType] -> StructInfo
mkStructInfo DataLayout
pdl Bool
packed ([MemType] -> StructInfo) -> Maybe [MemType] -> Maybe StructInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe MemType] -> Maybe [MemType]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Type -> Type) a. Monad m => [m a] -> m [a]
sequence [Maybe MemType]
fieldMemTys)


type AliasMap = Map Ident SymType
type MetadataMap = IntMap L.ValMd

-- | Provides information about the types in an LLVM bitcode file.
data TypeContext = TypeContext
  { TypeContext -> DataLayout
llvmDataLayout :: DataLayout
  , TypeContext -> MetadataMap
llvmMetadataMap :: MetadataMap
  , TypeContext -> AliasMap
llvmAliasMap  :: AliasMap
  }

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

ppTypeContext :: TypeContext -> Doc ann
ppTypeContext :: forall ann. TypeContext -> Doc ann
ppTypeContext TypeContext
lc =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((Ident, SymType) -> Doc ann
forall {ann}. (Ident, SymType) -> Doc ann
ppAlias ((Ident, SymType) -> Doc ann) -> [(Ident, SymType)] -> [Doc ann]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> AliasMap -> [(Ident, SymType)]
forall k a. Map k a -> [(k, a)]
Map.toList (TypeContext -> AliasMap
llvmAliasMap TypeContext
lc))
  where ppAlias :: (Ident, SymType) -> Doc ann
ppAlias (Ident
i,SymType
tp) = Ident -> Doc ann
forall {ann}. Ident -> Doc ann
ppIdent Ident
i Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> SymType -> Doc ann
forall ann. SymType -> Doc ann
ppSymType SymType
tp

lookupAlias :: (?lc :: TypeContext, MonadError String m) => Ident -> m SymType
lookupAlias :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Ident -> m SymType
lookupAlias Ident
i =
  case TypeContext -> AliasMap
llvmAliasMap ?lc::TypeContext
TypeContext
?lc AliasMap
-> Getting (Maybe SymType) AliasMap (Maybe SymType)
-> Maybe SymType
forall s a. s -> Getting a s a -> a
^. Index AliasMap -> Lens' AliasMap (Maybe (IxValue AliasMap))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index AliasMap
Ident
i of
    Just SymType
stp -> SymType -> m SymType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymType
stp
    Maybe SymType
Nothing  -> String -> m SymType
forall a. String -> m a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> m SymType) -> String -> m SymType
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Unknown type alias", Ident -> String
forall a. Show a => a -> String
show Ident
i]

lookupMetadata :: (?lc :: TypeContext) => Int -> Maybe L.ValMd
lookupMetadata :: (?lc::TypeContext) => Int -> Maybe ValMd
lookupMetadata Int
x = Getting (Maybe ValMd) MetadataMap (Maybe ValMd)
-> MetadataMap -> Maybe ValMd
forall s (m :: Type -> Type) a.
MonadReader s m =>
Getting a s a -> m a
view (Index MetadataMap
-> Lens' MetadataMap (Maybe (IxValue MetadataMap))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
Index MetadataMap
x) (TypeContext -> MetadataMap
llvmMetadataMap ?lc::TypeContext
TypeContext
?lc)

-- | If argument corresponds to a @MemType@ possibly via aliases,
-- then return it.  Otherwise, returns @Nothing@.
asMemType :: (?lc :: TypeContext, MonadError String m) => SymType -> m MemType
asMemType :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m MemType
asMemType (MemType MemType
mt) = MemType -> m MemType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return MemType
mt
asMemType (Alias Ident
i) = SymType -> m MemType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m MemType
asMemType (SymType -> m MemType) -> m SymType -> m MemType
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> m SymType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Ident -> m SymType
lookupAlias Ident
i
asMemType SymType
stp = String -> m MemType
forall a. String -> m a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String
"Expected memory type", SymType -> String
forall a. Show a => a -> String
show SymType
stp])

-- | If argument corresponds to a @RetType@ possibly via aliases,
-- then return it.  Otherwise, returns @Nothing@.
asRetType :: (?lc :: TypeContext, MonadError String m) => SymType -> m RetType
asRetType :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m (Maybe MemType)
asRetType (MemType MemType
mt) = Maybe MemType -> m (Maybe MemType)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (MemType -> Maybe MemType
forall a. a -> Maybe a
Just MemType
mt)
asRetType SymType
VoidType     = Maybe MemType -> m (Maybe MemType)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe MemType
forall a. Maybe a
Nothing
asRetType (Alias Ident
i)    = SymType -> m (Maybe MemType)
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m (Maybe MemType)
asRetType (SymType -> m (Maybe MemType)) -> m SymType -> m (Maybe MemType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ident -> m SymType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Ident -> m SymType
lookupAlias Ident
i
asRetType SymType
stp = String -> m (Maybe MemType)
forall a. String -> m a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String
"Expected return type", SymType -> String
forall a. Show a => a -> String
show SymType
stp])

-- | Creates an LLVMContext from a parsed data layout and lists of types.
--  Errors reported in first argument.
mkTypeContext :: DataLayout -> MetadataMap -> [L.TypeDecl]  -> ([Doc ann], TypeContext)
mkTypeContext :: forall ann.
DataLayout -> MetadataMap -> [TypeDecl] -> ([Doc ann], TypeContext)
mkTypeContext DataLayout
dl MetadataMap
mdMap [TypeDecl]
decls =
    let tps :: Map Ident Type
tps = [(Ident, Type)] -> Map Ident Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (TypeDecl -> Ident
L.typeName TypeDecl
d, TypeDecl -> Type
L.typeValue TypeDecl
d) | TypeDecl
d <- [TypeDecl]
decls ] in
    DataLayout
-> Map Ident IdentStatus
-> TC TypeContext
-> ([Doc ann], TypeContext)
forall a ann.
DataLayout -> Map Ident IdentStatus -> TC a -> ([Doc ann], a)
runTC DataLayout
dl (Type -> IdentStatus
Pending (Type -> IdentStatus) -> Map Ident Type -> Map Ident IdentStatus
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Ident Type
tps) (TC TypeContext -> ([Doc ann], TypeContext))
-> TC TypeContext -> ([Doc ann], TypeContext)
forall a b. (a -> b) -> a -> b
$
      do AliasMap
aliases <- (Type -> TC SymType)
-> Map Ident Type -> StateT TCState Identity AliasMap
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Map Ident a -> f (Map Ident b)
traverse Type -> TC SymType
tcType Map Ident Type
tps
         TypeContext -> TC TypeContext
forall a. a -> StateT TCState Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DataLayout -> MetadataMap -> AliasMap -> TypeContext
TypeContext DataLayout
dl MetadataMap
mdMap AliasMap
aliases)

-- | Utility function to creates an LLVMContext directly from a model.
typeContextFromModule :: L.Module -> ([Doc ann], TypeContext)
typeContextFromModule :: forall ann. Module -> ([Doc ann], TypeContext)
typeContextFromModule Module
mdl = DataLayout -> MetadataMap -> [TypeDecl] -> ([Doc ann], TypeContext)
forall ann.
DataLayout -> MetadataMap -> [TypeDecl] -> ([Doc ann], TypeContext)
mkTypeContext DataLayout
dl (Module -> MetadataMap
L.mkMdMap Module
mdl) (Module -> [TypeDecl]
L.modTypes Module
mdl)
  where dl :: DataLayout
dl = DataLayout -> DataLayout
parseDataLayout (DataLayout -> DataLayout) -> DataLayout -> DataLayout
forall a b. (a -> b) -> a -> b
$ Module -> DataLayout
L.modDataLayout Module
mdl

liftType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m SymType
liftType :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m SymType
liftType Type
tp | [Doc Any] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Doc Any]
forall {ann}. [Doc ann]
edocs = SymType -> m SymType
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return SymType
stp
            | Bool
otherwise  = String -> m SymType
forall a. String -> m a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (String -> m SymType) -> String -> m SymType
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ((Doc Any -> String) -> [Doc Any] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Doc Any -> String
forall a. Show a => a -> String
show [Doc Any]
forall {ann}. [Doc ann]
edocs)
  where m0 :: Map Ident IdentStatus
m0 = SymType -> IdentStatus
Resolved (SymType -> IdentStatus) -> AliasMap -> Map Ident IdentStatus
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeContext -> AliasMap
llvmAliasMap ?lc::TypeContext
TypeContext
?lc
        ([Doc ann]
edocs,SymType
stp) = DataLayout
-> Map Ident IdentStatus -> TC SymType -> ([Doc ann], SymType)
forall a ann.
DataLayout -> Map Ident IdentStatus -> TC a -> ([Doc ann], a)
runTC (TypeContext -> DataLayout
llvmDataLayout ?lc::TypeContext
TypeContext
?lc) Map Ident IdentStatus
m0 (TC SymType -> ([Doc ann], SymType))
-> TC SymType -> ([Doc ann], SymType)
forall a b. (a -> b) -> a -> b
$ Type -> TC SymType
tcType Type
tp

liftMemType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m MemType
liftMemType :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m MemType
liftMemType Type
tp = SymType -> m MemType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m MemType
asMemType (SymType -> m MemType) -> m SymType -> m MemType
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> m SymType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m SymType
liftType Type
tp

liftRetType :: (?lc :: TypeContext, MonadError String m) => L.Type -> m RetType
liftRetType :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m (Maybe MemType)
liftRetType Type
tp = SymType -> m (Maybe MemType)
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
SymType -> m (Maybe MemType)
asRetType (SymType -> m (Maybe MemType)) -> m SymType -> m (Maybe MemType)
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> m SymType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m SymType
liftType Type
tp

liftDeclare :: (?lc::TypeContext, MonadError String m) => L.Declare -> m FunDecl
liftDeclare :: forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Declare -> m FunDecl
liftDeclare Declare
decl =
  do [MemType]
args <- (Type -> m MemType) -> [Type] -> m [MemType]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> m MemType
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m MemType
liftMemType (Declare -> [Type]
L.decArgs Declare
decl)
     Maybe MemType
ret  <- Type -> m (Maybe MemType)
forall (m :: Type -> Type).
(?lc::TypeContext, MonadError String m) =>
Type -> m (Maybe MemType)
liftRetType (Declare -> Type
L.decRetType Declare
decl)
     FunDecl -> m FunDecl
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FunDecl -> m FunDecl) -> FunDecl -> m FunDecl
forall a b. (a -> b) -> a -> b
$ FunDecl
              { fdRetType :: Maybe MemType
fdRetType  = Maybe MemType
ret
              , fdArgTypes :: [MemType]
fdArgTypes = [MemType]
args
              , fdVarArgs :: Bool
fdVarArgs  = Declare -> Bool
L.decVarArgs Declare
decl
              }

compatStructInfo :: StructInfo -> StructInfo -> Bool
compatStructInfo :: StructInfo -> StructInfo -> Bool
compatStructInfo StructInfo
x StructInfo
y =
  StructInfo -> Bool
siIsPacked StructInfo
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== StructInfo -> Bool
siIsPacked StructInfo
y Bool -> Bool -> Bool
&&
    Vector MemType -> Vector MemType -> Bool
compatMemTypeVectors (StructInfo -> Vector MemType
siFieldTypes StructInfo
x) (StructInfo -> Vector MemType
siFieldTypes StructInfo
y)

-- | Returns true if types are bit-level compatible.
--
compatMemTypes :: MemType -> MemType -> Bool
compatMemTypes :: MemType -> MemType -> Bool
compatMemTypes MemType
x0 MemType
y0 =
  case (MemType
x0, MemType
y0) of
    (IntType Natural
x, IntType Natural
y) -> Natural
x Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
y
    (MemType
FloatType, MemType
FloatType) -> Bool
True
    (MemType
DoubleType, MemType
DoubleType) -> Bool
True
    (PtrType{}, PtrType{})   -> Bool
True
    (MemType
PtrOpaqueType, MemType
PtrOpaqueType) -> Bool
True
    (ArrayType Natural
xn MemType
xt, ArrayType Natural
yn MemType
yt) ->
      Natural
xn Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
yn Bool -> Bool -> Bool
&& MemType
xt MemType -> MemType -> Bool
`compatMemTypes` MemType
yt
    (VecType   Natural
xn MemType
xt, VecType   Natural
yn MemType
yt) ->
      Natural
xn Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
yn Bool -> Bool -> Bool
&& MemType
xt MemType -> MemType -> Bool
`compatMemTypes` MemType
yt
    (StructType StructInfo
x, StructType StructInfo
y) -> StructInfo
x StructInfo -> StructInfo -> Bool
`compatStructInfo` StructInfo
y
    (MemType, MemType)
_ -> Bool
False

compatRetTypes :: RetType -> RetType -> Bool
compatRetTypes :: Maybe MemType -> Maybe MemType -> Bool
compatRetTypes Maybe MemType
Nothing Maybe MemType
Nothing = Bool
True
compatRetTypes (Just MemType
x) (Just MemType
y) = MemType -> MemType -> Bool
compatMemTypes MemType
x MemType
y
compatRetTypes Maybe MemType
_ Maybe MemType
_ = Bool
False

compatMemTypeLists :: [MemType] -> [MemType] -> Bool
compatMemTypeLists :: [MemType] -> [MemType] -> Bool
compatMemTypeLists [] [] = Bool
True
compatMemTypeLists (MemType
x:[MemType]
xl) (MemType
y:[MemType]
yl) =
  MemType -> MemType -> Bool
compatMemTypes MemType
x MemType
y Bool -> Bool -> Bool
&& [MemType] -> [MemType] -> Bool
compatMemTypeLists [MemType]
xl [MemType]
yl
compatMemTypeLists [MemType]
_ [MemType]
_ = Bool
False

compatMemTypeVectors :: V.Vector MemType -> V.Vector MemType -> Bool
compatMemTypeVectors :: Vector MemType -> Vector MemType -> Bool
compatMemTypeVectors Vector MemType
x Vector MemType
y =
  Vector MemType -> Int
forall a. Vector a -> Int
V.length Vector MemType
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector MemType -> Int
forall a. Vector a -> Int
V.length Vector MemType
y Bool -> Bool -> Bool
&&
  Getting All (Vector (MemType, MemType)) (MemType, MemType)
-> ((MemType, MemType) -> Bool)
-> Vector (MemType, MemType)
-> Bool
forall s a. Getting All s a -> (a -> Bool) -> s -> Bool
allOf Getting All (Vector (MemType, MemType)) (MemType, MemType)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Vector a -> f (Vector b)
traverse ((MemType -> MemType -> Bool) -> (MemType, MemType) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MemType -> MemType -> Bool
compatMemTypes) (Vector MemType -> Vector MemType -> Vector (MemType, MemType)
forall a b. Vector a -> Vector b -> Vector (a, b)
V.zip Vector MemType
x Vector MemType
y)