{-# LANGUAGE
  TemplateHaskell,
  ForeignFunctionInterface,
  MultiParamTypeClasses,
  UndecidableInstances,
  ViewPatterns
  #-}
-- | FFI functions for handling the LLVM Constant class
module LLVM.Internal.FFI.Constant where

import LLVM.Prelude

import qualified Language.Haskell.TH as TH
import qualified LLVM.Internal.InstructionDefs as ID

import qualified Data.Map as Map

import Foreign.Ptr
import Foreign.C

import LLVM.Internal.FFI.PtrHierarchy
import LLVM.Internal.FFI.Context
import LLVM.Internal.FFI.Cleanup
import LLVM.Internal.FFI.LLVMCTypes

foreign import ccall unsafe "LLVMIsConstant" isConstant ::
  Ptr Value -> IO (CUInt)

foreign import ccall unsafe "LLVMIsAConstant" isAConstant ::
  Ptr Value -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMIsAConstantInt" isAConstantInt ::
  Ptr Value -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMGetOperand" getConstantOperand ::
  Ptr Constant -> CUInt -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMIsAConstantPointerNull" isAConstantPointerNull ::
  Ptr Value -> IO (Ptr Constant)

foreign import ccall unsafe "LLVM_Hs_GetConstantIntWords" getConstantIntWords ::
  Ptr Constant -> Ptr CUInt -> IO (Ptr Word64)

foreign import ccall unsafe "LLVM_Hs_ConstFloatDoubleValue" constFloatDoubleValue ::
  Ptr Constant -> IO CDouble

foreign import ccall unsafe "LLVM_Hs_ConstFloatFloatValue" constFloatFloatValue ::
  Ptr Constant -> IO CFloat

foreign import ccall unsafe "LLVMConstStructInContext" constStructInContext' ::
  Ptr Context -> Ptr (Ptr Constant) -> CUInt -> LLVMBool -> IO (Ptr Constant)

constStructInContext :: Ptr Context -> (CUInt, Ptr (Ptr Constant)) -> LLVMBool -> IO (Ptr Constant)
constStructInContext :: Ptr Context
-> (CUInt, Ptr (Ptr Constant)) -> LLVMBool -> IO (Ptr Constant)
constStructInContext ctx :: Ptr Context
ctx (n :: CUInt
n, cs :: Ptr (Ptr Constant)
cs) p :: LLVMBool
p = Ptr Context
-> Ptr (Ptr Constant) -> CUInt -> LLVMBool -> IO (Ptr Constant)
constStructInContext' Ptr Context
ctx Ptr (Ptr Constant)
cs CUInt
n LLVMBool
p

foreign import ccall unsafe "LLVMConstNamedStruct" constNamedStruct' ::
  Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)

constNamedStruct :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constNamedStruct :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constNamedStruct ty :: Ptr Type
ty (n :: CUInt
n, cs :: Ptr (Ptr Constant)
cs) = Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
constNamedStruct' Ptr Type
ty Ptr (Ptr Constant)
cs CUInt
n

foreign import ccall unsafe "LLVM_Hs_GetConstantDataSequentialElementAsConstant" getConstantDataSequentialElementAsConstant ::
  Ptr Constant -> CUInt -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMConstIntOfArbitraryPrecision" constantIntOfArbitraryPrecision' ::
  Ptr Type -> CUInt -> Ptr Word64 -> IO (Ptr Constant)

constantIntOfArbitraryPrecision :: Ptr Type -> (CUInt, Ptr Word64) -> IO (Ptr Constant)
constantIntOfArbitraryPrecision :: Ptr Type -> (CUInt, Ptr Word64) -> IO (Ptr Constant)
constantIntOfArbitraryPrecision t :: Ptr Type
t = (CUInt -> Ptr Word64 -> IO (Ptr Constant))
-> (CUInt, Ptr Word64) -> IO (Ptr Constant)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Ptr Type -> CUInt -> Ptr Word64 -> IO (Ptr Constant)
constantIntOfArbitraryPrecision' Ptr Type
t)

