{-# LANGUAGE
  TemplateHaskell,
  QuasiQuotes,
  MultiParamTypeClasses,
  ScopedTypeVariables
  #-}
module LLVM.Internal.Constant where

import LLVM.Prelude

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

import Data.Bits
import Control.Monad.AnyCont
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.State (get, gets, modify, evalState)

import qualified Data.Map as Map
import Foreign.Ptr
import Foreign.Storable (Storable, sizeOf)

import qualified LLVM.Internal.FFI.Constant as FFI
import qualified LLVM.Internal.FFI.GlobalValue as FFI
import qualified LLVM.Internal.FFI.Instruction as FFI
import qualified LLVM.Internal.FFI.LLVMCTypes as FFI
import LLVM.Internal.FFI.LLVMCTypes (valueSubclassIdP)
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI
import qualified LLVM.Internal.FFI.Type as FFI
import qualified LLVM.Internal.FFI.User as FFI
import qualified LLVM.Internal.FFI.Value as FFI
import qualified LLVM.Internal.FFI.BinaryOperator as FFI

import qualified LLVM.AST.Constant as A (Constant)
import qualified LLVM.AST.Constant as A.C hiding (Constant)
import qualified LLVM.AST.Type as A
import qualified LLVM.AST.IntegerPredicate as A (IntegerPredicate)
import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate)
import qualified LLVM.AST.Float as A.F

import LLVM.Exception
import LLVM.Internal.Coding
import LLVM.Internal.Context
import LLVM.Internal.DecodeAST
import LLVM.Internal.EncodeAST
import LLVM.Internal.FloatingPointPredicate ()
import LLVM.Internal.IntegerPredicate ()
import LLVM.Internal.Type (renameType)
import LLVM.Internal.Value

allocaWords :: forall a m . (Storable a, MonadAnyCont IO m, Monad m, MonadIO m) => Word32 -> m (Ptr a)
allocaWords :: forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m, Monad m, MonadIO m) =>
Word32 -> m (Ptr a)
allocaWords Word32
nBits = do
  Word32 -> m (Ptr a)
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray (((Word32
nBitsWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` (Word32
8Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
*(Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))))) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)

inconsistentCases :: Show a => String -> a -> b
inconsistentCases :: forall a b. Show a => String -> a -> b
inconsistentCases String
name a
attr =
  String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"llvm-hs internal error: cases inconstistent in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" encoding for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
attr

instance EncodeM EncodeAST A.Constant (Ptr FFI.Constant) where
  encodeM :: HasCallStack => Constant -> EncodeAST (Ptr Constant)
encodeM Constant
c = EncodeAST (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. EncodeAST a -> EncodeAST a
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (EncodeAST (Ptr Constant) -> EncodeAST (Ptr Constant))
-> EncodeAST (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ case Constant
c of
    A.C.Int { integerBits :: Constant -> Word32
A.C.integerBits = Word32
bits, integerValue :: Constant -> Integer
A.C.integerValue = Integer
v } -> do
      Ptr Type
t <- Type -> EncodeAST (Ptr Type)
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM (Word32 -> Type
A.IntegerType Word32
bits)
      (CUInt, Ptr Word64)
words <- [Word64] -> EncodeAST (CUInt, Ptr Word64)
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM [
        Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Integer
v Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` (Int
wInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
64)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xffffffffffffffff) :: Word64
        | Int
w <- [Int
0 .. ((Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
bitsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
64)]
       ]
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> (CUInt, Ptr Word64) -> IO (Ptr Constant)
FFI.constantIntOfArbitraryPrecision Ptr Type
t (CUInt, Ptr Word64)
words
    A.C.Float { floatValue :: Constant -> SomeFloat
A.C.floatValue = SomeFloat
v } -> do
      Context Ptr Context
context <- (EncodeState -> Context) -> EncodeAST Context
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Context
encodeStateContext
      let poke1 :: a -> m (Word32, Ptr a)
poke1 a
f = do
            let nBits :: Word32
nBits = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*(a -> Int
forall a. Storable a => a -> Int
sizeOf a
f)
            Ptr a
words <- Word32 -> m (Ptr a)
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m, Monad m, MonadIO m) =>
Word32 -> m (Ptr a)
allocaWords Word32
nBits
            Ptr a -> a -> m ()
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> a -> m ()
poke (Ptr a -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr a
words) a
f
            (Word32, Ptr a) -> m (Word32, Ptr a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
nBits, Ptr a
words)
          poke2 :: a -> a -> m (Word32, Ptr a)
poke2 a
fh a
fl = do
             let nBits :: Word32
nBits = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*(a -> Int
forall a. Storable a => a -> Int
sizeOf a
fh) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*(a -> Int
forall a. Storable a => a -> Int
sizeOf a
fl)
             Ptr a
words <- Word32 -> m (Ptr a)
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m, Monad m, MonadIO m) =>
Word32 -> m (Ptr a)
allocaWords Word32
nBits
             Ptr a -> Int -> a -> m ()
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> a -> m ()
pokeByteOff (Ptr a -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr a
words) Int
0 a
fl
             Ptr a -> Int -> a -> m ()
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> a -> m ()
pokeByteOff (Ptr a -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr a
words) (a -> Int
forall a. Storable a => a -> Int
sizeOf a
fl) a
fh
             (Word32, Ptr a) -> m (Word32, Ptr a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
nBits, Ptr a
words)
      (Word32
nBits, Ptr Word64
words) <- case SomeFloat
v of
        A.F.Half Word16
