{-# LANGUAGE
  TemplateHaskell,
  QuasiQuotes,
  MultiParamTypeClasses,
  UndecidableInstances,
  ViewPatterns
  #-}
module LLVM.Internal.Instruction 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 LLVM.Internal.InstructionDefs (instrP)

import Control.Monad.AnyCont
import Control.Monad.IO.Class
import Control.Monad.State (gets)

import Foreign.Ptr

import Control.Exception (assert)
import Control.Monad.Catch
import qualified Data.Map as Map
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty

import qualified LLVM.Internal.FFI.Attribute as FFI
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI
import qualified LLVM.Internal.FFI.BinaryOperator as FFI
import qualified LLVM.Internal.FFI.Instruction as FFI
import qualified LLVM.Internal.FFI.Value as FFI
import qualified LLVM.Internal.FFI.User as FFI
import qualified LLVM.Internal.FFI.Builder as FFI
import qualified LLVM.Internal.FFI.Constant as FFI
import qualified LLVM.Internal.FFI.BasicBlock as FFI

import LLVM.Internal.Atomicity ()
import LLVM.Internal.Attribute
import LLVM.Internal.CallingConvention ()
import LLVM.Internal.Coding
import LLVM.Internal.DecodeAST
import LLVM.Internal.EncodeAST
import LLVM.Internal.FastMathFlags ()
import LLVM.Internal.Metadata ()
import LLVM.Internal.Operand ()
import LLVM.Internal.RMWOperation ()
import LLVM.Internal.TailCallKind ()
import LLVM.Internal.Type
import LLVM.Internal.Value

import qualified LLVM.AST as A
import qualified LLVM.AST.Constant as A.C
import LLVM.Exception

callInstAttributeList :: Ptr FFI.Instruction -> DecodeAST AttributeList
callInstAttributeList :: Ptr Instruction -> DecodeAST AttributeList
callInstAttributeList instr :: Ptr Instruction
instr =
  (AttrSetDecoder (Ptr Instruction), Ptr Instruction)
-> DecodeAST AttributeList
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM
    ( (forall b.
 Ptr Instruction -> AttributeIndex -> IO (AttributeSet b))
-> (Ptr Instruction -> IO CUInt)
-> AttrSetDecoder (Ptr Instruction)
forall a.
(forall b. a -> AttributeIndex -> IO (AttributeSet b))
-> (a -> IO CUInt) -> AttrSetDecoder a
FFI.AttrSetDecoder
        forall b. Ptr Instruction -> AttributeIndex -> IO (AttributeSet b)
FFI.getCallSiteAttributesAtIndex
        Ptr Instruction -> IO CUInt
FFI.getCallSiteNumArgOperands
    , Ptr Instruction
instr)

meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata
meta :: Ptr Instruction -> DecodeAST InstructionMetadata
meta i :: Ptr Instruction
i = do
  let getMetadata :: CUInt -> m [(a, b)]
getMetadata n :: CUInt
n = m [(a, b)] -> m [(a, b)]
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (m [(a, b)] -> m [(a, b)]) -> m [(a, b)] -> m [(a, b)]
forall a b. (a -> b) -> a -> b
$ do
         Ptr MDKindID
ks <- CUInt -> m (Ptr MDKindID)
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
         Ptr (Ptr MDNode)
ps <- CUInt -> m (Ptr (Ptr MDNode))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
n
         CUInt
n' <- IO CUInt -> m CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CUInt -> m CUInt) -> IO CUInt -> m CUInt
forall a b. (a -> b) -> a -> b
$ Ptr Instruction
-> Ptr MDKindID -> Ptr (Ptr MDNode) -> CUInt -> IO CUInt
FFI.getMetadata Ptr Instruction
i Ptr MDKindID
ks Ptr (Ptr MDNode)
ps CUInt
n
         if (CUInt
n' CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
> CUInt
n)
          then CUInt -> m [(a, b)]
getMetadata CUInt
n'
          else ([a] -> [b] -> [(a, b)]) -> m ([a] -> [b] -> [(a, b)])
forall (m :: * -> *) a. Monad m => a -> m a
return [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip m ([a] -> [b] -> [(a, b)]) -> m [a] -> m ([b] -> [(a, b)])
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (CUInt, Ptr MDKindID) -> m [a]
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt
n', Ptr MDKindID
ks) m ([b] -> [(a, b)]) -> m [b] -> m [(a, b)]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` (CUInt, Ptr (Ptr MDNode)) -> m [b]
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt
n', Ptr (Ptr MDNode)
ps)
  CUInt -> DecodeAST InstructionMetadata
forall (m :: * -> *) a b.
(ScopeAnyCont m, MonadAnyCont IO m, MonadIO m,
 DecodeM m a MDKindID, DecodeM m b (Ptr MDNode)) =>
CUInt -> m [(a, b)]
getMetadata 4

setMD :: Ptr FFI.Instruction -> A.InstructionMetadata -> EncodeAST ()
setMD :: Ptr Instruction -> InstructionMetadata -> EncodeAST ()
setMD i :: Ptr Instruction
i md :: InstructionMetadata
md = InstructionMetadata
-> ((ShortByteString, MDRef MDNode) -> EncodeAST ())
-> EncodeAST ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ InstructionMetadata
md (((ShortByteString, MDRef MDNode) -> EncodeAST ()) -> EncodeAST ())
-> ((ShortByteString, MDRef MDNode) -> EncodeAST ())
-> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ \(kindName :: ShortByteString
kindName, anode :: MDRef MDNode
anode) -> do
               MDKindID
kindID <- ShortByteString -> EncodeAST MDKindID
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM ShortByteString
kindName
               Ptr MDNode
node <- MDRef MDNode -> EncodeAST (Ptr MDNode)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM MDRef MDNode
anode
               IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> MDKindID -> Ptr MDNode -> IO ()
FFI.setMetadata Ptr Instruction
i MDKindID
kindID Ptr MDNode
node

instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where
  decodeM :: Ptr Instruction -> DecodeAST Terminator
decodeM i :: Ptr Instruction
i = DecodeAST Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (DecodeAST Terminator -> DecodeAST Terminator)
-> DecodeAST Terminator -> DecodeAST Terminator
forall a b. (a -> b) -> a -> b
$ do
    CPPOpcode
n <- 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 Instruction -> IO CPPOpcode
FFI.getInstructionDefOpcode Ptr Instruction
i
    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 Instruction -> Ptr User
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i)
    InstructionMetadata
md <- Ptr Instruction -> DecodeAST InstructionMetadata
meta Ptr Instruction
i
    let op :: CUInt -> m b
op n :: CUInt
n = Ptr Value -> m b
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Value -> m b) -> m (Ptr Value) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO (Ptr Value) -> m (Ptr Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Value) -> m (Ptr Value))
-> IO (Ptr Value) -> m (Ptr Value)
forall a b. (a -> b) -> a -> b
$ Ptr User -> CUInt -> IO (Ptr Value)
FFI.getOperand (Ptr Instruction -> Ptr User
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i) CUInt
n)
        successor :: CUInt -> m b
successor n :: CUInt
n = Ptr BasicBlock -> m b
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr BasicBlock -> m b) -> m (Ptr BasicBlock) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (IO (Ptr BasicBlock) -> m (Ptr BasicBlock)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr BasicBlock) -> m (Ptr BasicBlock))
-> IO (Ptr BasicBlock) -> m (Ptr BasicBlock)
forall a b. (a -> b) -> a -> b
$ Ptr Value -> IO (Ptr BasicBlock)
FFI.isABasicBlock (Ptr Value -> IO (Ptr BasicBlock))
-> IO (Ptr Value) -> IO (Ptr BasicBlock)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr User -> CUInt -> IO (Ptr Value)
FFI.getOperand (Ptr Instruction -> Ptr User
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i) CUInt
n)
    case CPPOpcode
n of
      [instrP|Ret|] -> do
        Maybe Operand
returnOperand' <- if CUInt
nOps CUInt -> CUInt -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then Maybe Operand -> DecodeAST (Maybe Operand)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Operand
forall a. Maybe a
Nothing else Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand)
-> DecodeAST Operand -> DecodeAST (Maybe Operand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op 0
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return (Terminator -> DecodeAST Terminator)
-> Terminator -> DecodeAST Terminator
forall a b. (a -> b) -> a -> b
$ Ret :: Maybe Operand -> InstructionMetadata -> Terminator
A.Ret { returnOperand :: Maybe Operand
A.returnOperand = Maybe Operand
returnOperand', metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md }
      [instrP|Br|] -> do
        CUInt
n <- 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 Instruction -> Ptr User
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i)
        case CUInt
n of
          1 -> do
             Name
dest <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor 0
             Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return (Terminator -> DecodeAST Terminator)
-> Terminator -> DecodeAST Terminator
forall a b. (a -> b) -> a -> b
$ Br :: Name -> InstructionMetadata -> Terminator
A.Br { dest :: Name
A.dest = Name
dest, metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md }
          3 -> do
             Operand
condition <- CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op 0
             Name
falseDest <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor 1
             Name
trueDest <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor 2
             Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return (Terminator -> DecodeAST Terminator)
-> Terminator -> DecodeAST Terminator
forall a b. (a -> b) -> a -> b
$ CondBr :: Operand -> Name -> Name -> InstructionMetadata -> Terminator
A.CondBr {
               condition :: Operand
A.condition = Operand
condition,
               falseDest :: Name
A.falseDest = Name
falseDest,
               trueDest :: Name
A.trueDest = Name
trueDest,
               metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
             }
          _ -> [Char] -> DecodeAST Terminator
forall a. HasCallStack => [Char] -> a
error "Branch instructions should always have 1 or 3 operands"
      [instrP|Switch|] -> do
        Operand
op0 <- CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op 0
        Name
dd <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor 1
        let nCases :: CUInt
nCases = (CUInt
nOps CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 2) CUInt -> CUInt -> CUInt
forall a. Integral a => a -> a -> a
`div` 2
        Ptr (Ptr Constant)
values <- CUInt -> DecodeAST (Ptr (Ptr Constant))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
nCases
        Ptr (Ptr BasicBlock)
dests <- CUInt -> DecodeAST (Ptr (Ptr BasicBlock))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
nCases
        IO () -> DecodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction
-> Ptr (Ptr Constant) -> Ptr (Ptr BasicBlock) -> IO ()
FFI.getSwitchCases Ptr Instruction
i Ptr (Ptr Constant)
values Ptr (Ptr BasicBlock)
dests
        [(Ptr Constant, Ptr BasicBlock)]
cases <- ([Ptr Constant]
 -> [Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)])
-> DecodeAST
     ([Ptr Constant]
      -> [Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)])
forall (m :: * -> *) a. Monad m => a -> m a
return [Ptr Constant]
-> [Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)]
forall a b. [a] -> [b] -> [(a, b)]
zip DecodeAST
  ([Ptr Constant]
   -> [Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)])
-> DecodeAST [Ptr Constant]
-> DecodeAST ([Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)])
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` CUInt -> Ptr (Ptr Constant) -> DecodeAST [Ptr Constant]
forall i a (m :: * -> *).
(Integral i, Storable a, MonadIO m) =>
i -> Ptr a -> m [a]
peekArray CUInt
nCases Ptr (Ptr Constant)
values DecodeAST ([Ptr BasicBlock] -> [(Ptr Constant, Ptr BasicBlock)])
-> DecodeAST [Ptr BasicBlock]
-> DecodeAST [(Ptr Constant, Ptr BasicBlock)]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` CUInt -> Ptr (Ptr BasicBlock) -> DecodeAST [Ptr BasicBlock]
forall i a (m :: * -> *).
(Integral i, Storable a, MonadIO m) =>
i -> Ptr a -> m [a]
peekArray CUInt
nCases Ptr (Ptr BasicBlock)
dests
        [(Constant, Name)]
dests <- [(Ptr Constant, Ptr BasicBlock)]
-> ((Ptr Constant, Ptr BasicBlock) -> DecodeAST (Constant, Name))
-> DecodeAST [(Constant, Name)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Ptr Constant, Ptr BasicBlock)]
cases (((Ptr Constant, Ptr BasicBlock) -> DecodeAST (Constant, Name))
 -> DecodeAST [(Constant, Name)])
-> ((Ptr Constant, Ptr BasicBlock) -> DecodeAST (Constant, Name))
-> DecodeAST [(Constant, Name)]
forall a b. (a -> b) -> a -> b
$ \(c :: Ptr Constant
c, d :: Ptr BasicBlock
d) -> (Constant -> Name -> (Constant, Name))
-> DecodeAST (Constant -> Name -> (Constant, Name))
forall (m :: * -> *) a. Monad m => a -> m a
return (,) DecodeAST (Constant -> Name -> (Constant, Name))
-> DecodeAST Constant -> DecodeAST (Name -> (Constant, Name))
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Constant -> DecodeAST Constant
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM Ptr Constant
c DecodeAST (Name -> (Constant, Name))
-> DecodeAST Name -> DecodeAST (Constant, Name)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr BasicBlock -> DecodeAST Name
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM Ptr BasicBlock
d
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return Switch :: Operand
-> Name -> [(Constant, Name)] -> InstructionMetadata -> Terminator
A.Switch {
          operand0' :: Operand
A.operand0' = Operand
op0,
          defaultDest :: Name
A.defaultDest = Name
dd,
          dests :: [(Constant, Name)]
A.dests = [(Constant, Name)]
dests,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|IndirectBr|] -> do
        Operand
op0 <- CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op 0
        let nDests :: CUInt
nDests = CUInt
nOps CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 1
        Ptr (Ptr BasicBlock)
dests <- CUInt -> DecodeAST (Ptr (Ptr BasicBlock))
forall i a (m :: * -> *).
(Integral i, Storable a, MonadAnyCont IO m) =>
i -> m (Ptr a)
allocaArray CUInt
nDests
        IO () -> DecodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> DecodeAST ()) -> IO () -> DecodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr (Ptr BasicBlock) -> IO ()
FFI.getIndirectBrDests Ptr Instruction
i Ptr (Ptr BasicBlock)
dests
        [Name]
dests <- (CUInt, Ptr (Ptr BasicBlock)) -> DecodeAST [Name]
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CUInt
nDests, Ptr (Ptr BasicBlock)
dests)
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return IndirectBr :: Operand -> [Name] -> InstructionMetadata -> Terminator
A.IndirectBr {
           operand0' :: Operand
A.operand0' = Operand
op0,
           possibleDests :: [Name]
A.possibleDests = [Name]
dests,
           metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|Invoke|] -> do
        CallingConvention
cc <- CallingConvention -> DecodeAST CallingConvention
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (CallingConvention -> DecodeAST CallingConvention)
-> DecodeAST CallingConvention -> DecodeAST CallingConvention
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CallingConvention -> DecodeAST CallingConvention
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO CallingConvention
FFI.getCallSiteCallingConvention Ptr Instruction
i)
        AttributeList
attrs <- Ptr Instruction -> DecodeAST AttributeList
callInstAttributeList Ptr Instruction
i
        Ptr Value
fv <- IO (Ptr Value) -> DecodeAST (Ptr Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Value) -> DecodeAST (Ptr Value))
-> IO (Ptr Value) -> DecodeAST (Ptr Value)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> IO (Ptr Value)
FFI.getCallSiteCalledValue Ptr Instruction
i
        CallableOperand
f <- Ptr Value -> DecodeAST CallableOperand
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM Ptr Value
fv
        let argIndices :: [CUInt]
argIndices = if CUInt
nOps CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 then [0 .. CUInt
nOps CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 4] else []
        [(Operand, [ParameterAttribute])]
args <-
          [(CUInt, Maybe [ParameterAttribute])]
-> ((CUInt, Maybe [ParameterAttribute])
    -> DecodeAST (Operand, [ParameterAttribute]))
-> DecodeAST [(Operand, [ParameterAttribute])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([CUInt]
-> [[ParameterAttribute]] -> [(CUInt, Maybe [ParameterAttribute])]
forall a b. [a] -> [b] -> [(a, Maybe b)]
leftBiasedZip [CUInt]
argIndices (AttributeList -> [[ParameterAttribute]]
parameterAttributes AttributeList
attrs)) (((CUInt, Maybe [ParameterAttribute])
  -> DecodeAST (Operand, [ParameterAttribute]))
 -> DecodeAST [(Operand, [ParameterAttribute])])
-> ((CUInt, Maybe [ParameterAttribute])
    -> DecodeAST (Operand, [ParameterAttribute]))
-> DecodeAST [(Operand, [ParameterAttribute])]
forall a b. (a -> b) -> a -> b
$ \(j :: CUInt
j, pAttrs :: Maybe [ParameterAttribute]
pAttrs) ->
                  (, [ParameterAttribute]
-> Maybe [ParameterAttribute] -> [ParameterAttribute]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [ParameterAttribute]
pAttrs) (Operand -> (Operand, [ParameterAttribute]))
-> DecodeAST Operand -> DecodeAST (Operand, [ParameterAttribute])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op CUInt
j
        Name
rd <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor (CUInt
nOps CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 3)
        Name
ed <- CUInt -> DecodeAST Name
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr BasicBlock)) =>
CUInt -> m b
successor (CUInt
nOps CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 2)
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return Invoke :: CallingConvention
-> [ParameterAttribute]
-> CallableOperand
-> [(Operand, [ParameterAttribute])]
-> [Either GroupID FunctionAttribute]
-> Name
-> Name
-> InstructionMetadata
-> Terminator
A.Invoke {
          callingConvention' :: CallingConvention
A.callingConvention' = CallingConvention
cc,
          returnAttributes' :: [ParameterAttribute]
A.returnAttributes' = AttributeList -> [ParameterAttribute]
returnAttributes AttributeList
attrs,
          function' :: CallableOperand
A.function' = CallableOperand
f,
          arguments' :: [(Operand, [ParameterAttribute])]
A.arguments' = [(Operand, [ParameterAttribute])]
args,
          functionAttributes' :: [Either GroupID FunctionAttribute]
A.functionAttributes' = AttributeList -> [Either GroupID FunctionAttribute]
functionAttributes AttributeList
attrs,
          returnDest :: Name
A.returnDest = Name
rd,
          exceptionDest :: Name
A.exceptionDest = Name
ed,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|Resume|] -> do
        Operand
op0 <- CUInt -> DecodeAST Operand
forall (m :: * -> *) b.
(MonadIO m, DecodeM m b (Ptr Value)) =>
CUInt -> m b
op 0
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return Resume :: Operand -> InstructionMetadata -> Terminator
A.Resume {
          operand0' :: Operand
A.operand0' = Operand
op0,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|Unreachable|] -> do
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return Unreachable :: InstructionMetadata -> Terminator
A.Unreachable {
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|CleanupRet|] -> do
        Operand
dest <- Ptr Value -> DecodeAST Operand
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Value -> DecodeAST Operand)
-> DecodeAST (Ptr Value) -> DecodeAST Operand
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Value) -> DecodeAST (Ptr Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> Ptr Value
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr Instruction -> Ptr Value)
-> IO (Ptr Instruction) -> IO (Ptr Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Instruction -> IO (Ptr Instruction)
FFI.getCleanupPad Ptr Instruction
i) :: IO (Ptr FFI.Value))
        Maybe Name
unwindDest <- Ptr BasicBlock -> DecodeAST (Maybe Name)
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr BasicBlock -> DecodeAST (Maybe Name))
-> DecodeAST (Ptr BasicBlock) -> DecodeAST (Maybe Name)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO (Ptr BasicBlock)
FFI.getUnwindDest Ptr Instruction
i)
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return CleanupRet :: Operand -> Maybe Name -> InstructionMetadata -> Terminator
A.CleanupRet {
          cleanupPad :: Operand
A.cleanupPad = Operand
dest,
          unwindDest :: Maybe Name
A.unwindDest = Maybe Name
unwindDest,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|CatchRet|] -> do
        Operand
catchPad <- Ptr Value -> DecodeAST Operand
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Value -> DecodeAST Operand)
-> DecodeAST (Ptr Value) -> DecodeAST Operand
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Value) -> DecodeAST (Ptr Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO (Ptr Value)
FFI.catchRetGetCatchPad Ptr Instruction
i)
        Name
successor <- Ptr BasicBlock -> DecodeAST Name
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr BasicBlock -> DecodeAST Name)
-> DecodeAST (Ptr BasicBlock) -> DecodeAST Name
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO (Ptr BasicBlock)
FFI.catchRetGetSuccessor Ptr Instruction
i)
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return CatchRet :: Operand -> Name -> InstructionMetadata -> Terminator
A.CatchRet {
          catchPad :: Operand
A.catchPad = Operand
catchPad,
          successor :: Name
A.successor = Name
successor,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      [instrP|CatchSwitch|] -> do
        Operand
parentPad' <- Ptr Value -> DecodeAST Operand
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr Value -> DecodeAST Operand)
-> DecodeAST (Ptr Value) -> DecodeAST Operand
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr Value) -> DecodeAST (Ptr Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO (Ptr Value)
FFI.catchSwitchGetParentPad Ptr Instruction
i)
        CUInt
numHandlers <- IO CUInt -> DecodeAST CUInt
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO CUInt
FFI.catchSwitchGetNumHandlers Ptr Instruction
i)
        NonEmpty Name
handlers <- Bool -> DecodeAST (NonEmpty Name) -> DecodeAST (NonEmpty Name)
forall a. HasCallStack => Bool -> a -> a
assert (CUInt
numHandlers CUInt -> CUInt -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (DecodeAST (NonEmpty Name) -> DecodeAST (NonEmpty Name))
-> DecodeAST (NonEmpty Name) -> DecodeAST (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$
          NonEmpty CUInt
-> (CUInt -> DecodeAST Name) -> DecodeAST (NonEmpty Name)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (0 CUInt -> [CUInt] -> NonEmpty CUInt
forall a. a -> [a] -> NonEmpty a
:| [1..CUInt
numHandlers CUInt -> CUInt -> CUInt
forall a. Num a => a -> a -> a
- 1]) ((CUInt -> DecodeAST Name) -> DecodeAST (NonEmpty Name))
-> (CUInt -> DecodeAST Name) -> DecodeAST (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$ Ptr BasicBlock -> DecodeAST Name
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr BasicBlock -> DecodeAST Name)
-> (CUInt -> DecodeAST (Ptr BasicBlock)) -> CUInt -> DecodeAST Name
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock))
-> (CUInt -> IO (Ptr BasicBlock))
-> CUInt
-> DecodeAST (Ptr BasicBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Instruction -> CUInt -> IO (Ptr BasicBlock)
FFI.catchSwitchGetHandler Ptr Instruction
i
        Maybe Name
unwindDest <- Ptr BasicBlock -> DecodeAST (Maybe Name)
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM (Ptr BasicBlock -> DecodeAST (Maybe Name))
-> DecodeAST (Ptr BasicBlock) -> DecodeAST (Maybe Name)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Ptr BasicBlock) -> DecodeAST (Ptr BasicBlock)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr Instruction -> IO (Ptr BasicBlock)
FFI.catchSwitchGetUnwindDest Ptr Instruction
i)
        Terminator -> DecodeAST Terminator
forall (m :: * -> *) a. Monad m => a -> m a
return CatchSwitch :: Operand
-> NonEmpty Name -> Maybe Name -> InstructionMetadata -> Terminator
A.CatchSwitch {
          parentPad' :: Operand
A.parentPad' = Operand
parentPad',
          catchHandlers :: NonEmpty Name
A.catchHandlers = NonEmpty Name
handlers,
          defaultUnwindDest :: Maybe Name
A.defaultUnwindDest = Maybe Name
unwindDest,
          metadata' :: InstructionMetadata
A.metadata' = InstructionMetadata
md
        }
      i :: CPPOpcode
i -> [Char] -> DecodeAST Terminator
forall a. HasCallStack => [Char] -> a
error ("Unknown terminator instruction kind: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> CPPOpcode -> [Char]
forall a. Show a => a -> [Char]
show CPPOpcode
i)

instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where
  encodeM :: Terminator -> EncodeAST (Ptr Instruction)
encodeM t :: Terminator
t = EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. ScopeAnyCont m => m a -> m a
scopeAnyCont (EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ do
    Ptr Builder
builder <- (EncodeState -> Ptr Builder) -> EncodeAST (Ptr Builder)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets EncodeState -> Ptr Builder
encodeStateBuilder
    CString
s <- [Char] -> EncodeAST CString
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM ""
    Ptr Instruction
t' <- case Terminator
t of
      A.Ret { returnOperand :: Terminator -> Maybe Operand
A.returnOperand = Maybe Operand
r } -> do
        Ptr Value
rv <- EncodeAST (Ptr Value)
-> (Operand -> EncodeAST (Ptr Value))
-> Maybe Operand
-> EncodeAST (Ptr Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ptr Value -> EncodeAST (Ptr Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Value
forall a. Ptr a
nullPtr) Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Maybe Operand
r
        Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr Instruction -> Ptr Instruction)
-> EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr Value -> IO (Ptr Instruction)
FFI.buildRet Ptr Builder
builder Ptr Value
rv
      A.Br { dest :: Terminator -> Name
A.dest = Name
d } -> do
        Ptr BasicBlock
db <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
d
        Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr Instruction -> Ptr Instruction)
-> EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr BasicBlock -> IO (Ptr Instruction)
FFI.buildBr Ptr Builder
builder Ptr BasicBlock
db
      A.CondBr { condition :: Terminator -> Operand
A.condition = Operand
c, trueDest :: Terminator -> Name
A.trueDest = Name
t, falseDest :: Terminator -> Name
A.falseDest = Name
f } -> do
        Ptr Value
cv <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
c
        Ptr BasicBlock
tb <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
t
        Ptr BasicBlock
fb <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
f
        Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr Instruction -> Ptr Instruction)
-> EncodeAST (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder
-> Ptr Value
-> Ptr BasicBlock
-> Ptr BasicBlock
-> IO (Ptr Instruction)
FFI.buildCondBr Ptr Builder
builder Ptr Value
cv Ptr BasicBlock
tb Ptr BasicBlock
fb
      A.Switch {
        operand0' :: Terminator -> Operand
A.operand0' = Operand
op0,
        defaultDest :: Terminator -> Name
A.defaultDest = Name
dd,
        dests :: Terminator -> [(Constant, Name)]
A.dests = [(Constant, Name)]
ds
      } -> do
        Ptr Value
op0' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
op0
        Ptr BasicBlock
dd' <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
dd
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder
-> Ptr Value -> Ptr BasicBlock -> CUInt -> IO (Ptr Instruction)
FFI.buildSwitch Ptr Builder
builder Ptr Value
op0' Ptr BasicBlock
dd' (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUInt) -> Int -> CUInt
forall a b. (a -> b) -> a -> b
$ [(Constant, Name)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Constant, Name)]
ds)
        [(Constant, Name)]
-> ((Constant, Name) -> EncodeAST ()) -> EncodeAST ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Constant, Name)]
ds (((Constant, Name) -> EncodeAST ()) -> EncodeAST ())
-> ((Constant, Name) -> EncodeAST ()) -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ \(v :: Constant
v,d :: Name
d) -> do
          Ptr Constant
v' <- Constant -> EncodeAST (Ptr Constant)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Constant
v
          Ptr BasicBlock
d' <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
d
          IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Constant -> Ptr BasicBlock -> IO ()
FFI.addCase Ptr Instruction
i Ptr Constant
v' Ptr BasicBlock
d'
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Instruction -> EncodeAST (Ptr Instruction))
-> Ptr Instruction -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
      A.IndirectBr {
        operand0' :: Terminator -> Operand
A.operand0' = Operand
op0,
        possibleDests :: Terminator -> [Name]
A.possibleDests = [Name]
dests
      } -> do
        Ptr Value
op0' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
op0
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr Value -> CUInt -> IO (Ptr Instruction)
FFI.buildIndirectBr Ptr Builder
builder Ptr Value
op0' (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUInt) -> Int -> CUInt
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
dests)
        [Name] -> (Name -> EncodeAST ()) -> EncodeAST ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
dests ((Name -> EncodeAST ()) -> EncodeAST ())
-> (Name -> EncodeAST ()) -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ \dest :: Name
dest -> do
          Ptr BasicBlock
d <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
dest
          IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr BasicBlock -> IO ()
FFI.addDestination Ptr Instruction
i Ptr BasicBlock
d
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Instruction -> EncodeAST (Ptr Instruction))
-> Ptr Instruction -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
      A.Invoke {
        callingConvention' :: Terminator -> CallingConvention
A.callingConvention' = CallingConvention
cc,
        returnAttributes' :: Terminator -> [ParameterAttribute]
A.returnAttributes' = [ParameterAttribute]
rAttrs,
        function' :: Terminator -> CallableOperand
A.function' = CallableOperand
fun,
        arguments' :: Terminator -> [(Operand, [ParameterAttribute])]
A.arguments' = [(Operand, [ParameterAttribute])]
args,
        functionAttributes' :: Terminator -> [Either GroupID FunctionAttribute]
A.functionAttributes' = [Either GroupID FunctionAttribute]
fAttrs,
        returnDest :: Terminator -> Name
A.returnDest = Name
rd,
        exceptionDest :: Terminator -> Name
A.exceptionDest = Name
ed
      } -> do
        Ptr Value
fv <- CallableOperand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM CallableOperand
fun
        Ptr BasicBlock
rb <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
rd
        Ptr BasicBlock
eb <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
ed
        let (argvs :: [Operand]
argvs, argAttrs :: [[ParameterAttribute]]
argAttrs) = [(Operand, [ParameterAttribute])]
-> ([Operand], [[ParameterAttribute]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Operand, [ParameterAttribute])]
args
        (n :: CUInt
n, argvs :: Ptr (Ptr Value)
argvs) <- [Operand] -> EncodeAST (CUInt, Ptr (Ptr Value))
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM [Operand]
argvs
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder
-> Ptr Value
-> Ptr (Ptr Value)
-> CUInt
-> Ptr BasicBlock
-> Ptr BasicBlock
-> CString
-> IO (Ptr Instruction)
FFI.buildInvoke Ptr Builder
builder Ptr Value
fv Ptr (Ptr Value)
argvs CUInt
n Ptr BasicBlock
rb Ptr BasicBlock
eb CString
s
        AttributeList
attrs <- AttributeList -> EncodeAST AttributeList
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM (AttributeList -> EncodeAST AttributeList)
-> AttributeList -> EncodeAST AttributeList
forall a b. (a -> b) -> a -> b
$ [Either GroupID FunctionAttribute]
-> [ParameterAttribute] -> [[ParameterAttribute]] -> AttributeList
AttributeList [Either GroupID FunctionAttribute]
fAttrs [ParameterAttribute]
rAttrs [[ParameterAttribute]]
argAttrs
        IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> AttributeList -> IO ()
FFI.setCallSiteAttributeList Ptr Instruction
i AttributeList
attrs
        CallingConvention
cc <- CallingConvention -> EncodeAST CallingConvention
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM CallingConvention
cc
        IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> CallingConvention -> IO ()
FFI.setCallSiteCallingConvention Ptr Instruction
i CallingConvention
cc
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Instruction -> EncodeAST (Ptr Instruction))
-> Ptr Instruction -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
      A.Resume {
        operand0' :: Terminator -> Operand
A.operand0' = Operand
op0
      } -> do
        Ptr Value
op0' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
op0
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr Value -> IO (Ptr Instruction)
FFI.buildResume Ptr Builder
builder Ptr Value
op0'
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Instruction -> EncodeAST (Ptr Instruction))
-> Ptr Instruction -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
      A.Unreachable {
      } -> do
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> IO (Ptr Instruction)
FFI.buildUnreachable Ptr Builder
builder
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Instruction -> EncodeAST (Ptr Instruction))
-> Ptr Instruction -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Instruction -> Ptr Instruction
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
      A.CleanupRet {
        cleanupPad :: Terminator -> Operand
A.cleanupPad = Operand
cleanupPad,
        unwindDest :: Terminator -> Maybe Name
A.unwindDest = Maybe Name
unwindDest
      } -> do
        Ptr Value
cleanupPad' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
cleanupPad
        Ptr BasicBlock
unwindDest' <- Maybe Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Maybe Name
unwindDest
        IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr Value -> Ptr BasicBlock -> IO (Ptr Instruction)
FFI.buildCleanupRet Ptr Builder
builder Ptr Value
cleanupPad' Ptr BasicBlock
unwindDest'
      A.CatchRet {
        catchPad :: Terminator -> Operand
A.catchPad = Operand
catchPad,
        successor :: Terminator -> Name
A.successor = Name
successor
      } -> do
        Ptr Value
catchPad' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
catchPad
        Ptr BasicBlock
successor' <- Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
successor
        IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder -> Ptr Value -> Ptr BasicBlock -> IO (Ptr Instruction)
FFI.buildCatchRet Ptr Builder
builder Ptr Value
catchPad' Ptr BasicBlock
successor'
      A.CatchSwitch {
        parentPad' :: Terminator -> Operand
A.parentPad' = Operand
parentPad,
        catchHandlers :: Terminator -> NonEmpty Name
A.catchHandlers = NonEmpty Name
catchHandlers,
        defaultUnwindDest :: Terminator -> Maybe Name
A.defaultUnwindDest = Maybe Name
unwindDest
      } -> do
        Ptr Value
parentPad' <- Operand -> EncodeAST (Ptr Value)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Operand
parentPad
        Ptr BasicBlock
unwindDest' <- Maybe Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Maybe Name
unwindDest
        let numHandlers :: CUInt
numHandlers = Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonEmpty Name -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty Name
catchHandlers)
        Ptr Instruction
i <- IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr Instruction) -> EncodeAST (Ptr Instruction))
-> IO (Ptr Instruction) -> EncodeAST (Ptr Instruction)
forall a b. (a -> b) -> a -> b
$ Ptr Builder
-> Ptr Value -> Ptr BasicBlock -> CUInt -> IO (Ptr Instruction)
FFI.buildCatchSwitch Ptr Builder
builder Ptr Value
parentPad' Ptr BasicBlock
unwindDest' CUInt
numHandlers
        (Name -> EncodeAST ()) -> NonEmpty Name -> EncodeAST ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ())
-> (Ptr BasicBlock -> IO ()) -> Ptr BasicBlock -> EncodeAST ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Instruction -> Ptr BasicBlock -> IO ()
FFI.catchSwitchAddHandler Ptr Instruction
i (Ptr BasicBlock -> EncodeAST ())
-> (Name -> EncodeAST (Ptr BasicBlock)) -> Name -> EncodeAST ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> EncodeAST (Ptr BasicBlock)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM) NonEmpty Name
catchHandlers
        Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Instruction
i
    Ptr Instruction -> InstructionMetadata -> EncodeAST ()
setMD Ptr Instruction
t' (Terminator -> InstructionMetadata
A.metadata' Terminator
t)
    Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Instruction
t'

$(do
  let findInstrFields s = Map.findWithDefault (error $ "instruction missing from AST: " ++ show s) s
                          ID.astInstructionRecs

  [d|
    instance DecodeM DecodeAST A.Instruction (Ptr FFI.Instruction) where
      decodeM i = scopeAnyCont $ do
        t <- typeOf i
        nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i)
        let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n)
            cop n = decodeM =<< (liftIO $ FFI.isAConstant =<< FFI.getOperand (FFI.upCast i) n)
            get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap (FFI.upCast b)
            get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap (FFI.upCast b)
            get_exact b = liftIO $ decodeM =<< FFI.isExact (FFI.upCast b)
            get_fastMathFlags b = liftIO $ decodeM =<< FFI.getFastMathFlags (FFI.upCast b)

        n <- liftIO $ FFI.getInstructionDefOpcode i
        $(
          let fieldDecoders :: String -> String -> ([String], TH.ExpQ)
              fieldDecoders lrn s = case s of
                "b" -> ([], [| liftIO $ FFI.isABinaryOperator (FFI.upCast i) |])
                "nsw" -> (["b"], [| get_nsw $(TH.dyn "b") |])
                "nuw" -> (["b"], [| get_nuw $(TH.dyn "b") |])
                "exact" -> (["b"], [| get_exact $(TH.dyn "b") |])
                "fastMathFlags" -> (["b"], [| get_fastMathFlags $(TH.dyn "b") |])
                "operand0" -> ([], [| op 0 |])
                "operand1" -> ([], [| op 1 |])
                "address" -> ([], case lrn of "Store" -> [| op 1 |]; _ -> [| op 0 |])
                "value" -> ([], case lrn of "Store" -> [| op 0 |]; _ -> [| op 1 |])
                "expected" -> ([], [| op 1 |])
                "replacement" -> ([], [| op 2 |])
                "condition'" -> ([], [| op 0 |])
                "trueValue" -> ([], [| op 1 |])
                "falseValue" -> ([], [| op 2 |])
                "argList" -> ([], [| op 0 |])
                "vector" -> ([], [| op 0 |])
                "element" -> ([], [| op 1 |])
                "index" -> ([], case lrn of
                                  "ExtractElement" -> [| op 1 |]
                                  "InsertElement" -> [| op 2 |]
                                  _ -> [|error "Index fields are only supported for 'ExtractElement' and 'InsertElement': " <> lrn|])
                "mask" -> ([], [| cop 2 |])
                "aggregate" -> ([], [| op 0 |])
                "metadata" -> ([], [| meta i |])
                "iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |])
                "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |])
                "tailCallKind" -> ([], [| decodeM =<< liftIO (FFI.getTailCallKind i) |])
                "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) |])
                "attrs" -> ([], [| callInstAttributeList i |])
                "returnAttributes" -> (["attrs"], [| return $ returnAttributes $(TH.dyn "attrs") |])
                "f" -> ([], [| liftIO $ FFI.getCallSiteCalledValue i |])
                "function" -> (["f"], [| decodeM $(TH.dyn "f") |])
                "arguments" -> ([], [| forM (leftBiasedZip [1..nOps-1] (parameterAttributes $(TH.dyn "attrs"))) $ \(j, pAttrs) ->
                                         (\p -> (p, fromMaybe [] pAttrs)) <$> op (j - 1) |])
                "clauses" ->
                  ([], [|do
                          nClauses <- liftIO $ FFI.getNumClauses i
                          -- We need to convert nClauses to a signed
                          -- value before subtracting
                          forM [0..fromIntegral nClauses - (1 :: Int)] $ \j -> do
                            v <- liftIO $ FFI.getClause i (fromIntegral j)
                            c <- decodeM v
                            t <- typeOf v
                            return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |])
                "functionAttributes" -> (["attrs"], [| return $ functionAttributes $(TH.dyn "attrs") |])
                "type'" -> ([], [| return t |])
                "incomingValues" ->
                    ([], [| do
                            n <- liftIO $ FFI.countIncoming i
                            forM [0..n-1] $ \m -> do
                              iv <- decodeM =<< (liftIO $ FFI.getIncomingValue i m)
                              ib <- decodeM =<< (liftIO $ FFI.getIncomingBlock i m)
                              return (iv,ib) |])
                "allocatedType" -> ([], [| decodeM =<< liftIO (FFI.getAllocatedType i) |])
                "numElements" ->
                    ([], [| do
                            n <- decodeM =<< (liftIO $ FFI.getAllocaNumElements i)
                            return $ case n of
                              A.ConstantOperand (A.C.Int { A.C.integerValue = 1 }) -> Nothing
                              _ -> Just n
                              |])
                "alignment" -> ([], [| decodeM =<< liftIO (FFI.getInstrAlignment i) |])
                "maybeAtomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |])
                "atomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |])
                "volatile" -> ([], [| decodeM =<< liftIO (FFI.getVolatile i) |])
                "inBounds" -> ([], [| decodeM =<< liftIO (FFI.getInBounds (FFI.upCast i)) |])
                "failureMemoryOrdering" -> ([], [| decodeM =<< liftIO (FFI.getFailureAtomicOrdering i) |])
                "indices" -> ([], [| mapM op [1..nOps-1] |])
                "indices'" ->
                  ([], [| do
                          n <- liftIO $ FFI.countInstStructureIndices i
                          a <- allocaArray n
                          liftIO $ FFI.getInstStructureIndices i a
                          decodeM (n, a) |])
                "rmwOperation" -> ([], [| decodeM =<< liftIO (FFI.getAtomicRMWBinOp i) |])
                "cleanup" -> ([], [| decodeM =<< liftIO (FFI.isCleanup i) |])
                "parentPad" -> ([], [| decodeM =<< liftIO (FFI.getParentPad i) |])
                "catchSwitch" -> ([], [| decodeM =<< liftIO (FFI.getParentPad i) |])
                "args" -> ([], [| do numArgs <- liftIO (FFI.getNumArgOperands i)
                                     if (numArgs == 0)
                                       then return []
                                       else forM [0..numArgs-1] $ \op ->
                                              decodeM =<< liftIO (FFI.getArgOperand i op) |])
                _ -> ([], [| error $ "unrecognized instruction field or depenency thereof: " ++ show s |])
          in
          TH.caseE [| n |] $
            [ TH.match opcodeP (TH.normalB (TH.doE handlerBody)) []
            | (lrn, iDef) <- Map.toList ID.instructionDefs,
              ID.instructionKind iDef /= ID.Terminator,
              let opcodeP = TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef)
                  handlerBody =
                    let TH.RecC fullName fields = findInstrFields lrn
                        (fieldNames,_,_) = unzip3 fields
                        allNames ns = List.nub $ [ d | n <- ns, d <- allNames . fst . fieldDecoders lrn $ n ] ++ ns
                    in
                      [
                       TH.bindS (TH.varP (TH.mkName n)) (snd . fieldDecoders lrn $ n)
                       | n <- allNames . map TH.nameBase $ fieldNames
                      ] ++ [
                       TH.noBindS [|
                        return $(TH.recConE
                                 fullName
                                 [ (f,) <$> (TH.varE . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])
                        |]
                      ]
            ] ++
            [ TH.match TH.wildP (TH.normalB [| error ("Unknown instruction opcode: " <> show n) |]) [] ]
         )

    instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction, EncodeAST ()) where
      encodeM o = scopeAnyCont $ do
        builder <- gets encodeStateBuilder
        let return' i = return (FFI.upCast i, return ())
        s <- encodeM ""
        (inst, act) <- case o of
          A.ICmp {
            A.iPredicate = pred,
            A.operand0 = op0,
            A.operand1 = op1
          } -> do
            op0' <- encodeM op0
            op1' <- encodeM op1
            pred <- encodeM pred
            i <- liftIO $ FFI.buildICmp builder pred op0' op1' s
            return' i
          A.FCmp {
            A.fpPredicate = pred,
            A.operand0 = op0,
            A.operand1 = op1
          } -> do
            op0' <- encodeM op0
            op1' <- encodeM op1
            pred <- encodeM pred
            i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s
            return' i
          A.Phi { A.type' = t, A.incomingValues = ivs } -> do
             t' <- encodeM t
             i <- liftIO $ FFI.buildPhi builder t' s
             return (
               FFI.upCast i,
               do
                 let (ivs3, bs3) = unzip ivs
                 ivs3' <- encodeM ivs3
                 bs3' <- encodeM bs3
                 liftIO $ FFI.addIncoming i ivs3' bs3'
               )
          A.Call {
            A.tailCallKind = tck,
            A.callingConvention = cc,
            A.returnAttributes = rAttrs,
            A.function = f,
            A.arguments = args,
            A.functionAttributes = fAttrs
          } -> do
            fv <- encodeM f
            let (argvs, argAttrs) = unzip args
            (n, argvs) <- encodeM argvs
            i <- liftIO $ FFI.buildCall builder fv argvs n s
            attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs
            liftIO $ FFI.setCallSiteAttributeList i attrs
            tck <- encodeM tck
            liftIO $ FFI.setTailCallKind i tck
            cc <- encodeM cc
            liftIO $ FFI.setCallSiteCallingConvention i cc
            return' i
          A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do
            c' <- encodeM c
            t' <- encodeM t
            f' <- encodeM f
            i <- liftIO $ FFI.buildSelect builder c' t' f' s
            return' i
          A.VAArg { A.argList = al, A.type' = t } -> do
            al' <- encodeM al
            t' <- encodeM t
            i <- liftIO $ FFI.buildVAArg builder al' t' s
            return' i
          A.ExtractElement { A.vector = v, A.index = idx } -> do
            v' <- encodeM v
            idx' <- encodeM idx
            i <- liftIO $ FFI.buildExtractElement builder v' idx' s
            return' i
          A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do
            v' <- encodeM v
            e' <- encodeM e
            idx' <- encodeM idx
            i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s
            return' i
          A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do
            o0' <- encodeM o0
            o1' <- encodeM o1
            mask' <- encodeM mask
            i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' s
            return' i
          A.ExtractValue { A.aggregate = a, A.indices' = is } -> do
            a' <- encodeM a
            (n, is') <- encodeM is
            i <- liftIO $ FFI.buildExtractValue builder a' is' n s
            return' i
          A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do
            a' <- encodeM a
            e' <- encodeM e
            (n, is') <- encodeM is
            i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s
            return' i
          A.LandingPad {
            A.type' = t,
            A.cleanup = cl,
            A.clauses = cs
          } -> do
            t' <- encodeM t
            i <- liftIO $ FFI.buildLandingPad builder t' (fromIntegral $ length cs) s
            forM_ cs $ \c ->
              case c of
                A.Catch a -> do
                  cn <- encodeM a
                  isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)
                  when isArray $ throwM . EncodeException $ "Catch clause cannot take an array: " ++ show c
                  liftIO $ FFI.addClause i cn
                A.Filter a -> do
                  cn <- encodeM a
                  isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)
                  unless isArray $ throwM . EncodeException $ "filter clause must take an array: " ++ show c
                  liftIO $ FFI.addClause i cn
            when cl $ do
              cl <- encodeM cl
              liftIO $ FFI.setCleanup i cl
            return' i
          A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do
             alt' <- encodeM alt
             n' <- encodeM n
             i <- liftIO $ FFI.buildAlloca builder alt' n' s
             unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)
             return' i
          A.CleanupPad { A.parentPad = parentPad, A.args = args } -> do
            parentPad' <- encodeM parentPad
            (numArgs, args') <- encodeM args
            i <- liftIO $ FFI.buildCleanupPad builder parentPad' args' numArgs s
            return' i
          A.CatchPad { A.catchSwitch = catchSwitch, A.args = args } -> do
            catchSwitch' <- encodeM catchSwitch
            (numArgs, args') <- encodeM args
            i <- liftIO $ FFI.buildCatchPad builder catchSwitch' args' numArgs s
            return' i
          o -> $(TH.caseE [| o |] $
                  [TH.match
                   (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- encodeFieldNames ])
                   (TH.normalB (TH.doE handlerBody))
                   []
                   |
                   (name, ID.instructionKind -> k) <- Map.toList ID.instructionDefs,
                   case (k, name) of
                     (ID.Binary, _) -> True
                     (ID.Cast, _) -> True
                     (ID.Memory, "Alloca") -> False
                     (ID.Memory, _) -> True
                     _ -> False,
                   let
                     TH.RecC fullName (unzip3 -> (fieldNames, _, _)) = findInstrFields name
                     encodeFieldNames = filter (\f -> TH.nameBase f /= "metadata") fieldNames
                     encodeMFields = map TH.nameBase encodeFieldNames
                     handlerBody = ([
                       TH.bindS (if s == "fastMathFlags" then TH.tupP [] else TH.varP (TH.mkName s))
                           [| encodeM $(TH.dyn s) |] | s <- encodeMFields
                      ] ++ [
                       TH.bindS (TH.varP (TH.mkName "i")) [| liftIO $ $(
                          foldl1 TH.appE . map TH.dyn $
                           [ "FFI.build" ++ name, "builder" ] ++ (encodeMFields List.\\ [ "fastMathFlags" ]) ++ [ "s" ]
                        ) |],
                       TH.noBindS [| return' $(TH.dyn "i") |]
                      ])
                  ] ++
                  (map (\p -> TH.match p (TH.normalB [|inconsistentCases "Instruction" o|]) [])
                       [[p|A.Alloca{}|],
                        [p|A.ICmp{}|],
                        [p|A.FCmp{}|],
                        [p|A.Phi{}|],
                        [p|A.Call{}|],
                        [p|A.Select{}|],
                        [p|A.VAArg{}|],
                        [p|A.ExtractElement{}|],
                        [p|A.InsertElement{}|],
                        [p|A.ShuffleVector{}|],
                        [p|A.ExtractValue{}|],
                        [p|A.InsertValue{}|],
                        [p|A.LandingPad{}|],
                        [p|A.CatchPad{}|],
                        [p|A.CleanupPad{}|]])
                )

        setMD inst (A.metadata o)
        return (inst, act)
   |]
 )


instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (DecodeAST (A.Named a)) (Ptr FFI.Instruction) where
  decodeM :: Ptr Instruction -> DecodeAST (DecodeAST (Named a))
decodeM i :: Ptr Instruction
i = do
    Type
t <- Ptr Instruction -> DecodeAST Type
forall v. DescendentOf Value v => Ptr v -> DecodeAST Type
typeOf Ptr Instruction
i
    a -> Named a
w <- if Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
A.VoidType then ((a -> Named a) -> DecodeAST (a -> Named a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Named a
forall a. a -> Named a
A.Do) else ((Name -> a -> Named a) -> DecodeAST (Name -> a -> Named a)
forall (m :: * -> *) a. Monad m => a -> m a
return Name -> a -> Named a
forall a. Name -> a -> Named a
(A.:=) DecodeAST (Name -> a -> Named a)
-> DecodeAST Name -> DecodeAST (a -> Named a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Instruction -> DecodeAST Name
forall v. DescendentOf Value v => Ptr v -> DecodeAST Name
getLocalName Ptr Instruction
i)
    DecodeAST (Named a) -> DecodeAST (DecodeAST (Named a))
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodeAST (Named a) -> DecodeAST (DecodeAST (Named a)))
-> DecodeAST (Named a) -> DecodeAST (DecodeAST (Named a))
forall a b. (a -> b) -> a -> b
$ (a -> Named a) -> DecodeAST (a -> Named a)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Named a
w DecodeAST (a -> Named a) -> DecodeAST a -> DecodeAST (Named a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` Ptr Instruction -> DecodeAST a
forall (d :: * -> *) h c. DecodeM d h c => c -> d h
decodeM Ptr Instruction
i

guardNonVoidType :: (MonadIO m, MonadThrow m) => Ptr FFI.Instruction -> String -> m ()
guardNonVoidType :: Ptr Instruction -> [Char] -> m ()
guardNonVoidType instr :: Ptr Instruction
instr expr :: [Char]
expr = do
  Type
ty <- (IO Type -> m Type
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Type -> m Type)
-> (Ptr Instruction -> IO Type) -> Ptr Instruction -> m 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 Instruction -> DecodeAST Type)
-> Ptr Instruction
-> IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Instruction -> DecodeAST Type
forall v. DescendentOf Value v => Ptr v -> DecodeAST Type
typeOf) Ptr Instruction
instr
  case Type