foreign import ccall unsafe "LLVM_Hs_ConstFloatOfArbitraryPrecision" constantFloatOfArbitraryPrecision ::
  Ptr Context -> CUInt -> Ptr Word64 -> FloatSemantics -> IO (Ptr Constant)

foreign import ccall unsafe "LLVM_Hs_GetConstantFloatWords" getConstantFloatWords ::
  Ptr Constant -> Ptr Word64 -> IO ()

foreign import ccall unsafe "LLVMConstVector" constantVector' ::
  Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)

constantVector :: (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantVector :: (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantVector (n :: CUInt
n, cs :: Ptr (Ptr Constant)
cs) = Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
constantVector' Ptr (Ptr Constant)
cs CUInt
n

foreign import ccall unsafe "LLVMConstNull" constantNull ::
  Ptr Type -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMConstArray" constantArray' ::
  Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)

constantArray :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantArray :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantArray t :: Ptr Type
t (n :: CUInt
n, cs :: Ptr (Ptr Constant)
cs) = Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
constantArray' Ptr Type
t Ptr (Ptr Constant)
cs CUInt
n

foreign import ccall unsafe "LLVM_Hs_ConstCast" constantCast ::
  CPPOpcode -> Ptr Constant -> Ptr Type -> IO (Ptr Constant)

foreign import ccall unsafe "LLVM_Hs_ConstBinaryOperator" constantBinaryOperator ::
  CPPOpcode -> Ptr Constant -> Ptr Constant -> IO (Ptr Constant)

$(do
   let constExprInfo = ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs
   liftM concat $ sequence $ do
     (name, ((TH.RecC _ (unzip3 -> (_, _, fieldTypes)),_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo
     prefix <- case ik of
                 ID.Other -> return "LLVM"
                 ID.Binary | hasFlags fieldTypes -> return "LLVM_Hs_"
                 _ -> []
     return $
       foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) (map typeMapping fieldTypes) [t| Ptr Constant |]
  )

foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' ::
  Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMConstInBoundsGEP" constantInBoundsGetElementPtr' ::
  Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)

constantGetElementPtr :: LLVMBool -> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantGetElementPtr :: LLVMBool
-> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
constantGetElementPtr (LLVMBool ib :: CUInt
ib) a :: Ptr Constant
a (n :: CUInt
n, is :: Ptr (Ptr Constant)
is) =
  (case CUInt
ib of
     0 -> Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
constantGetElementPtr'
     1 -> Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
constantInBoundsGetElementPtr'
     _ -> [Char]
-> Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
forall a. HasCallStack => [Char] -> a
error ("LLVMBool should be 0 or 1 but is " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> CUInt -> [Char]
forall a. Show a => a -> [Char]
show CUInt
ib)
  ) Ptr Constant
a Ptr (Ptr Constant)
is CUInt
n

foreign import ccall unsafe "LLVM_Hs_GetConstCPPOpcode" getConstantCPPOpcode ::
  Ptr Constant -> IO CPPOpcode

foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantICmpPredicate ::
  Ptr Constant -> IO ICmpPredicate

foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantFCmpPredicate ::
  Ptr Constant -> IO FCmpPredicate

foreign import ccall unsafe "LLVM_Hs_GetConstIndices" getConstantIndices ::
  Ptr Constant -> Ptr CUInt -> IO (Ptr CUInt)

foreign import ccall unsafe "LLVMGetUndef" constantUndef ::
  Ptr Type -> IO (Ptr Constant)

foreign import ccall unsafe "LLVMBlockAddress" blockAddress ::
  Ptr Value -> Ptr BasicBlock -> IO (Ptr Constant)

foreign import ccall unsafe "LLVM_Hs_GetBlockAddressFunction" getBlockAddressFunction ::
  Ptr Constant -> IO (Ptr Value)

foreign import ccall unsafe "LLVM_Hs_GetBlockAddressBlock" getBlockAddressBlock ::
  Ptr Constant -> IO (Ptr BasicBlock)

foreign import ccall unsafe "LLVM_Hs_GetConstTokenNone" getConstTokenNone ::
  Ptr Context -> IO (Ptr Constant)