f -> Word16 -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a) =>
a -> m (Word32, Ptr a)
poke1 Word16
f
        A.F.Single Float
f -> Float -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a) =>
a -> m (Word32, Ptr a)
poke1 Float
f
        A.F.Double Double
f -> Double -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a) =>
a -> m (Word32, Ptr a)
poke1 Double
f
        A.F.X86_FP80 Word16
high Word64
low -> Word16 -> Word64 -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a,
 Storable a) =>
a -> a -> m (Word32, Ptr a)
poke2 Word16
high Word64
low
        A.F.Quadruple Word64
high Word64
low -> Word64 -> Word64 -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a,
 Storable a) =>
a -> a -> m (Word32, Ptr a)
poke2 Word64
high Word64
low
        A.F.PPC_FP128 Word64
high Word64
low -> Word64 -> Word64 -> EncodeAST (Word32, Ptr Word64)
forall {m :: * -> *} {a} {a} {a}.
(MonadAnyCont IO m, MonadIO m, Storable a, Storable a,
 Storable a) =>
a -> a -> m (Word32, Ptr a)
poke2 Word64
high Word64
low
      let fpSem :: FloatSemantics
fpSem = case SomeFloat
v of
                    A.F.Half Word16
_ -> FloatSemantics
FFI.floatSemanticsIEEEhalf
                    A.F.Single Float
_ -> FloatSemantics
FFI.floatSemanticsIEEEsingle
                    A.F.Double Double
_ -> FloatSemantics
FFI.floatSemanticsIEEEdouble
                    A.F.Quadruple Word64
_ Word64
_ -> FloatSemantics
FFI.floatSemanticsIEEEquad
                    A.F.X86_FP80 Word16
_ Word64
_ -> FloatSemantics
FFI.floatSemanticsx87DoubleExtended
                    A.F.PPC_FP128 Word64
_ Word64
_ -> FloatSemantics
FFI.floatSemanticsPPCDoubleDouble
      CUInt
nBits <- Word32 -> EncodeAST CUInt
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM Word32
nBits
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Context
-> CUInt -> Ptr Word64 -> FloatSemantics -> IO (Ptr Constant)
FFI.constantFloatOfArbitraryPrecision Ptr Context
context CUInt
nBits Ptr Word64
words FloatSemantics
fpSem
    A.C.GlobalReference Type
ty Name
n -> do
      Ptr Constant
ref <- Ptr GlobalValue -> Ptr Constant
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr GlobalValue -> Ptr Constant)
-> EncodeAST (Ptr GlobalValue) -> EncodeAST (Ptr Constant)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> EncodeAST (Ptr GlobalValue)
referGlobal Name
n
      Type
