llvm-general-0.1: src/LLVM/General/Internal/Instruction.hs
{-# LANGUAGE
TemplateHaskell,
QuasiQuotes,
TupleSections,
MultiParamTypeClasses,
FlexibleContexts,
FlexibleInstances
#-}
module LLVM.General.Internal.Instruction where
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified LLVM.General.Internal.InstructionDefs as ID
import Data.Functor
import Control.Monad
import Control.Monad.Trans
import Control.Monad.AnyCont
import Control.Monad.State
import Control.Monad.Phased
import Foreign.Ptr
import qualified Data.Map as Map
import qualified Data.List as List
import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI
import qualified LLVM.General.Internal.FFI.BinaryOperator as FFI
import qualified LLVM.General.Internal.FFI.Instruction as FFI
import qualified LLVM.General.Internal.FFI.Value as FFI
import qualified LLVM.General.Internal.FFI.User as FFI
import qualified LLVM.General.Internal.FFI.Builder as FFI
import qualified LLVM.General.Internal.FFI.Constant as FFI
import qualified LLVM.General.Internal.FFI.BasicBlock as FFI
import LLVM.General.Internal.Atomicity ()
import LLVM.General.Internal.Attribute ()
import LLVM.General.Internal.CallingConvention ()
import LLVM.General.Internal.Coding
import LLVM.General.Internal.DecodeAST
import LLVM.General.Internal.EncodeAST
import LLVM.General.Internal.Metadata ()
import LLVM.General.Internal.Operand ()
import LLVM.General.Internal.RMWOperation ()
import LLVM.General.Internal.Type
import LLVM.General.Internal.Value
import qualified LLVM.General.AST as A
import qualified LLVM.General.AST.Constant as A.C
callInstAttr i j = liftIO $ decodeM =<< FFI.getCallInstAttr i j
meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata
meta i = do
let getMetadata n = scopeAnyCont $ do
ks <- allocaArray n
ps <- allocaArray n
n' <- liftIO $ FFI.getMetadata i ks ps n
if (n' > n)
then getMetadata n'
else return zip `ap` decodeM (n', ks) `ap` decodeM (n', ps)
getMetadata 4
instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where
decodeM i = scopeAnyCont $ do
n <- liftIO $ FFI.getInstructionDefOpcode i
nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i)
md <- meta i
let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n)
successor n = decodeM =<< (liftIO $ FFI.isABasicBlock =<< FFI.getOperand (FFI.upCast i) n)
case n of
[ID.instrP|Ret|] -> do
returnOperand' <- if nOps == 0 then return Nothing else Just <$> op 0
return $ A.Ret { A.returnOperand = returnOperand', A.metadata' = md }
[ID.instrP|Br|] -> do
n <- liftIO $ FFI.getNumOperands (FFI.upCast i)
case n of
1 -> do
dest <- successor 0
return $ A.Br { A.dest = dest, A.metadata' = md }
3 -> do
condition <- op 0
falseDest <- successor 1
trueDest <- successor 2
return $ A.CondBr {
A.condition = condition,
A.falseDest = falseDest,
A.trueDest = trueDest,
A.metadata' = md
}
[ID.instrP|Switch|] -> do
op0 <- op 0
dd <- successor 1
let nCases = (nOps - 2) `div` 2
values <- allocaArray nCases
dests <- allocaArray nCases
liftIO $ FFI.getSwitchCases i values dests
cases <- return zip `ap` peekArray nCases values `ap` peekArray nCases dests
dests <- forM cases $ \(c, d) -> return (,) `ap` decodeM c `ap` decodeM d
return A.Switch {
A.operand0' = op0,
A.defaultDest = dd,
A.dests = dests,
A.metadata' = md
}
[ID.instrP|IndirectBr|] -> do
op0 <- op 0
let nDests = nOps - 1
dests <- allocaArray nDests
liftIO $ FFI.getIndirectBrDests i dests
dests <- decodeM (nDests, dests)
return A.IndirectBr {
A.operand0' = op0,
A.possibleDests = dests,
A.metadata' = md
}
[ID.instrP|Invoke|] -> do
cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i)
rAttrs <- callInstAttr i 0
fv <- liftIO $ FFI.getCallInstCalledValue i
f <- decodeM fv
args <- forM [1..nOps-3] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j
fAttrs <- decodeM =<< liftIO (FFI.getCallInstFunctionAttr i)
rd <- successor (nOps - 2)
ed <- successor (nOps - 1)
return A.Invoke {
A.callingConvention' = cc,
A.returnAttributes' = rAttrs,
A.function' = f,
A.arguments' = args,
A.functionAttributes' = fAttrs,
A.returnDest = rd,
A.exceptionDest = ed,
A.metadata' = md
}
[ID.instrP|Resume|] -> do
op0 <- op 0
return A.Resume {
A.operand0' = op0,
A.metadata' = md
}
[ID.instrP|Unreachable|] -> do
return A.Unreachable {
A.metadata' = md
}
instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where
encodeM t = scopeAnyCont $ do
builder <- gets encodeStateBuilder
s <- encodeM ""
t' <- case t of
A.Ret { A.returnOperand = r } -> do
rv <- maybe (return nullPtr) encodeM r
FFI.upCast <$> do liftIO $ FFI.buildRet builder rv
A.Br { A.dest = d } -> do
db <- encodeM d
FFI.upCast <$> do liftIO $ FFI.buildBr builder db
A.CondBr { A.condition = c, A.trueDest = t, A.falseDest = f } -> do
cv <- encodeM c
tb <- encodeM t
fb <- encodeM f
FFI.upCast <$> do liftIO $ FFI.buildCondBr builder cv tb fb
A.Switch {
A.operand0' = op0,
A.defaultDest = dd,
A.dests = ds
} -> do
op0' <- encodeM op0
dd' <- encodeM dd
i <- liftIO $ FFI.buildSwitch builder op0' dd' (fromIntegral $ length ds)
forM ds $ \(v,d) -> do
v' <- encodeM v
d' <- encodeM d
liftIO $ FFI.addCase i v' d'
return $ FFI.upCast i
A.IndirectBr {
A.operand0' = op0,
A.possibleDests = dests
} -> do
op0' <- encodeM op0
i <- liftIO $ FFI.buildIndirectBr builder op0' (fromIntegral $ length dests)
forM dests $ \dest -> do
d <- encodeM dest
liftIO $ FFI.addDestination i d
return $ FFI.upCast i
A.Invoke {
A.callingConvention' = cc,
A.returnAttributes' = rAttrs,
A.function' = fun,
A.arguments' = args,
A.functionAttributes' = fAttrs,
A.returnDest = rd,
A.exceptionDest = ed
} -> do
fv <- encodeM fun
rb <- encodeM rd
eb <- encodeM ed
let (argvs, argAttrs) = unzip args
(n, argvs) <- encodeM argvs
i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s
forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do
attrs <- encodeM attrs
liftIO $ FFI.addCallInstAttr i j attrs
fAttrs <- encodeM fAttrs
liftIO $ FFI.addCallInstFunctionAttr i fAttrs
cc <- encodeM cc
liftIO $ FFI.setInstructionCallConv i cc
return $ FFI.upCast i
A.Resume {
A.operand0' = op0
} -> do
op0' <- encodeM op0
i <- liftIO $ FFI.buildResume builder op0'
return $ FFI.upCast i
A.Unreachable {
} -> do
i <- liftIO $ FFI.buildUnreachable builder
return $ FFI.upCast i
forM (A.metadata' t) $ \(k, mdn) -> do
k <- encodeM k
mdn <- encodeM mdn
liftIO $ FFI.setMetadata t' k mdn
return 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 b
get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap b
get_exact b = liftIO $ decodeM =<< FFI.isExact 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") |])
"operand0" -> ([], [| op 0 |])
"operand1" -> ([], [| op 1 |])
"address" -> ([], [| op 0 |])
"value" -> ([], [| 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 |])
"personalityFunction" -> ([], [| op 0 |])
"mask" -> ([], [| cop 2 |])
"aggregate" -> ([], [| op 0 |])
"metadata" -> ([], [| meta i |])
"iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |])
"fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |])
"isTailCall" -> ([], [| decodeM =<< liftIO (FFI.isTailCall i) |])
"callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getInstructionCallConv i) |])
"returnAttributes" -> ([], [| callInstAttr i 0 |])
"f" -> ([], [| liftIO $ FFI.getCallInstCalledValue i |])
"function" -> (["f"], [| decodeM $(TH.dyn "f") |])
"arguments" -> ([], [| forM [1..nOps-1] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j |])
"clauses" ->
([], [| forM [1..nOps-1] $ \j -> do
v <- liftIO $ FFI.getOperand (FFI.upCast i) j
c <- decodeM =<< (liftIO $ FFI.isAConstant v)
t <- typeOf v
return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |])
"functionAttributes" ->
([], [| decodeM =<< liftIO (FFI.getCallInstFunctionAttr i) |])
"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)) |])
"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.getAtomicRMWOperation i) |])
"cleanup" -> ([], [| decodeM =<< liftIO (FFI.isCleanup i) |])
_ -> ([], [| 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 ])
|]
]
]
)
instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction) where
encodeM o = scopeAnyCont $ do
builder <- gets encodeStateBuilder
s <- encodeM ""
$(
[|
case o of
A.ICmp {
A.iPredicate = pred,
A.operand0 = op0,
A.operand1 = op1,
A.metadata = []
} -> do
op0' <- encodeM op0
op1' <- encodeM op1
pred <- encodeM pred
i <- liftIO $ FFI.buildICmp builder pred op0' op1' s
return $ FFI.upCast i
A.FCmp {
A.fpPredicate = pred,
A.operand0 = op0,
A.operand1 = op1,
A.metadata = []
} -> do
op0' <- encodeM op0
op1' <- encodeM op1
pred <- encodeM pred
i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s
return $ FFI.upCast i
A.Phi { A.type' = t, A.incomingValues = ivs } -> do
t' <- encodeM t
i <- liftIO $ FFI.buildPhi builder t' s
defer
let (ivs3, bs3) = unzip ivs
ivs3' <- encodeM ivs3
bs3' <- encodeM bs3
liftIO $ FFI.addIncoming i ivs3' bs3'
return $ FFI.upCast i
A.Call {
A.isTailCall = tc,
A.callingConvention = cc,
A.returnAttributes = rAttrs,
A.function = f,
A.arguments = args,
A.functionAttributes = fAttrs,
A.metadata = []
} -> do
fv <- encodeM f
let (argvs, argAttrs) = unzip args
(n, argvs) <- encodeM argvs
i <- liftIO $ FFI.buildCall builder fv argvs n s
forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do
attrs <- encodeM attrs
liftIO $ FFI.addCallInstAttr i j attrs
fAttrs <- encodeM fAttrs
liftIO $ FFI.addCallInstFunctionAttr i fAttrs
when tc $ do
tc <- encodeM tc
liftIO $ FFI.setTailCall i tc
cc <- encodeM cc
liftIO $ FFI.setInstructionCallConv i cc
return $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast 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 $ FFI.upCast i
A.LandingPad {
A.type' = t,
A.personalityFunction = pf,
A.cleanup = cl,
A.clauses = cs
} -> do
t' <- encodeM t
pf' <- encodeM pf
i <- liftIO $ FFI.buildLandingPad builder t' pf' (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 $ fail $ "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 $ fail $ "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 $ FFI.upCast i
A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do
alt' <- encodeM alt
n' <- maybe (return nullPtr) encodeM n
i <- liftIO $ FFI.buildAlloca builder alt' n' s
unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)
return $ FFI.upCast i
A.Load {
A.volatile = vol,
A.address = a,
A.alignment = al,
A.maybeAtomicity = mat,
A.metadata = []
} -> do
a' <- encodeM a
al <- encodeM al
vol <- encodeM vol
(ss, mo) <- encodeM mat
i <- liftIO $ FFI.buildLoad builder a' al vol mo ss s
return $ FFI.upCast i
A.Store {
A.volatile = vol,
A.address = a,
A.value = v,
A.maybeAtomicity = mat,
A.alignment = al,
A.metadata = []
} -> do
a' <- encodeM a
v' <- encodeM v
al <- encodeM al
vol <- encodeM vol
(ss, mo) <- encodeM mat
i <- liftIO $ FFI.buildStore builder a' v' al vol mo ss s
return $ FFI.upCast i
A.GetElementPtr { A.address = a, A.indices = is, A.inBounds = ib } -> do
a' <- encodeM a
(n, is') <- encodeM is
i <- liftIO $ FFI.buildGetElementPtr builder a' is' n s
when ib $ do
ib <- encodeM ib
liftIO $ FFI.setInBounds i ib
return $ FFI.upCast i
A.Fence { A.atomicity = at } -> do
(ss, mo) <- encodeM at
i <- liftIO $ FFI.buildFence builder mo ss s
return $ FFI.upCast i
A.CmpXchg {
A.volatile = vol,
A.address = a, A.expected = e, A.replacement = r,
A.atomicity = at,
A.metadata = []
} -> do
a' <- encodeM a
e' <- encodeM e
r' <- encodeM r
vol <- encodeM vol
(ss, mo) <- encodeM at
i <- liftIO $ FFI.buildCmpXchg builder a' e' r' vol mo ss s
return $ FFI.upCast i
A.AtomicRMW {
A.volatile = vol,
A.rmwOperation = rmwOp,
A.address = a,
A.value = v,
A.atomicity = at,
A.metadata = []
} -> do
a' <- encodeM a
v' <- encodeM v
rmwOp <- encodeM rmwOp
vol <- encodeM vol
(ss, mo) <- encodeM at
i <- liftIO $ FFI.buildAtomicRMW builder rmwOp a' v' vol mo ss s
return $ FFI.upCast i
o -> $(
let
fieldData :: String -> [Either TH.ExpQ TH.ExpQ]
fieldData s = case s of
"operand0" -> [Left [| encodeM $(TH.dyn s) |] ]
"operand1" -> [Left [| encodeM $(TH.dyn s) |] ]
"type'" -> [Left [| encodeM $(TH.dyn s) |] ]
"nsw" -> [Left [| encodeM $(TH.dyn s) |] ]
"nuw" -> [Left [| encodeM $(TH.dyn s) |] ]
"exact" -> [Left [| encodeM $(TH.dyn s) |] ]
"metadata" ->
[Right [| unless (List.null $(TH.dyn s)) $ error "can't handle metadata yet" |]]
_ -> error $ "unhandled instruction field " ++ show s
in
TH.caseE [| o |] [
TH.match
(TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])
(TH.normalB (TH.doE handlerBody))
[]
|
(name, ID.InstructionDef { ID.instructionKind = k }) <- Map.toList ID.instructionDefs,
k `List.elem` [ID.Binary, ID.Cast],
let
TH.RecC fullName fields = findInstrFields name
(fieldNames, _, _) = unzip3 fields
cTorFields = [
(s, binding)
| f <- fieldNames,
let s = TH.nameBase f,
Left binding <- fieldData s
]
handlerBody = (
[ TH.bindS (TH.varP (TH.mkName s)) binding | (s, binding) <- cTorFields ]
++ [
TH.bindS
(TH.varP (TH.mkName "i"))
[| liftIO $ $(foldl1 TH.appE . map TH.dyn $ [
"FFI.build" ++ name,
"builder"
] ++ [
s | (s, _) <- cTorFields, s /= "metadata"
] ++ [
"s"
] ) |]
] ++ [
TH.noBindS action
| f <- fieldNames,
let s = TH.nameBase f,
Right action <- fieldData s
] ++ [
TH.noBindS [| return $ FFI.upCast $(TH.dyn "i") |]
]
)
]
)
|]
)
|]
)
instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (A.Named a) (Ptr FFI.Instruction) where
decodeM i = do
t <- typeOf i
(if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)) `ap` (do defer; decodeM i)
instance EncodeM EncodeAST a (Ptr FFI.Instruction) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where
encodeM (A.Do o) = encodeM o
encodeM (n A.:= o) = do
i <- encodeM o
let v = FFI.upCast i
n' <- encodeM n
liftIO $ FFI.setValueName v n'
defineLocal n v
return i