{-# LANGUAGE RecordWildCards #-}

-- | Querying the type of LLVM expressions
module LLVM.AST.Typed (
  Typed(..),
  getElementType,
  getElementPtrType,
  extractValueType,
) where

import LLVM.Prelude

import LLVM.AST
import LLVM.AST.Global
import LLVM.AST.Type

import qualified LLVM.AST.Constant as C
import qualified LLVM.AST.Float as F

class Typed a where
    typeOf :: a -> Type

instance Typed Operand where
  typeOf :: Operand -> Type
typeOf (LocalReference t :: Type
t _) = Type
t
  typeOf (ConstantOperand c :: Constant
c)  = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
c
  typeOf _                    = Type
MetadataType

instance Typed CallableOperand where
  typeOf :: CallableOperand -> Type
typeOf (Right op :: Operand
op) = Operand -> Type
forall a. Typed a => a -> Type
typeOf Operand
op
  typeOf (Left _) = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "typeOf inline assembler is not defined. (Malformed AST)"

instance Typed C.Constant where
  typeOf :: Constant -> Type
typeOf (C.Int bits :: Word32
bits _)  = Word32 -> Type
IntegerType Word32
bits
  typeOf (C.Float t :: SomeFloat
t) = SomeFloat -> Type
forall a. Typed a => a -> Type
typeOf SomeFloat
t
  typeOf (C.Null t :: Type
t)      = Type
t
  typeOf (C.AggregateZero t :: Type
t) = Type
t
  typeOf (C.Struct {..}) = Bool -> [Type] -> Type
StructureType Bool
isPacked ((Constant -> Type) -> [Constant] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Constant -> Type
forall a. Typed a => a -> Type
typeOf [Constant]
memberValues)
  typeOf (C.Array {..})  = Word64 -> Type -> Type
ArrayType (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ [Constant] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constant]
memberValues) Type
memberType
  typeOf (C.Vector {..}) = Word32 -> Type -> Type