ty' <- (IO Type -> EncodeAST Type
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Type -> EncodeAST Type)
-> (Ptr Constant -> IO Type) -> Ptr Constant -> EncodeAST Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeAST Type -> IO Type
forall a. DecodeAST a -> IO a
runDecodeAST (DecodeAST Type -> IO Type)
-> (Ptr Constant -> DecodeAST Type) -> Ptr Constant -> IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Constant -> DecodeAST Type
forall v. DescendentOf Value v => Ptr v -> DecodeAST Type
typeOf) Ptr Constant
ref
      Type
renamedTy <- Type -> EncodeAST Type
renameType Type
ty
      if Type
renamedTy Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Type
ty'
        then EncodeException -> EncodeAST (Ptr Constant)
forall e a. Exception e => e -> EncodeAST a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
               (String -> EncodeException
EncodeException
                  (String
"The serialized GlobalReference " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but should have type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty'))
        else Ptr Constant -> EncodeAST (Ptr Constant)
forall a. a -> EncodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Constant
ref
    A.C.BlockAddress Name
f Name
b -> do
      Ptr GlobalValue
f' <- Name -> EncodeAST (Ptr GlobalValue)
referGlobal Name
f
      Ptr BasicBlock
b' <- Name -> Name -> EncodeAST (Ptr BasicBlock)
getBlockForAddress Name
f Name
b
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Value -> Ptr BasicBlock -> IO (Ptr Constant)
FFI.blockAddress (Ptr GlobalValue -> Ptr Value
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr GlobalValue
f') Ptr BasicBlock
b'
    A.C.Struct Maybe Name
nm Bool
p [Constant]
ms -> do
      LLVMBool
p <- Bool -> EncodeAST LLVMBool
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM Bool
p
      (CUInt, Ptr (Ptr Constant))
ms <- [Constant] -> EncodeAST (CUInt, Ptr (Ptr Constant))
forall (e :: * -> *) h c. (EncodeM e h c, HasCallStack) => h -> e c
encodeM [Constant]
ms
      case Maybe Name
nm of
        Maybe Name
Nothing -> do
          Context Ptr Context
context <- (EncodeState -> Context) -> EncodeAST Context
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Context
encodeStateContext
          IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Context
-> (CUInt, Ptr (Ptr Constant)) -> LLVMBool -> IO (Ptr Constant)
FFI.constStructInContext Ptr Context
context (CUInt, Ptr (Ptr Constant))
ms LLVMBool
p
        Just Name
nm -> do
          Ptr Type
t <- Name -> EncodeAST (Ptr Type)
lookupNamedType Name
nm
          IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant)
FFI.constNamedStruct Ptr Type
t (CUInt, Ptr (Ptr Constant))
ms
    Constant
A.C.TokenNone -> do
      Context Ptr Context
context <- (EncodeState -> Context) -> EncodeAST Context
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Context
encodeStateContext
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a. IO a -> EncodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> EncodeAST (Ptr Constant))
-> IO (Ptr Constant) -> EncodeAST (Ptr Constant)
forall a b. (a -> b) -> a -> b
$ Ptr Context -> IO (Ptr Constant)
FFI.getConstTokenNone Ptr Context
context
    Constant
o -> $(do
      let -- This is a mapping from constructor names to the constructor of the constant
          -- and the constructor and the definition of the instruction.
          constExprInfo :: Map.Map String (Maybe TH.Con, Maybe (TH.Con, ID.InstructionDef))
          constExprInfo =  ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs)
      TH.caseE [| o |] $
        map (\p -> TH.match p (TH.normalB [|inconsistentCases "Constant" o|]) [])
            [[p|A.C.Int{}|],
             [p|A.C.Float{}|],
             [p|A.C.Struct{}|],
             [p|A.C.BlockAddress{}|],
             [p|A.C.GlobalReference{}|],
             [p|A.C.TokenNone{}|]] ++
        (do (name, (Just (TH.RecC n fields), instrInfo)) <- Map.toList constExprInfo
            let fieldNames = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fields ]
                coreCall n = TH.dyn $ "FFI.constant" ++ n
                -- Addition validations that are run during encoding. A common usage of
                -- this is to check if certain types are allowed. The record fields are in scope
                -- when the validations are run.
                validations = case name of
                  "Null" ->
                    [ TH.noBindS
                        [| case $(TH.dyn "constantType") of
                             A.PointerType {} -> pure ()
                             _ ->
                               throwM
                                 (EncodeException
                                    ("Null pointer constant must have pointer type but has type " <>
                                     show $(TH.dyn "constantType") <> "."))
                        |]
                    ]
                  "AggregateZero" ->
                    [ TH.noBindS $
                        [| case $(TH.dyn "constantType") of
                             A.ArrayType {} -> pure ()
                             A.StructureType {} -> pure ()
                             A.VectorType {} -> pure ()
                             A.NamedTypeReference {} -> pure ()
                             _ ->
                               throwM
                                 (EncodeException
                                    ("Aggregate zero constant must have struct, array or vector type but has type " <>
                                     show $(TH.dyn "constantType") <> "."))
                        |]
                    ]
                  _ -> []
                buildBody c =
                  validations ++
                  [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fieldNames ] ++
                  [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fieldNames)) |] ]
                hasFlags = ''Bool `elem` [ h | (_, _, TH.ConT h) <- fields ]
            core <- case instrInfo of
              Just (_, iDef) -> do
                let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef)
                case ID.instructionKind iDef of
                  ID.Binary
                    | hasFlags -> return $ coreCall name
                    | otherwise -> return [| $(coreCall "BinaryOperator") $(opcode) |]
                  ID.Cast -> return [| $(coreCall "Cast") $(opcode) |]
                  _ -> return $ coreCall name
              Nothing ->
                case name of
                  "Array" -> pure (TH.varE 'FFI.constantArray)
                  "AggregateZero" -> pure (TH.varE 'FFI.constantNull)
                  "Null" -> pure (TH.varE 'FFI.constantNull)
                  "Undef" -> pure (TH.varE 'FFI.constantUndef)
                  "Vector" -> pure (TH.varE 'FFI.constantVector)
                  _ -> [] -- We have already handled these values
            return $ TH.match
              (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fields])
              (TH.normalB (TH.doE (buildBody core)))
              [])
     )

instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where
  decodeM :: HasCallStack => Ptr Constant -> DecodeAST Constant
decodeM Ptr Constant
c = DecodeAST Constant -> DecodeAST Constant
forall a. DecodeAST a -> DecodeAST a
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (DecodeAST Constant -> DecodeAST Constant)
-> DecodeAST Constant -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ do
    let v :: Ptr Value
v = Ptr Constant -> Ptr Value
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Constant
c :: Ptr FFI.Value
        u :: Ptr User
u = Ptr Constant -> Ptr User
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Constant
c :: Ptr FFI.User
    Ptr Type
ft <- IO (Ptr Type) -> DecodeAST (Ptr Type)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Value -> IO (Ptr Type)
FFI.typeOf Ptr Value
v)
    Type
t <- Ptr Type -> DecodeAST Type
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM Ptr Type
ft
    ValueSubclassId
valueSubclassId <- IO ValueSubclassId -> DecodeAST ValueSubclassId
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ValueSubclassId -> DecodeAST ValueSubclassId)
-> IO ValueSubclassId -> DecodeAST ValueSubclassId
forall a b. (a -> b) -> a -> b
$ Ptr Value -> IO ValueSubclassId
FFI.getValueSubclassId Ptr Value
v
    CUInt
