module LLVM.ST
( CUInt, CULLong
, IntPredicate(..), FPPredicate(..)
, LLVM, MonadLLVM
, getContext, liftLL, liftST
, MemoryBuffer
, createMemoryBufferWithContentsOfFile
, createMemoryBufferWithSTDIN
, createMemoryBufferWithMemoryRange
, createMemoryBufferWithMemoryRangeCopy
, run, run2, runLLVM
, Context
, W.getGlobalContext
, W.contextCreate
, STPassManager
, createPassManager
, populateModulePassManager
, populateLTOPassManager
, runPassManager
, ModuleGen, MonadMG
, runModuleGen, liftMG
, STModule
, Module
, unsafeFreeze, unsafeThaw
, parseBitcode
, writeBitcodeToFile
, getModule
, genModule
, verifyModule
, showModule
, linkModules
, STBasicBlock
, appendBasicBlock
, STValue
, Linkage(..)
, Attribute(..)
, CallingConvention(..)
, showValue
, typeOf
, findGlobal, findFunction
, addFunction, genFunction, defineFunction, runCodeGen
, getFuncCallConv, setFuncCallConv, setInstrCallConv
, getFunctionParams
, addParamAttrib, addFuncAttrib, removeAttrib
, getLinkage, setLinkage
, getTailCall, setTailCall
, verifyFunction
, getUndef
, isConstant, isNull, isUndef, isUnreachable
, constInt
, constPtrNull
, constString, constStruct
, STType
, TypeKind(..)
, typeKind
, showType
, findType
, sizeOf
, intType, floatType, doubleType, voidType
, functionType, structType, vectorType, arrayType
, pointerTypeInSpace, pointerType
, structCreateNamed, structSetBody
, CodeGen, MonadCG
, liftCG
, position, positionAtEnd, positionBefore, positionAfter
, getEntryBasicBlock, getNextBasicBlock
, getFirstInstruction, getNextInstruction, getPreviousInstruction, getLastInstruction
, getInsertBlock, getFunction, getParams
, getValueName, setValueName
, buildTrunc
, buildZExt
, buildSExt
, buildFPToUI
, buildFPToSI
, buildUIToFP
, buildSIToFP
, buildFPTrunc
, buildFPExt
, buildPtrToInt
, buildIntToPtr
, buildBitCast
, buildPointerCast
, buildTruncOrBitCast
, buildZExtOrBitCast
, buildSExtOrBitCast
, buildInBoundsGEP
, buildAlloca
, buildLoad, buildStore
, buildCall
, buildBr, buildCondBr
, buildSwitch, addCase
, buildPhi, addIncoming
, buildCase, buildIf
, buildRet, buildUnreachable
, buildAdd
, buildSub
, buildMul
, buildFAdd
, buildFMul
, buildFPCast
, buildFSub
, buildUDiv
, buildSDiv
, buildExactSDiv
, buildFDiv
, buildURem
, buildSRem
, buildFRem
, buildShl
, buildLShr
, buildAShr
, buildAnd
, buildOr
, buildXor
, buildNeg
, buildFNeg
, buildNot
, buildNSWAdd
, buildNSWMul
, buildNSWNeg
, buildNSWSub
, buildNUWAdd
, buildNUWMul
, buildNUWNeg
, buildNUWSub
, buildICmp, buildFCmp
, buildGlobalString, buildGlobalStringPtr
, constAdd
, constSub
, constMul
, constFAdd
, constFMul
, constFPCast
, constFSub
, constUDiv
, constSDiv
, constFDiv
, constURem
, constSRem
, constFRem
, constAnd
, constOr
, constXor
, constShl
, constLShr
, constAShr
, constGEP
, constTrunc
, constSExt
, constZExt
, constFPTrunc
, constFPExt
, constUIToFP
, constSIToFP
, constFPToUI
, constFPToSI
, constPtrToInt
, constIntToPtr
, constBitCast
)
where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.ST.Safe
import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)
import System.IO.Unsafe (unsafePerformIO)
import qualified LLVM.Wrapper.Core as W
import qualified LLVM.Wrapper.Linker as W
import qualified LLVM.Wrapper.BitReader as W
import qualified LLVM.Wrapper.BitWriter as W
import qualified LLVM.Wrapper.Analysis as W
import qualified LLVM.Wrapper.Transforms.PassManagerBuilder as W
import LLVM.Wrapper.Core ( MemoryBuffer, Context, BasicBlock, Type, Value, Builder
, CUInt, CULLong
, TypeKind(..)
, Linkage(..)
, Attribute(..)
, CallingConvention(..)
, IntPredicate(..), FPPredicate(..)
, createMemoryBufferWithContentsOfFile
, createMemoryBufferWithSTDIN
, createMemoryBufferWithMemoryRange
, createMemoryBufferWithMemoryRangeCopy
)
newtype STPassManager c s = STPM W.PassManager
deriving Eq
newtype Module = PM W.Module
deriving Eq
newtype STModule c s = STM { unSTM :: W.Module }
deriving Eq
newtype STBasicBlock c s = STB { unSTB :: BasicBlock }
deriving Eq
newtype STType c s = STT { unSTT :: Type }
deriving Eq
newtype STValue c s = STV { unSTV :: Value }
deriving Eq
writeBitcodeToFile :: Module -> FilePath -> IO ()
writeBitcodeToFile (PM m) = W.writeBitcodeToFile m
verifyModule :: Module -> Maybe String
verifyModule (PM m) = unsafePerformIO (W.verifyModule m)
instance Show Module where
show (PM m) = unsafePerformIO $ W.dumpModuleToString m
newtype LLVM c s a = LL (ReaderT Context (ST s) a)
deriving (Functor, Applicative, Monad)
class MonadLLVM m where
getContext :: m c s Context
liftLL :: LLVM c s a -> m c s a
liftST :: ST s a -> m c s a
instance MonadLLVM LLVM where
getContext = LL ask
liftLL = id
liftST = LL . lift
wrap :: MonadLLVM m => IO a -> m c s a
wrap = liftLL . LL . lift . unsafeIOToST
run :: Context -> (forall c s. LLVM c s (STModule c s)) -> Module
run ctx action = runST $ runLLVM ctx (action >>= unsafeFreeze)
run2 :: Context -> (forall c s. LLVM c s (STModule c s, a)) -> (Module, a)
run2 ctx action = runST $ runLLVM ctx (do (m, x) <- action; m' <- unsafeFreeze m; return (m', x))
runLLVM :: Context -> (forall c. LLVM c s a) -> ST s a
runLLVM ctx (LL lm) = runReaderT lm ctx
unsafeFreeze :: (Monad (m c s), MonadLLVM m) => STModule c s -> m c s Module
unsafeFreeze (STM m) = liftLL $ return (PM m)
unsafeThaw :: (Monad (m c s), MonadLLVM m) => Module -> m c s (STModule c s)
unsafeThaw (PM m) = liftLL $ return $ STM m
showModule :: (Monad (m c s), MonadLLVM m) => STModule c s -> m c s String
showModule (STM m) = wrap . W.dumpModuleToString $ m
linkModules :: (Monad (m c s), MonadLLVM m) => STModule c s -> STModule c s -> m c s (Maybe String)
linkModules (STM dest) (STM src) = wrap $ W.linkModules dest src W.DestroySource
parseBitcode :: (Functor (m c s), Monad (m c s), MonadLLVM m) =>
MemoryBuffer -> m c s (Either String (STModule c s))
parseBitcode buf = do ctx <- getContext
(fmap . fmap) STM . wrap $ W.parseBitcodeInContext ctx buf
sizeOf :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s (STValue c s)
sizeOf (STT ty) = wrap . fmap STV $ W.sizeOf ty
typeKind :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s TypeKind
typeKind (STT t) = wrap $ W.getTypeKind t
showType :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s String
showType (STT t) = wrap . W.dumpTypeToString $ t
showValue :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s String
showValue (STV v) = wrap . W.dumpValueToString $ v
functionType :: (Monad (m c s), MonadLLVM m) => STType c s -> [STType c s] -> Bool -> m c s (STType c s)
functionType (STT ret) args variadic =
liftLL $ return $ STT (W.functionType ret (map unSTT args) variadic)
intType :: (Monad (m c s), MonadLLVM m) => CUInt -> m c s (STType c s)
intType i = do ctx <- getContext
wrap . fmap STT $ W.intTypeInContext ctx i
doubleType :: (Monad (m c s), MonadLLVM m) => m c s (STType c s)
doubleType = do ctx <- getContext
wrap . fmap STT $ W.doubleTypeInContext ctx
floatType :: (Monad (m c s), MonadLLVM m) => m c s (STType c s)
floatType = do ctx <- getContext
wrap . fmap STT $ W.floatTypeInContext ctx
voidType :: (Monad (m c s), MonadLLVM m) => m c s (STType c s)
voidType = do ctx <- getContext
wrap . fmap STT $ W.voidTypeInContext ctx
structType :: (Monad (m c s), MonadLLVM m) => [STType c s] -> Bool -> m c s (STType c s)
structType types packed = do ctx <- getContext
wrap . fmap STT $ W.structTypeInContext ctx (map unSTT types) packed
structCreateNamed :: (Monad (m c s), MonadLLVM m) => String -> m c s (STType c s)
structCreateNamed n = getContext >>= wrap . fmap STT . flip W.structCreateNamedInContext n
structSetBody :: (Monad (m c s), MonadLLVM m) => STType c s -> [STType c s] -> Bool -> m c s ()
structSetBody (STT struct) body packed = wrap $ W.structSetBody struct (map unSTT body) packed
vectorType :: (Monad (m c s), MonadLLVM m) => STType c s -> CUInt -> m c s (STType c s)
vectorType (STT t) count = return $ STT (W.vectorType t count)
arrayType :: (Monad (m c s), MonadLLVM m) => STType c s -> CUInt -> m c s (STType c s)
arrayType (STT t) count = return $ STT (W.arrayType t count)
pointerTypeInSpace :: (Monad (m c s), MonadLLVM m) => STType c s -> CUInt -> m c s (STType c s)
pointerTypeInSpace (STT t) addrSpace = return $ STT (W.pointerType t addrSpace)
pointerType :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s (STType c s)
pointerType ty = pointerTypeInSpace ty 0
getValueName :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s String
getValueName (STV v) = wrap $ W.getValueName v
setValueName :: (Monad (m c s), MonadLLVM m) => STValue c s -> String -> m c s ()
setValueName (STV v) = wrap . W.setValueName v
isUnreachable :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
isUnreachable (STV v) = wrap $ W.isUnreachable v
isConstant :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
isConstant (STV v) = wrap $ W.isConstant v
isNull :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
isNull (STV v) = wrap $ W.isNull v
isUndef :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
isUndef (STV v) = wrap $ W.isUndef v
getUndef :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s (STValue c s)
getUndef = return . STV . W.getUndef . unSTT
constInt :: (Monad (m c s), MonadLLVM m) => STType c s -> CULLong -> Bool -> m c s (STValue c s)
constInt (STT intTy) value signExtend = return . STV $ W.constInt intTy value signExtend
constPtrNull :: (Monad (m c s), MonadLLVM m) => STType c s -> m c s (STValue c s)
constPtrNull (STT ty) = wrap . fmap STV $ W.constPointerNull ty
constString :: (Monad (m c s), MonadLLVM m) => String -> Bool -> m c s (STValue c s)
constString str nullTerminated = do
ctx <- getContext
wrap . fmap STV $ W.constStringInContext ctx str nullTerminated
constStruct :: (Monad (m c s), MonadLLVM m) => [STValue c s] -> Bool -> m c s (STValue c s)
constStruct values packed = do
ctx <- getContext
wrap . fmap STV $ W.constStructInContext ctx (map unSTV values) packed
appendBasicBlock :: (Monad (m c s), MonadLLVM m) =>
String -> STValue c s -> m c s (STBasicBlock c s)
appendBasicBlock name (STV func) = do
ctx <- getContext
wrap . fmap STB $ W.appendBasicBlockInContext ctx func name
getFunctionParams :: (Functor (m c s), Monad (m c s), MonadLLVM m) =>
STValue c s -> m c s [STValue c s]
getFunctionParams (STV func) = (fmap . fmap) STV . wrap $ W.getParams func
addParamAttrib :: (Monad (m c s), MonadLLVM m) => STValue c s -> Attribute -> m c s ()
addParamAttrib (STV param) = wrap . W.addAttribute param
addFuncAttrib :: (Monad (m c s), MonadLLVM m) => STValue c s -> Attribute -> m c s ()
addFuncAttrib (STV func) = wrap . W.addFunctionAttr func
removeAttrib :: (Monad (m c s), MonadLLVM m) => STValue c s -> Attribute -> m c s ()
removeAttrib (STV val) = wrap . W.removeAttribute val
typeOf :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s (STType c s)
typeOf (STV v) = wrap . fmap STT $ W.typeOf v
data MGS = MGS { mgModule :: W.Module, mgCtx :: Context }
newtype ModuleGen c s a = MG (ReaderT MGS (ST s) a)
deriving (Functor, Applicative, Monad)
class MonadLLVM m => MonadMG m where
liftMG :: ModuleGen c s a -> m c s a
instance MonadReader (STModule c s) (ModuleGen c s) where
ask = fmap (STM . mgModule) (MG ask)
local f (MG mg) = MG (local (\(MGS m ctx) -> MGS (unSTM . f . STM $ m) ctx) mg)
instance MonadLLVM ModuleGen where
getContext = fmap mgCtx $ MG ask
liftLL (LL s) = do ctx <- getContext
MG (lift $ runReaderT s ctx)
liftST = MG . lift
instance MonadMG ModuleGen where
liftMG = id
unsafeMod :: ModuleGen c s W.Module
unsafeMod = fmap mgModule $ MG ask
getModule :: MonadMG m => m c s (STModule c s)
getModule = liftMG ask
genModule :: (Monad (m c s), MonadLLVM m) => String -> ModuleGen c s a -> m c s a
genModule name (MG mg) = do
ctx <- getContext
wrap $ do
m <- W.moduleCreateWithNameInContext name ctx
unsafeSTToIO . runReaderT mg $ MGS m ctx
runModuleGen :: (Monad (m c s), MonadLLVM m) => STModule c s -> ModuleGen c s a -> m c s a
runModuleGen (STM m) (MG mg) = do
ctx <- getContext
liftLL $ LL . lift . runReaderT mg $ MGS m ctx
createPassManager :: (Functor (m c s), MonadLLVM m) => m c s (STPassManager c s)
createPassManager = fmap STPM . wrap $ W.createPassManager
populateModulePassManager :: MonadLLVM m => CUInt -> CUInt -> STPassManager c s -> m c s ()
populateModulePassManager optLevel optSizeLevel (STPM pm) =
wrap $ do
pmb <- W.passManagerBuilderCreate
W.passManagerBuilderSetOptLevel pmb optLevel
W.passManagerBuilderSetSizeLevel pmb optSizeLevel
W.passManagerBuilderPopulateModulePassManager pmb pm
populateLTOPassManager :: MonadLLVM m => CUInt -> CUInt -> Bool -> Bool -> STPassManager c s -> m c s ()
populateLTOPassManager optLevel optSizeLevel internalize inline (STPM pm) =
wrap $ do
pmb <- W.passManagerBuilderCreate
W.passManagerBuilderSetOptLevel pmb optLevel
W.passManagerBuilderSetSizeLevel pmb optSizeLevel
W.passManagerBuilderPopulateLTOPassManager pmb pm internalize inline
runPassManager :: MonadLLVM m => STPassManager c s -> STModule c s -> m c s Bool
runPassManager (STPM pm) (STM m) = wrap $ W.runPassManager pm m
findType :: MonadMG m => String -> m c s (Maybe (STType c s))
findType name = liftMG $ unsafeMod >>= ((fmap . fmap) STT . wrap . flip W.getTypeByName name)
findGlobal :: MonadMG m => String -> m c s (Maybe (STValue c s))
findGlobal name = liftMG $ unsafeMod >>= ((fmap . fmap) STV . wrap . flip W.getNamedGlobal name)
findFunction :: MonadMG m => String -> m c s (Maybe (STValue c s))
findFunction name = liftMG $ unsafeMod >>= ((fmap . fmap) STV . wrap . flip W.getNamedFunction name)
addFunction :: MonadMG m => String -> STType c s -> m c s (STValue c s)
addFunction name (STT ty) = liftMG $ unsafeMod >>= (\m -> fmap STV . wrap $ W.addFunction m name ty)
getLinkage :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Linkage
getLinkage (STV v) = wrap (W.getLinkage v)
setLinkage :: (Monad (m c s), MonadLLVM m) => STValue c s -> Linkage -> m c s ()
setLinkage (STV v) = wrap . W.setLinkage v
getTailCall :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
getTailCall (STV call) = wrap $ W.isTailCall call
setTailCall :: (Monad (m c s), MonadLLVM m) => STValue c s -> Bool -> m c s ()
setTailCall (STV call) = wrap . W.setTailCall call
setFuncCallConv :: (Monad (m c s), MonadLLVM m) => STValue c s -> CallingConvention -> m c s ()
setFuncCallConv (STV func) = wrap . W.setFunctionCallConv func
getFuncCallConv :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s CallingConvention
getFuncCallConv (STV func) = wrap $ W.getFunctionCallConv func
setInstrCallConv :: (Monad (m c s), MonadLLVM m) => STValue c s -> CallingConvention -> m c s ()
setInstrCallConv (STV func) = wrap . W.setInstructionCallConv func
data CGS = CGS { cgBuilder :: Builder, cgMGS :: MGS }
newtype CodeGen c s a = CG { unCG :: ReaderT CGS (ST s) a }
deriving (Functor, Applicative, Monad)
class MonadMG m => MonadCG m where
liftCG :: CodeGen c s a -> m c s a
instance MonadLLVM CodeGen where
getContext = fmap (mgCtx . cgMGS) $ CG ask
liftLL (LL s) = do ctx <- getContext
CG (lift $ runReaderT s ctx)
liftST = CG . lift
instance MonadMG CodeGen where
liftMG (MG mg) =
do r <- CG ask
CG (lift $ runReaderT mg (cgMGS r))
instance MonadCG CodeGen where
liftCG = id
genFunction :: (Functor (m c s), Monad (m c s), MonadMG m) =>
String -> STType c s -> CodeGen c s a -> m c s a
genFunction name ty cg = do
f <- addFunction name ty
bb <- appendBasicBlock "entry" f
mgs <- liftMG $ MG ask
wrap (do b <- W.createBuilderInContext (mgCtx mgs)
unsafeSTToIO (runReaderT (unCG (positionAtEnd bb >> cg)) (CGS b mgs)))
defineFunction :: (Functor (m c s), Monad (m c s), MonadMG m) =>
STValue c s -> CodeGen c s a -> m c s a
defineFunction func cg = do
bb <- appendBasicBlock "entry" func
mgs <- liftMG $ MG ask
wrap (do b <- W.createBuilderInContext (mgCtx mgs)
unsafeSTToIO (runReaderT (unCG (positionAtEnd bb >> cg)) (CGS b mgs)))
runCodeGen :: (Monad (m c s), MonadMG m) =>
STValue c s -> CodeGen c s a -> ModuleGen c s a
runCodeGen (STV func) cg = do
bbs <- wrap $ W.getBasicBlocks func
let cg' = if null bbs then cg else positionAtEnd (STB (last bbs)) >> cg
mgs <- MG ask
wrap (do b <- W.createBuilderInContext (mgCtx mgs)
unsafeSTToIO (runReaderT (unCG cg') (CGS b mgs)))
verifyFunction :: (Monad (m c s), MonadLLVM m) => STValue c s -> m c s Bool
verifyFunction (STV f) = wrap (W.verifyFunction f)
position :: MonadCG m => STBasicBlock c s -> STValue c s -> m c s ()
position (STB block) (STV instr) = liftCG $ do
b <- fmap cgBuilder $ CG ask
wrap $ W.positionBuilder b block instr
positionAtEnd :: MonadCG m => STBasicBlock c s -> m c s ()
positionAtEnd (STB block) = liftCG $ CG ask >>= wrap . flip W.positionAtEnd block . cgBuilder
positionBefore :: MonadCG m => STValue c s -> m c s ()
positionBefore (STV v) = liftCG $ CG ask >>= wrap . flip W.positionBefore v . cgBuilder
positionAfter :: MonadCG m => STValue c s -> m c s ()
positionAfter (STV v) =
liftCG $ CG ask >>=
(\builder ->
wrap $ do
block <- W.getInstructionParent v
W.positionBuilder builder block v) . cgBuilder
getFirstInstruction :: MonadLLVM m => STBasicBlock c s -> m c s (STValue c s)
getFirstInstruction (STB b) = wrap . fmap STV . W.getFirstInstruction $ b
getLastInstruction :: MonadLLVM m => STBasicBlock c s -> m c s (STValue c s)
getLastInstruction (STB b) = wrap . fmap STV . W.getLastInstruction $ b
getNextInstruction :: MonadLLVM m => STValue c s -> m c s (STValue c s)
getNextInstruction (STV v) = wrap . fmap STV . W.getNextInstruction $ v
getPreviousInstruction :: MonadLLVM m => STValue c s -> m c s (STValue c s)
getPreviousInstruction (STV v) = wrap . fmap STV . W.getPreviousInstruction $ v
getInsertBlock :: MonadCG m => m c s (STBasicBlock c s)
getInsertBlock = liftCG $ CG ask >>= wrap . fmap STB . W.getInsertBlock . cgBuilder
getEntryBasicBlock :: MonadLLVM m => STValue c s -> m c s (STBasicBlock c s)
getEntryBasicBlock (STV f) = liftLL $ wrap . fmap STB . W.getEntryBasicBlock $ f
getNextBasicBlock :: MonadLLVM m => STBasicBlock c s -> m c s (Maybe (STBasicBlock c s))
getNextBasicBlock (STB b) = liftLL $ wrap . (fmap . fmap) STB . W.getNextBasicBlock $ b
getFunction :: MonadCG m => m c s (STValue c s)
getFunction = liftCG $ getInsertBlock >>= (\(STB b) -> wrap . fmap STV $ W.getBasicBlockParent b)
getParams :: MonadCG m => m c s [STValue c s]
getParams = liftCG $ getFunction >>= getFunctionParams
buildInBoundsGEP :: (Monad (m c s), MonadCG m) => String -> STValue c s -> [STValue c s] -> m c s (STValue c s)
buildInBoundsGEP name (STV aggPtr) indices = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildInBoundsGEP b aggPtr (map unSTV indices) name
constGEP :: (Monad (m c s), MonadCG m) => STValue c s -> [STValue c s] -> m c s (STValue c s)
constGEP (STV aggPtr) indices =
wrap . fmap STV $ W.constGEP aggPtr (map unSTV indices)
buildAlloca :: (Monad (m c s), MonadCG m) => String -> STType c s -> m c s (STValue c s)
buildAlloca name (STT ty) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildAlloca b ty name
buildLoad :: (Monad (m c s), MonadCG m) => String -> STValue c s -> m c s (STValue c s)
buildLoad name (STV ptr) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildLoad b ptr name
buildStore :: (Monad (m c s), MonadCG m) => STValue c s -> STValue c s -> m c s (STValue c s)
buildStore (STV value) (STV ptr) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildStore b value ptr
buildCall :: (Monad (m c s), MonadCG m) =>
String -> STValue c s -> [STValue c s] -> m c s (STValue c s)
buildCall name (STV func) args = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildCall b func (map unSTV args) name
buildRet :: (Monad (m c s), MonadCG m) => STValue c s -> m c s (STValue c s)
buildRet (STV x) = do b <- liftCG $ CG ask; wrap . fmap STV $ W.buildRet (cgBuilder b) x
buildBr :: (Monad (m c s), MonadCG m) => STBasicBlock c s -> m c s (STValue c s)
buildBr (STB block) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildBr b block
buildCondBr :: (Monad (m c s), MonadCG m) =>
STValue c s -> STBasicBlock c s -> STBasicBlock c s -> m c s (STValue c s)
buildCondBr (STV cond) (STB trueBlock) (STB falseBlock) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildCondBr b cond trueBlock falseBlock
buildSwitch :: (Monad (m c s), MonadCG m) =>
STValue c s -> STBasicBlock c s -> CUInt -> m c s (STValue c s)
buildSwitch (STV val) (STB defaultBlock) count = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildSwitch b val defaultBlock count
addCase :: (Monad (m c s), MonadCG m) =>
STValue c s -> STValue c s -> STBasicBlock c b -> m c s ()
addCase (STV switch) (STV val) (STB block) =
wrap $ W.addCase switch val block
buildCase :: (Functor (m c s), Monad (m c s), MonadCG m) =>
STValue c s -> m c s (STValue c s) -> [(STValue c s, m c s (STValue c s))]
-> m c s (STValue c s)
buildCase value defaultCode alts = do
func <- getFunction
defBlock <- appendBasicBlock "caseDefault" func
switch <- buildSwitch value defBlock (fromIntegral (length alts))
positionAtEnd defBlock
defResult <- defaultCode
defExit <- getInsertBlock
results <- forM alts $ \(val, cg) ->
do inBlock <- appendBasicBlock "caseAlt" func
addCase switch val inBlock
positionAtEnd inBlock
result <- cg
outBlock <- getInsertBlock
return (result, inBlock, outBlock)
end <- appendBasicBlock "caseExit" func
positionAtEnd defBlock
isUnreachable defResult >>= flip unless (void $ buildBr end)
forM_ results $ \(result, _, outBlock) ->
do unreachable <- isUnreachable result
unless unreachable $ void $ positionAtEnd outBlock >> buildBr end
positionAtEnd end
case results of
[] -> return defResult
(result, _, _):_ ->
do ty <- typeOf result
phi <- buildPhi "caseResult" ty
inputs <- filterM (\(r, _, _) -> fmap not $ isUnreachable r)
((defResult, defBlock, defExit):results)
addIncoming phi (map (\(outVal, _, outBlock) ->
(outVal, outBlock))
inputs)
return phi
buildIf :: (Monad (m c s), MonadCG m) =>
STType c s -> STValue c s -> m c s (STValue c s) -> m c s (STValue c s)
-> m c s (STValue c s)
buildIf ty cond whenTrue whenFalse = do
func <- getFunction
initialBlock <- getInsertBlock
trueBlock <- appendBasicBlock "ifTrue" func
positionAtEnd trueBlock
trueResult <- whenTrue
trueExit <- getInsertBlock
falseBlock <- appendBasicBlock "ifFalse" func
positionAtEnd falseBlock
falseResult <- whenFalse
falseExit <- getInsertBlock
positionAtEnd initialBlock
buildCondBr cond trueBlock falseBlock
exitBlock <- appendBasicBlock "ifExit" func
positionAtEnd trueExit
buildBr exitBlock
positionAtEnd falseExit
buildBr exitBlock
positionAtEnd exitBlock
phi <- buildPhi "ifResult" ty
addIncoming phi [ (trueResult, trueExit)
, (falseResult, falseExit)]
return phi
buildPhi :: (Monad (m c s), MonadCG m) => String -> STType c s -> m c s (STValue c s)
buildPhi name (STT ty) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildPhi b ty name
addIncoming :: (Monad (m c s), MonadCG m) =>
STValue c s -> [(STValue c s, STBasicBlock c s)] -> m c s ()
addIncoming (STV phi) incoming =
wrap $ W.addIncoming phi (map (\(a, b) -> (unSTV a, unSTB b)) incoming)
buildUnreachable :: (Monad (m c s), MonadCG m) => m c s (STValue c s)
buildUnreachable = do b <- liftCG $ CG ask; wrap . fmap STV $ W.buildUnreachable (cgBuilder b)
wrapCast :: (Monad (m c s), MonadCG m) =>
(Builder -> Value -> Type -> String -> IO Value)
-> String -> STValue c s -> STType c s -> m c s (STValue c s)
wrapCast f n (STV v) (STT t) =
do b <- liftCG $ CG ask; wrap . fmap STV $ f (cgBuilder b) v t n
buildTrunc = wrapCast W.buildTrunc
buildZExt = wrapCast W.buildZExt
buildSExt = wrapCast W.buildSExt
buildFPToUI = wrapCast W.buildFPToUI
buildFPToSI = wrapCast W.buildFPToSI
buildUIToFP = wrapCast W.buildUIToFP
buildSIToFP = wrapCast W.buildSIToFP
buildFPTrunc = wrapCast W.buildFPTrunc
buildFPExt = wrapCast W.buildFPExt
buildPtrToInt = wrapCast W.buildPtrToInt
buildIntToPtr = wrapCast W.buildIntToPtr
buildBitCast = wrapCast W.buildBitCast
buildPointerCast = wrapCast W.buildPointerCast
buildTruncOrBitCast = wrapCast W.buildTruncOrBitCast
buildZExtOrBitCast = wrapCast W.buildZExtOrBitCast
buildSExtOrBitCast = wrapCast W.buildSExtOrBitCast
buildFPCast = wrapCast W.buildFPCast
wrapUn :: (Monad (m c s), MonadCG m) =>
(Builder -> Value -> String -> IO Value)
-> String -> STValue c s -> m c s (STValue c s)
wrapUn f n (STV x) = do b <- liftCG $ CG ask; wrap . fmap STV $ f (cgBuilder b) x n
buildNeg = wrapUn W.buildNeg
buildFNeg = wrapUn W.buildFNeg
buildNot = wrapUn W.buildNot
buildNSWNeg = wrapUn W.buildNSWNeg
buildNUWNeg = wrapUn W.buildNUWNeg
wrapBin :: (Monad (m c s), MonadCG m) =>
(Builder -> Value -> Value -> String -> IO Value)
-> String -> STValue c s -> STValue c s -> m c s (STValue c s)
wrapBin f n (STV l) (STV r) = do b <- liftCG $ CG ask; wrap . fmap STV $ f (cgBuilder b) l r n
buildAdd = wrapBin W.buildAdd
buildSub = wrapBin W.buildSub
buildMul = wrapBin W.buildMul
buildNSWAdd = wrapBin W.buildNSWAdd
buildNSWSub = wrapBin W.buildNSWSub
buildNSWMul = wrapBin W.buildNSWMul
buildNUWAdd = wrapBin W.buildNUWAdd
buildNUWSub = wrapBin W.buildNUWSub
buildNUWMul = wrapBin W.buildNUWMul
buildUDiv = wrapBin W.buildUDiv
buildSDiv = wrapBin W.buildSDiv
buildExactSDiv = wrapBin W.buildExactSDiv
buildURem = wrapBin W.buildURem
buildSRem = wrapBin W.buildSRem
buildFAdd = wrapBin W.buildFAdd
buildFSub = wrapBin W.buildFSub
buildFMul = wrapBin W.buildFMul
buildFDiv = wrapBin W.buildFDiv
buildFRem = wrapBin W.buildFRem
buildShl = wrapBin W.buildShl
buildLShr = wrapBin W.buildLShr
buildAShr = wrapBin W.buildAShr
buildAnd = wrapBin W.buildAnd
buildOr = wrapBin W.buildOr
buildXor = wrapBin W.buildXor
buildICmp :: (Monad (m c s), MonadCG m) =>
String -> IntPredicate -> STValue c s -> STValue c s -> m c s (STValue c s)
buildICmp name f (STV l) (STV r) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildICmp b f l r name
buildFCmp :: (Monad (m c s), MonadCG m) =>
String -> FPPredicate -> STValue c s -> STValue c s -> m c s (STValue c s)
buildFCmp name f (STV l) (STV r) = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildFCmp b f l r name
wrapConstBin :: (Monad (m c s), MonadLLVM m) =>
(Value -> Value -> Value)
-> STValue c s -> STValue c s -> m c s (STValue c s)
wrapConstBin f (STV l) (STV r) = return . STV $ f l r
constAdd = wrapConstBin W.constAdd
constSub = wrapConstBin W.constSub
constMul = wrapConstBin W.constMul
constUDiv = wrapConstBin W.constUDiv
constSDiv = wrapConstBin W.constSDiv
constURem = wrapConstBin W.constURem
constSRem = wrapConstBin W.constSRem
constFAdd = wrapConstBin W.constFAdd
constFSub = wrapConstBin W.constFSub
constFMul = wrapConstBin W.constFMul
constFDiv = wrapConstBin W.constFDiv
constFRem = wrapConstBin W.constFRem
constShl = wrapConstBin W.constShl
constLShr = wrapConstBin W.constLShr
constAShr = wrapConstBin W.constAShr
constAnd = wrapConstBin W.constAnd
constOr = wrapConstBin W.constOr
constXor = wrapConstBin W.constXor
buildGlobalString :: (Monad (m c s), MonadCG m) => String -> String -> m c s (STValue c s)
buildGlobalString name value = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildGlobalString b value name
buildGlobalStringPtr :: (Monad (m c s), MonadCG m) => String -> String -> m c s (STValue c s)
buildGlobalStringPtr name value = do
b <- liftCG $ fmap cgBuilder (CG ask)
wrap . fmap STV $ W.buildGlobalStringPtr b value name
wrapConstCast :: (Monad (m c s), MonadLLVM m) =>
(Value -> Type -> Value)
-> STValue c s -> STType c s -> m c s (STValue c s)
wrapConstCast f (STV v) (STT t) = liftLL $ return . STV $ f v t
constTrunc = wrapConstCast W.constTrunc
constZExt = wrapConstCast W.constZExt
constSExt = wrapConstCast W.constSExt
constFPToUI = wrapConstCast W.constFPToUI
constFPToSI = wrapConstCast W.constFPToSI
constUIToFP = wrapConstCast W.constUIToFP
constSIToFP = wrapConstCast W.constSIToFP
constFPTrunc = wrapConstCast W.constFPTrunc
constFPExt = wrapConstCast W.constFPExt
constPtrToInt = wrapConstCast W.constPtrToInt
constIntToPtr = wrapConstCast W.constIntToPtr
constBitCast = wrapConstCast W.constBitCast
constFPCast = wrapConstCast W.constFPCast