VectorType (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [Constant] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Constant]
memberValues) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                              case [Constant]
memberValues of
                                  []    -> [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "Vectors of size zero are not allowed. (Malformed AST)"
                                  (x :: Constant
x:_) -> Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
x
  typeOf (C.Undef t :: Type
t)     = Type
t
  typeOf (C.BlockAddress {..})   = Type -> Type
ptr Type
i8
  typeOf (C.GlobalReference t :: Type
t _) = Type
t
  typeOf (C.Add {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.FAdd {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.FDiv {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.FRem {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.Sub {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.FSub {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.Mul {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.FMul {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.UDiv {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.SDiv {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.URem {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.SRem {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.Shl {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.LShr {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.AShr {..})    = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.And {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.Or  {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.Xor {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0
  typeOf (C.GetElementPtr {..}) = Type -> [Constant] -> Type
getElementPtrType (Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
address) [Constant]
indices
  typeOf (C.Trunc {..})   = Type
type'
  typeOf (C.ZExt {..})    = Type
type'
  typeOf (C.SExt {..})    = Type
type'
  typeOf (C.FPToUI {..})  = Type
type'
  typeOf (C.FPToSI {..})  = Type
type'
  typeOf (C.UIToFP {..})  = Type
type'
  typeOf (C.SIToFP {..})  = Type
type'
  typeOf (C.FPTrunc {..}) = Type
type'
  typeOf (C.FPExt {..})   = Type
type'
  typeOf (C.PtrToInt {..}) = Type
type'
  typeOf (C.IntToPtr {..}) = Type
type'
  typeOf (C.BitCast {..})  = Type
type'
  typeOf (C.ICmp {..})    = case (Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0) of
                              (VectorType n :: Word32
n _) -> Word32 -> Type -> Type
VectorType Word32
n Type
i1
                              _ -> Type
i1
  typeOf (C.FCmp {..})    = case (Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0) of
                              (VectorType n :: Word32
n _) -> Word32 -> Type -> Type
VectorType Word32
n Type
i1
                              _ -> Type
i1
  typeOf (C.Select {..})  = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
trueValue
  typeOf (C.ExtractElement {..})  = case Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
vector of
                                      (VectorType _ t :: Type
t) -> Type
t
                                      _ -> [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)"
  typeOf (C.InsertElement {..})   = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
vector
  typeOf (C.ShuffleVector {..})   = case (Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
operand0, Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
mask) of
                                      (VectorType _ t :: Type
t, VectorType m :: Word32
m _) -> Word32 -> Type -> Type
VectorType Word32
m Type
t
                                      _ -> [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)"
  typeOf (C.ExtractValue {..})    = [Word32] -> Type -> Type
extractValueType [Word32]
indices' (Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
aggregate)
  typeOf (C.InsertValue {..})     = Constant -> Type
forall a. Typed a => a -> Type
typeOf Constant
aggregate
  typeOf (Constant
C.TokenNone)          = Type
TokenType
  typeOf (C.AddrSpaceCast {..}) = Type
type'

getElementPtrType :: Type -> [C.Constant] -> Type
getElementPtrType :: Type -> [Constant] -> Type
getElementPtrType ty :: Type
ty [] = Type -> Type
ptr Type
ty
getElementPtrType (PointerType ty :: Type
ty _) (_:is :: [Constant]
is) = Type -> [Constant] -> Type
getElementPtrType Type
ty [Constant]
is
getElementPtrType (StructureType _ elTys :: [Type]
elTys) (C.Int 32 val :: Integer
val:is :: [Constant]
is) =
  Type -> [Constant] -> Type
getElementPtrType ([Type]
elTys [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
val) [Constant]
is
getElementPtrType (VectorType _ elTy :: Type
elTy) (_:is :: [Constant]
is) = Type -> [Constant] -> Type
getElementPtrType Type
elTy [Constant]
is
getElementPtrType (ArrayType _ elTy :: Type
elTy) (_:is :: [Constant]
is) = Type -> [Constant] -> Type
getElementPtrType Type
elTy [Constant]
is
getElementPtrType _ _ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "Expecting aggregate type. (Malformed AST)"

getElementType :: Type -> Type
getElementType :: Type -> Type
getElementType (PointerType t :: Type
t _) = Type
t
getElementType _ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error ([Char] -> Type) -> [Char] -> Type
forall a b. (a -> b) -> a -> b
$ "Expecting pointer type. (Malformed AST)"

extractValueType :: [Word32] -> Type -> Type
extractValueType :: [Word32] -> Type -> Type
extractValueType [] ty :: Type
ty = Type
ty
extractValueType (i :: Word32
i : is :: [Word32]
is) (ArrayType numEls :: Word64
numEls elTy :: Type
elTy)
  | Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
numEls = [Word32] -> Type -> Type
extractValueType [Word32]
is Type
elTy
  | Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
numEls = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "Expecting valid index into array type. (Malformed AST)"
extractValueType (i :: Word32
i : is :: [Word32]
is) (StructureType _ elTys :: [Type]
elTys)
  | Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
elTys = [Word32] -> Type -> Type
extractValueType [Word32]
is ([Type]
elTys [Type] -> Int -> Type
forall a. [a] -> Int -> a
!! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i)
  | Bool
otherwise = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "Expecting valid index into structure type. (Malformed AST)"
extractValueType _ _ = [Char] -> Type
forall a. HasCallStack => [Char] -> a
error "Expecting vector type. (Malformed AST)"

instance Typed F.SomeFloat where
  typeOf :: SomeFloat -> Type
typeOf (F.Half _)          = FloatingPointType -> Type
FloatingPointType FloatingPointType
HalfFP
  typeOf (F.Single _)        = FloatingPointType -> Type
FloatingPointType FloatingPointType
FloatFP
  typeOf (F.Double _)        = FloatingPointType -> Type
FloatingPointType FloatingPointType
DoubleFP
  typeOf (F.Quadruple _ _)   = FloatingPointType -> Type
FloatingPointType FloatingPointType
FP128FP
  typeOf (F.X86_FP80 _ _)    = FloatingPointType -> Type
FloatingPointType FloatingPointType
X86_FP80FP
  typeOf (F.PPC_FP128 _ _)   = FloatingPointType -> Type
FloatingPointType FloatingPointType
PPC_FP128FP

instance Typed Global where
  typeOf :: Global -> Type
typeOf (GlobalVariable {..}) = Type
type'
  typeOf (GlobalAlias {..})    = Type
type'
  typeOf (Function {..})       = let (params :: [Parameter]
params, isVarArg :: Bool
isVarArg) = ([Parameter], Bool)
parameters
                                   in Type -> [Type] -> Bool -> Type
FunctionType Type
returnType ((Parameter -> Type) -> [Parameter] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Parameter -> Type
forall a. Typed a => a -> Type
typeOf [Parameter]
params) Bool
isVarArg
instance Typed Parameter where
  typeOf :: Parameter -> Type
typeOf (Parameter t :: Type
t _ _) = Type
t