nOps <- IO CUInt -> DecodeAST CUInt
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CUInt -> DecodeAST CUInt) -> IO CUInt -> DecodeAST CUInt
forall a b. (a -> b) -> a -> b
$ Ptr User -> IO CUInt
FFI.getNumOperands Ptr User
u
    let globalRef :: DecodeAST Constant
globalRef = (Type -> Name -> Constant) -> DecodeAST (Type -> Name -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> Name -> Constant
A.C.GlobalReference
                    DecodeAST (Type -> Name -> Constant)
-> DecodeAST Type -> DecodeAST (Name -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Type -> DecodeAST Type
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t)
                    DecodeAST (Name -> Constant)
-> DecodeAST Name -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr GlobalValue -> DecodeAST Name
forall v. DescendentOf GlobalValue v => Ptr v -> DecodeAST Name
getGlobalName (Ptr GlobalValue -> DecodeAST Name)
-> DecodeAST (Ptr GlobalValue) -> DecodeAST Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr GlobalValue) -> DecodeAST (Ptr GlobalValue)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Value -> IO (Ptr GlobalValue)
FFI.isAGlobalValue Ptr Value
v))
        op :: CUInt -> DecodeAST Constant
op = Ptr Constant -> DecodeAST Constant
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (Ptr Constant -> DecodeAST Constant)
-> (CUInt -> DecodeAST (Ptr Constant))
-> CUInt
-> DecodeAST Constant
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Ptr Constant) -> DecodeAST (Ptr Constant)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> DecodeAST (Ptr Constant))
-> (CUInt -> IO (Ptr Constant))
-> CUInt
-> DecodeAST (Ptr Constant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Constant -> CUInt -> IO (Ptr Constant)
FFI.getConstantOperand Ptr Constant
c
        getConstantOperands :: DecodeAST [Constant]
getConstantOperands = (CUInt -> DecodeAST Constant) -> [CUInt] -> DecodeAST [Constant]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CUInt -> DecodeAST Constant
op [CUInt
0..CUInt
nOpsCUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
-CUInt
1]
        getConstantData :: DecodeAST [Constant]
getConstantData = do
          let nElements :: Word32
nElements =
                case Type
t of
                  A.VectorType Word32
n Type
_ -> Word32
n
                  A.ArrayType Word64
n Type
_ | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
forall a. Bounded a => a
maxBound :: Word32)) -> Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
                  Type
