{-# 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" -> ([], 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 |]) "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.getAtomicRMWBinOp 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 v' a' 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