{-# 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 :: Word32 -> m (Ptr a)
allocaWords nBits :: 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
-1) Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` (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
+ 1)

inconsistentCases :: Show a => String -> a -> b
inconsistentCases :: String -> a -> b
inconsistentCases name :: String
name attr :: a
attr =
  String -> b
forall a. HasCallStack => String -> a
error (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ "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]
++ " 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 :: Constant -> EncodeAST (Ptr Constant)
encodeM c :: Constant
c = EncodeAST (Ptr Constant) -> EncodeAST (Ptr Constant)
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 => 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 => 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
*64)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. 0xffffffffffffffff) :: Word64
        | Int
w <- [0 .. ((Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
bitsInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 64)]
       ]
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
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 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 f :: 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
$ 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 (m :: * -> *) a. Monad m => a -> m a
return (Word32
nBits, Ptr a
words)
          poke2 :: a -> a -> m (Word32, Ptr a)
poke2 fh :: a
fh fl :: 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
$ 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
+ 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) 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 (m :: * -> *) a. Monad m => a -> m a
return (Word32
nBits, Ptr a
words)
      (nBits :: Word32
nBits, words :: Ptr Word64
words) <- case SomeFloat
v of
        A.F.Half f :: 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 f :: 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 f :: 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 high :: Word16
high low :: 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 high :: Word64
high low :: 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 high :: Word64
high low :: 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 _ -> FloatSemantics
FFI.floatSemanticsIEEEhalf
                    A.F.Single _ -> FloatSemantics
FFI.floatSemanticsIEEEsingle
                    A.F.Double _ -> FloatSemantics
FFI.floatSemanticsIEEEdouble
                    A.F.Quadruple _ _ -> FloatSemantics
FFI.floatSemanticsIEEEquad
                    A.F.X86_FP80 _ _ -> FloatSemantics
FFI.floatSemanticsx87DoubleExtended
                    A.F.PPC_FP128 _ _ -> FloatSemantics
FFI.floatSemanticsPPCDoubleDouble
      CUInt
nBits <- Word32 -> EncodeAST CUInt
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Word32
nBits
      IO (Ptr Constant) -> EncodeAST (Ptr Constant)
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 ty :: Type
ty n :: 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 (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 (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
               (String -> EncodeException
EncodeException
                  ("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]
++ " 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]
++ " 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 (m :: * -> *) a. Monad m => a -> m a
return Ptr Constant
ref
    A.C.BlockAddress f :: Name
f b :: 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 (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 nm :: Maybe Name
nm p :: Bool
p ms :: [Constant]
ms -> do
      LLVMBool
p <- Bool -> EncodeAST LLVMBool
forall (e :: * -> *) h c. EncodeM e h c => 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 => h -> e c
encodeM [Constant]
ms
      case Maybe Name
nm of
        Nothing -> do
          Context 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 (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 nm :: Name
nm -> do
          Ptr Type
t <- Name -> EncodeAST (Ptr Type)
lookupNamedType Name
nm
          IO (Ptr Constant) -> EncodeAST (Ptr Constant)
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
    A.C.TokenNone -> do
      Context 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 (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
    o :: 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 ()
                             _ ->
                               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 :: Ptr Constant -> DecodeAST Constant
decodeM c :: Ptr Constant
c = DecodeAST Constant -> DecodeAST Constant
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 (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 => c -> d h
decodeM Ptr Type
ft
    ValueSubclassId
valueSubclassId <- IO ValueSubclassId -> DecodeAST ValueSubclassId
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 (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 (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 (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 (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 => 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 (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)
mapM CUInt -> DecodeAST Constant
op [0..CUInt
nOpsCUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
-1]
        getConstantData :: DecodeAST [Constant]
getConstantData = do
          let nElements :: Word32
nElements =
                case Type
t of
                  A.VectorType n _ -> Word32
n
                  A.ArrayType n _ | 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
                  _ -> String -> Word32
forall a. HasCallStack => String -> a
error "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 [0..Word32
nElementsWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-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 => 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 (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
      [valueSubclassIdP|Function|] -> DecodeAST Constant
globalRef
      [valueSubclassIdP|GlobalAlias|] -> DecodeAST Constant
globalRef
      [valueSubclassIdP|GlobalVariable|] -> DecodeAST Constant
globalRef
      [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 (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 => c -> d h
decodeM (CUInt
n, Ptr Word64
wsp)
        Constant -> DecodeAST Constant
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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\b :: Word64
b a :: Integer
a -> (Integer
a Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` 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) 0 ([Word64]
words :: [Word64]))
      [valueSubclassIdP|ConstantFP|] -> do
        let A.FloatingPointType fpt :: FloatingPointType
fpt = Type
t
        let nBits :: Word32
nBits = case FloatingPointType
fpt of
                A.HalfFP      -> 16
                A.FloatFP     -> 32
                A.DoubleFP    -> 64
                A.FP128FP     -> 128
                A.X86_FP80FP  -> 80
                A.PPC_FP128FP -> 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 (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
            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)
            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)
            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)
            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) 8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
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) 0
            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) 8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
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) 0
            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) 8 DecodeAST (Word64 -> SomeFloat)
-> DecodeAST Word64 -> DecodeAST SomeFloat
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) 0
          )
      [valueSubclassIdP|ConstantPointerNull|] -> Constant -> DecodeAST Constant
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
      [valueSubclassIdP|ConstantAggregateZero|] -> Constant -> DecodeAST Constant
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
      [valueSubclassIdP|UndefValue|] -> Constant -> DecodeAST Constant
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
      [valueSubclassIdP|BlockAddress|] ->
            (Name -> Name -> Constant) -> DecodeAST (Name -> Name -> Constant)
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 (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 (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)
      [valueSubclassIdP|ConstantStruct|] -> do
            (Maybe Name -> Bool -> [Constant] -> Constant)
-> DecodeAST (Maybe Name -> Bool -> [Constant] -> Constant)
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 (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 n :: Name
n -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n; _ -> 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 => 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 (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
      [valueSubclassIdP|ConstantDataArray|] ->
            (Type -> [Constant] -> Constant)
-> DecodeAST (Type -> [Constant] -> Constant)
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 (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
      [valueSubclassIdP|ConstantArray|] ->
            (Type -> [Constant] -> Constant)
-> DecodeAST (Type -> [Constant] -> Constant)
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 (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
      [valueSubclassIdP|ConstantDataVector|] ->
            ([Constant] -> Constant) -> DecodeAST ([Constant] -> Constant)
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
      [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
      [valueSubclassIdP|ConstantExpr|] -> do
            CPPOpcode
cppOpcode <- IO CPPOpcode -> DecodeAST CPPOpcode
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)|]) []]
             )
      [valueSubclassIdP|ConstantTokenNone|] -> Constant -> DecodeAST Constant
forall (m :: * -> *) a. Monad m => a -> m a
return Constant
A.C.TokenNone
      _ -> String -> DecodeAST Constant
forall a. HasCallStack => String -> a
error (String -> DecodeAST Constant) -> String -> DecodeAST Constant
forall a b. (a -> b) -> a -> b
$ "unhandled constant valueSubclassId: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ValueSubclassId -> String
forall a. Show a => a -> String
show ValueSubclassId
valueSubclassId