_ -> String -> Word32
forall a. HasCallStack => String -> a
error String
"getConstantData can only be applied to vectors and arrays"
          [Word32] -> (Word32 -> DecodeAST Constant) -> DecodeAST [Constant]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word32
0..Word32
nElementsWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1] ((Word32 -> DecodeAST Constant) -> DecodeAST [Constant])
-> (Word32 -> DecodeAST Constant) -> DecodeAST [Constant]
forall a b. (a -> b) -> a -> b
$ do
             Ptr Constant -> DecodeAST Constant
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (Ptr Constant -> DecodeAST Constant)
-> (Word32 -> DecodeAST (Ptr Constant))
-> Word32
-> DecodeAST Constant
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Ptr Constant) -> DecodeAST (Ptr Constant)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Constant) -> DecodeAST (Ptr Constant))
-> (Word32 -> IO (Ptr Constant))
-> Word32
-> DecodeAST (Ptr Constant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Constant -> CUInt -> IO (Ptr Constant)
FFI.getConstantDataSequentialElementAsConstant Ptr Constant
c (CUInt -> IO (Ptr Constant))
-> (Word32 -> CUInt) -> Word32 -> IO (Ptr Constant)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral

    case ValueSubclassId
valueSubclassId of
      ValueSubclassId
[valueSubclassIdP|Function|] -> DecodeAST Constant
globalRef
      ValueSubclassId
[valueSubclassIdP|GlobalAlias|] -> DecodeAST Constant
globalRef
      ValueSubclassId
[valueSubclassIdP|GlobalVariable|] -> DecodeAST Constant
globalRef
      ValueSubclassId
[valueSubclassIdP|ConstantInt|] -> do
        Ptr CUInt
np <- DecodeAST (Ptr CUInt)
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m) =>
m (Ptr a)
alloca
        Ptr Word64
wsp <- IO (Ptr Word64) -> DecodeAST (Ptr Word64)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Word64) -> DecodeAST (Ptr Word64))
-> IO (Ptr Word64) -> DecodeAST (Ptr Word64)
forall a b. (a -> b) -> a -> b
$ Ptr Constant -> Ptr CUInt -> IO (Ptr Word64)
FFI.getConstantIntWords Ptr Constant
c Ptr CUInt
np
        CUInt
n <- Ptr CUInt -> DecodeAST CUInt
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek Ptr CUInt
np
        [Word64]
words <- (CUInt, Ptr Word64) -> DecodeAST [Word64]
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (CUInt
n, Ptr Word64
wsp)
        Constant -> DecodeAST Constant
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constant -> DecodeAST Constant) -> Constant -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ Word32 -> Integer -> Constant
A.C.Int (Type -> Word32
A.typeBits Type
t) ((Word64 -> Integer -> Integer) -> Integer -> [Word64] -> Integer
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Word64
b Integer
a -> (Integer
a Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
64) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
b) Integer
0 ([Word64]
words :: [Word64]))
      ValueSubclassId
