{-# 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
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