ty of
    A.VoidType -> EncodeException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ([Char] -> EncodeException
EncodeException ("Instruction of type void must not have a name: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expr))
    _ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance (EncodeM EncodeAST a (Ptr FFI.Instruction), Show a) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where
  encodeM :: Named a -> EncodeAST (Ptr Instruction)
encodeM (A.Do o :: a
o) = a -> EncodeAST (Ptr Instruction)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM a
o
  encodeM assgn :: Named a
assgn@(n :: Name
n A.:= o :: a
o) = do
    Ptr Instruction
i <- a -> EncodeAST (Ptr Instruction)
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM a
o
    let v :: Ptr Value
v = Ptr Instruction -> Ptr Value
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast Ptr Instruction
i
    CString
n' <- Name -> EncodeAST CString
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
n
    IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Value -> CString -> IO ()
FFI.setValueName Ptr Value
v CString
n'
    Name -> Ptr Value -> EncodeAST ()
forall v. DescendentOf Value v => Name -> Ptr v -> EncodeAST ()
defineLocal Name
n Ptr Value
v
    Ptr Instruction -> [Char] -> EncodeAST ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Ptr Instruction -> [Char] -> m ()
guardNonVoidType Ptr Instruction
i (Named a -> [Char]
forall a. Show a => a -> [Char]
show Named a
assgn)
    Ptr Instruction -> EncodeAST (Ptr Instruction)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Instruction
i

instance (EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()), Show a) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where
  encodeM :: Named a -> EncodeAST (EncodeAST ())
encodeM (A.Do o :: a
o) = ((Ptr Instruction, EncodeAST ()) -> EncodeAST ())
-> EncodeAST (Ptr Instruction, EncodeAST ())
-> EncodeAST (EncodeAST ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Ptr Instruction, EncodeAST ()) -> EncodeAST ()
forall a b. (a, b) -> b
snd (EncodeAST (Ptr Instruction, EncodeAST ())
 -> EncodeAST (EncodeAST ()))
-> EncodeAST (Ptr Instruction, EncodeAST ())
-> EncodeAST (EncodeAST ())
forall a b. (a -> b) -> a -> b
$ (a -> EncodeAST (Ptr Instruction, EncodeAST ())
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM a
o :: EncodeAST (Ptr FFI.Instruction, EncodeAST ()))
  encodeM assgn :: Named a
assgn@(n :: Name
n A.:= o :: a
o) = do
    (i :: Ptr Instruction
i, later :: EncodeAST ()
later) <- a -> EncodeAST (Ptr Instruction, EncodeAST ())
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM a
o
    let v :: Ptr Value
v = Ptr Instruction -> Ptr Value
forall a b. DescendentOf a b => Ptr b -> Ptr a
FFI.upCast (Ptr Instruction
i :: Ptr FFI.Instruction)
    CString
n' <- Name -> EncodeAST CString
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM Name
n
    IO () -> EncodeAST ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EncodeAST ()) -> IO () -> EncodeAST ()
forall a b. (a -> b) -> a -> b
$ Ptr Value -> CString -> IO ()
FFI.setValueName Ptr Value
v CString
n'
    Name -> Ptr Value -> EncodeAST ()
forall v. DescendentOf Value v => Name -> Ptr v -> EncodeAST ()
defineLocal Name
n Ptr Value
v
    Ptr Instruction -> [Char] -> EncodeAST ()
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
Ptr Instruction -> [Char] -> m ()
guardNonVoidType Ptr Instruction
i (Named a -> [Char]
forall a. Show a => a -> [Char]
show Named a
assgn)
    EncodeAST () -> EncodeAST (EncodeAST ())
forall (m :: * -> *) a. Monad m => a -> m a
return EncodeAST ()
later