[valueSubclassIdP|ConstantFP|] -> do
        let A.FloatingPointType FloatingPointType
fpt = Type
t
        let nBits :: Word32
nBits = case FloatingPointType
fpt of
                FloatingPointType
A.HalfFP      -> Word32
16
                FloatingPointType
A.FloatFP     -> Word32
32
                FloatingPointType
A.DoubleFP    -> Word32
64
                FloatingPointType
A.FP128FP     -> Word32
128
                FloatingPointType
A.X86_FP80FP  -> Word32
80
                FloatingPointType
A.PPC_FP128FP -> Word32
128
        Ptr Word64
ws <- Word32 -> DecodeAST (Ptr Word64)
forall a (m :: * -> *).
(Storable a, MonadAnyCont IO m, Monad m, MonadIO m) =>
Word32 -> m (Ptr a)
allocaWords Word32
nBits
        IO () -> DecodeAST ()
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Constant -> Ptr Word64 -> IO ()
FFI.getConstantFloatWords Ptr Constant
c Ptr Word64
ws
        SomeFloat -> Constant
A.C.Float (SomeFloat -> Constant)
-> DecodeAST SomeFloat -> DecodeAST Constant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
          case FloatingPointType
fpt of
            FloatingPointType
A.HalfFP      -> Word16 -> SomeFloat
A.F.Half (Word16 -> SomeFloat) -> DecodeAST Word16 -> DecodeAST SomeFloat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word16 -> DecodeAST Word16
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek (Ptr Word64 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws)
            FloatingPointType
A.FloatFP     -> Float -> SomeFloat
A.F.Single (Float -> SomeFloat) -> DecodeAST Float -> DecodeAST SomeFloat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Float -> DecodeAST Float
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek (Ptr Word64 -> Ptr Float
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws)
            FloatingPointType
A.DoubleFP    -> Double -> SomeFloat
A.F.Double (Double -> SomeFloat) -> DecodeAST Double -> DecodeAST SomeFloat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Double -> DecodeAST Double
forall a (m :: * -> *). (Storable a, MonadIO m) => Ptr a -> m a
peek (Ptr Word64 -> Ptr Double
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws)
            FloatingPointType
A.FP128FP     -> Word64 -> Word64 -> SomeFloat
A.F.Quadruple (Word64 -> Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST (Word64 -> SomeFloat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word64 -> Int -> DecodeAST Word64
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
forall a b. DecodeAST (a -> b) -> DecodeAST a -> DecodeAST b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Word64 -> Int -> DecodeAST Word64
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
0
            FloatingPointType
A.X86_FP80FP  -> Word16 -> Word64 -> SomeFloat
A.F.X86_FP80 (Word16 -> Word64 -> SomeFloat)
-> DecodeAST Word16 -> DecodeAST (Word64 -> SomeFloat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word16 -> Int -> DecodeAST Word16
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
forall a b. DecodeAST (a -> b) -> DecodeAST a -> DecodeAST b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Word64 -> Int -> DecodeAST Word64
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
0
            FloatingPointType
A.PPC_FP128FP -> Word64 -> Word64 -> SomeFloat
A.F.PPC_FP128 (Word64 -> Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST (Word64 -> SomeFloat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word64 -> Int -> DecodeAST Word64
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
forall a b. DecodeAST (a -> b) -> DecodeAST a -> DecodeAST b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr Word64 -> Int -> DecodeAST Word64
forall a (m :: * -> *).
(Storable a, MonadIO m) =>
Ptr a -> Int -> m a
peekByteOff (Ptr Word64 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
ws) Int
0
          )
      ValueSubclassId
[valueSubclassIdP|ConstantPointerNull|] -> Constant -> DecodeAST Constant
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constant -> DecodeAST Constant) -> Constant -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ Type -> Constant
A.C.Null Type
t
      ValueSubclassId
[valueSubclassIdP|ConstantAggregateZero|] -> Constant -> DecodeAST Constant
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constant -> DecodeAST Constant) -> Constant -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ Type -> Constant
A.C.AggregateZero Type
t
      ValueSubclassId
[valueSubclassIdP|UndefValue|] -> Constant -> DecodeAST Constant
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constant -> DecodeAST Constant) -> Constant -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ Type -> Constant
A.C.Undef Type
t
      ValueSubclassId
[valueSubclassIdP|BlockAddress|] ->
            (Name -> Name -> Constant) -> DecodeAST (Name -> Name -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Name -> Name -> Constant
A.C.BlockAddress
               DecodeAST (Name -> Name -> Constant)
-> DecodeAST Name -> DecodeAST (Name -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr GlobalValue -> DecodeAST Name
forall v. DescendentOf GlobalValue v => Ptr v -> DecodeAST Name
getGlobalName (Ptr GlobalValue -> DecodeAST Name)
-> DecodeAST (Ptr GlobalValue) -> DecodeAST Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do IO (Ptr GlobalValue) -> DecodeAST (Ptr GlobalValue)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr GlobalValue) -> DecodeAST (Ptr GlobalValue))
-> IO (Ptr GlobalValue) -> DecodeAST (Ptr GlobalValue)
forall a b. (a -> b) -> a -> b
$ Ptr Value -> IO (Ptr GlobalValue)
FFI.isAGlobalValue (Ptr Value -> IO (Ptr GlobalValue))
-> IO (Ptr Value) -> IO (Ptr GlobalValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Constant -> IO (Ptr Value)
FFI.getBlockAddressFunction Ptr Constant
c)
               DecodeAST (Name -> Constant)
-> DecodeAST Name -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Ptr BasicBlock -> DecodeAST Name
forall v. DescendentOf Value v => Ptr v -> DecodeAST Name
getLocalName (Ptr BasicBlock -> DecodeAST Name)
-> DecodeAST (Ptr BasicBlock) -> DecodeAST Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock))
-> IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall a b. (a -> b) -> a -> b
$ Ptr Constant -> IO (Ptr BasicBlock)
FFI.getBlockAddressBlock Ptr Constant
c)
      ValueSubclassId
[valueSubclassIdP|ConstantStruct|] -> do
            (Maybe Name -> Bool -> [Constant] -> Constant)
-> DecodeAST (Maybe Name -> Bool -> [Constant] -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name -> Bool -> [Constant] -> Constant
A.C.Struct
               DecodeAST (Maybe Name -> Bool -> [Constant] -> Constant)
-> DecodeAST (Maybe Name)
-> DecodeAST (Bool -> [Constant] -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Maybe Name -> DecodeAST (Maybe Name)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Name -> DecodeAST (Maybe Name))
-> Maybe Name -> DecodeAST (Maybe Name)
forall a b. (a -> b) -> a -> b
$ case Type
t of A.NamedTypeReference Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n; Type
_ -> Maybe Name
forall a. Maybe a
Nothing)
               DecodeAST (Bool -> [Constant] -> Constant)
-> DecodeAST Bool -> DecodeAST ([Constant] -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (LLVMBool -> DecodeAST Bool
forall (d :: * -> *) h c. (DecodeM d h c, HasCallStack) => c -> d h
decodeM (LLVMBool -> DecodeAST Bool)
-> DecodeAST LLVMBool -> DecodeAST Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO LLVMBool -> DecodeAST LLVMBool
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Type -> IO LLVMBool
FFI.isPackedStruct Ptr Type
ft))
               DecodeAST ([Constant] -> Constant)
-> DecodeAST [Constant] -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DecodeAST [Constant]
getConstantOperands
      ValueSubclassId
[valueSubclassIdP|ConstantDataArray|] ->
            (Type -> [Constant] -> Constant)
-> DecodeAST (Type -> [Constant] -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> [Constant] -> Constant
A.C.Array DecodeAST (Type -> [Constant] -> Constant)
-> DecodeAST Type -> DecodeAST ([Constant] -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Type -> DecodeAST Type
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
A.elementType Type
t) DecodeAST ([Constant] -> Constant)
-> DecodeAST [Constant] -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DecodeAST [Constant]
getConstantData
      ValueSubclassId
[valueSubclassIdP|ConstantArray|] ->
            (Type -> [Constant] -> Constant)
-> DecodeAST (Type -> [Constant] -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Type -> [Constant] -> Constant
A.C.Array DecodeAST (Type -> [Constant] -> Constant)
-> DecodeAST Type -> DecodeAST ([Constant] -> Constant)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (Type -> DecodeAST Type
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> DecodeAST Type) -> Type -> DecodeAST Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
A.elementType Type
t) DecodeAST ([Constant] -> Constant)
-> DecodeAST [Constant] -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DecodeAST [Constant]
getConstantOperands
      ValueSubclassId
[valueSubclassIdP|ConstantDataVector|] ->
            ([Constant] -> Constant) -> DecodeAST ([Constant] -> Constant)
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return [Constant] -> Constant
A.C.Vector DecodeAST ([Constant] -> Constant)
-> DecodeAST [Constant] -> DecodeAST Constant
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` DecodeAST [Constant]
getConstantData
      ValueSubclassId
[valueSubclassIdP|ConstantVector|] ->
            [Constant] -> Constant
A.C.Vector ([Constant] -> Constant)
-> DecodeAST [Constant] -> DecodeAST Constant
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecodeAST [Constant]
getConstantOperands
      ValueSubclassId
[valueSubclassIdP|ConstantExpr|] -> do
            CPPOpcode
cppOpcode <- IO CPPOpcode -> DecodeAST CPPOpcode
forall a. IO a -> DecodeAST a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CPPOpcode -> DecodeAST CPPOpcode)
-> IO CPPOpcode -> DecodeAST CPPOpcode
forall a b. (a -> b) -> a -> b
$ Ptr Constant -> IO CPPOpcode
FFI.getConstantCPPOpcode Ptr Constant
c
            $(
              TH.caseE [| cppOpcode |] $
                (do (_, ((TH.RecC n fs, _), iDef)) <- Map.toList $
                          ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs
                    let apWrapper o (fn, _, ct) = do
                          a <- case ct of
                                 TH.ConT h
                                   | h == ''A.Constant -> do
                                                   operandNumber <- get
                                                   modify (+1)
                                                   return [| op $(TH.litE . TH.integerL $ operandNumber) |]
                                   | h == ''A.Type -> return [| pure t |]
                                   | h == ''A.IntegerPredicate ->
                                     return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |]
                                   | h == ''A.FloatingPointPredicate ->
                                     return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |]
                                   | h == ''Bool -> case TH.nameBase fn of
                                                      "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |]
                                                      "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |]
                                                      "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |]
                                                      "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |]
                                                      x -> error $ "constant bool field " ++ show x ++ " not handled yet"
                                 TH.AppT TH.ListT (TH.ConT h)
                                   | h == ''Word32 ->
                                      return [|
                                            do
                                              np <- alloca
                                              isp <- liftIO $ FFI.getConstantIndices c np
                                              n <- peek np
                                              decodeM (n, isp)
                                            |]
                                   | h == ''A.Constant &&
                                     TH.nameBase fn == "indices" -> do
                                       operandNumber <- get
                                       return [| mapM op [$(TH.litE . TH.integerL $ operandNumber)..nOps-1] |]

                                 _ -> error $ "unhandled constant expr field type: " ++ show fn ++ " - " ++ show ct
                          return [| $(o) `ap` $(a) |]
                    return $ TH.match
                              (TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef))
                              (TH.normalB (evalState (foldM apWrapper [| return $(TH.conE n) |] fs) 0))
                              [])
                ++ [TH.match TH.wildP (TH.normalB [|error ("Unknown constant opcode: " <> show cppOpcode)|]) []]
             )
      ValueSubclassId
[valueSubclassIdP|ConstantTokenNone|] -> Constant -> DecodeAST Constant
forall a. a -> DecodeAST a
forall (m :: * -> *) a. Monad m => a -> m a
return Constant
A.C.TokenNone
      ValueSubclassId
_ -> String -> DecodeAST Constant
forall a. HasCallStack => String -> a
error (String -> DecodeAST Constant) -> String -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ String
"unhandled constant valueSubclassId: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueSubclassId -> String
forall a. Show a => a -> String
show ValueSubclassId
valueSubclassId