module LLVM.Core.Util(
Module(..), withModule, createModule, destroyModule, writeBitcodeToFile,
ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule,
PassManager(..), withPassManager, createPassManager, createFunctionPassManager,
runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager,
Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,
BasicBlock,
appendBasicBlock,
Function,
addFunction, getParam,
addGlobal,
constString, constStringNul, constVector, constArray,
makeCall, makeInvoke,
CString, withArrayLen,
withEmptyCString,
functionType, buildEmptyPhi, addPhiIns,
addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,
addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,
addTargetData
) where
import Control.Monad(liftM, when)
import Foreign.C.String (withCString, withCStringLen, CString)
import Foreign.ForeignPtr (ForeignPtr, FinalizerPtr, newForeignPtr, withForeignPtr)
import Foreign.Marshal.Array (withArrayLen, withArray)
import Foreign.Marshal.Utils (fromBool)
import System.IO.Unsafe (unsafePerformIO)
import qualified LLVM.FFI.Core as FFI
import qualified LLVM.FFI.Target as FFI
import qualified LLVM.FFI.BitWriter as FFI
import qualified LLVM.FFI.Transforms.Scalar as FFI
type Type = FFI.TypeRef
functionType :: Bool -> Type -> [Type] -> Type
functionType varargs retType paramTypes = unsafePerformIO $
withArrayLen paramTypes $ \ len ptr ->
return $ FFI.functionType retType ptr (fromIntegral len)
(fromBool varargs)
newtype Module = Module {
fromModule :: FFI.ModuleRef
}
withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a
withModule modul f = f (fromModule modul)
createModule :: String -> IO Module
createModule name =
withCString name $ \ namePtr -> do
liftM Module $ FFI.moduleCreateWithName namePtr
destroyModule :: Module -> IO ()
destroyModule = FFI.disposeModule . fromModule
writeBitcodeToFile :: String -> Module -> IO ()
writeBitcodeToFile name mdl =
withCString name $ \ namePtr ->
withModule mdl $ \ mdlPtr -> do
rc <- FFI.writeBitcodeToFile mdlPtr namePtr
when (rc /= 0) $
ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc
return ()
newtype ModuleProvider = ModuleProvider {
fromModuleProvider :: ForeignPtr FFI.ModuleProvider
}
withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a)
-> IO a
withModuleProvider = withForeignPtr . fromModuleProvider
createModuleProviderForExistingModule :: Module -> IO ModuleProvider
createModuleProviderForExistingModule modul =
withModule modul $ \modulPtr -> do
ptr <- FFI.createModuleProviderForExistingModule modulPtr
final <- h2c_moduleProvider FFI.disposeModuleProvider
liftM ModuleProvider $ newForeignPtr final ptr
foreign import ccall "wrapper" h2c_moduleProvider
:: (FFI.ModuleProviderRef -> IO ()) -> IO (FinalizerPtr a)
newtype Builder = Builder {
fromBuilder :: ForeignPtr FFI.Builder
}
withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a
withBuilder = withForeignPtr . fromBuilder
createBuilder :: IO Builder
createBuilder = do
final <- h2c_builder FFI.disposeBuilder
ptr <- FFI.createBuilder
liftM Builder $ newForeignPtr final ptr
foreign import ccall "wrapper" h2c_builder
:: (FFI.BuilderRef -> IO ()) -> IO (FinalizerPtr a)
positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()
positionAtEnd bld bblk =
withBuilder bld $ \ bldPtr ->
FFI.positionAtEnd bldPtr bblk
getInsertBlock :: Builder -> IO FFI.BasicBlockRef
getInsertBlock bld =
withBuilder bld $ \ bldPtr ->
FFI.getInsertBlock bldPtr
type BasicBlock = FFI.BasicBlockRef
appendBasicBlock :: Function -> String -> IO BasicBlock
appendBasicBlock func name =
withCString name $ \ namePtr ->
FFI.appendBasicBlock func namePtr
type Function = FFI.ValueRef
addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function
addFunction modul linkage name typ =
withModule modul $ \ modulPtr ->
withCString name $ \ namePtr -> do
f <- FFI.addFunction modulPtr namePtr typ
FFI.setLinkage f linkage
return f
getParam :: Function -> Int -> Value
getParam f = FFI.getParam f . fromIntegral
addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value
addGlobal modul linkage name typ =
withModule modul $ \ modulPtr ->
withCString name $ \ namePtr -> do
v <- FFI.addGlobal modulPtr typ namePtr
FFI.setLinkage v linkage
return v
constStringInternal :: Bool -> String -> Value
constStringInternal nulTerm s = unsafePerformIO $
withCStringLen s $ \(sPtr, sLen) ->
return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm))
constString :: String -> Value
constString = constStringInternal False
constStringNul :: String -> Value
constStringNul = constStringInternal True
type Value = FFI.ValueRef
makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value
makeCall func bldPtr args = do
withArrayLen args $ \ argLen argPtr ->
withEmptyCString $
FFI.buildCall bldPtr func argPtr
(fromIntegral argLen)
makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->
[Value] -> IO Value
makeInvoke norm expt func bldPtr args =
withArrayLen args $ \ argLen argPtr ->
withEmptyCString $
FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt
buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value
buildEmptyPhi bldPtr typ = do
withEmptyCString $ FFI.buildPhi bldPtr typ
withEmptyCString :: (CString -> IO a) -> IO a
withEmptyCString = withCString ""
addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()
addPhiIns inst incoming = do
let (vals, bblks) = unzip incoming
withArrayLen vals $ \ count valPtr ->
withArray bblks $ \ bblkPtr ->
FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)
newtype PassManager = PassManager {
fromPassManager :: ForeignPtr FFI.PassManager
}
withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)
-> IO a
withPassManager = withForeignPtr . fromPassManager
createPassManager :: IO PassManager
createPassManager = do
ptr <- FFI.createPassManager
final <- h2c_passManager FFI.disposePassManager
liftM PassManager $ newForeignPtr final ptr
createFunctionPassManager :: ModuleProvider -> IO PassManager
createFunctionPassManager modul =
withModuleProvider modul $ \modulPtr -> do
ptr <- FFI.createFunctionPassManager modulPtr
final <- h2c_passManager FFI.disposePassManager
liftM PassManager $ newForeignPtr final ptr
foreign import ccall "wrapper" h2c_passManager
:: (FFI.PassManagerRef -> IO ()) -> IO (FinalizerPtr a)
addCFGSimplificationPass :: PassManager -> IO ()
addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass
addConstantPropagationPass :: PassManager -> IO ()
addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass
addDemoteMemoryToRegisterPass :: PassManager -> IO ()
addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass
addGVNPass :: PassManager -> IO ()
addGVNPass pm = withPassManager pm FFI.addGVNPass
addInstructionCombiningPass :: PassManager -> IO ()
addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass
addPromoteMemoryToRegisterPass :: PassManager -> IO ()
addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass
addReassociatePass :: PassManager -> IO ()
addReassociatePass pm = withPassManager pm FFI.addReassociatePass
addTargetData :: FFI.TargetDataRef -> PassManager -> IO ()
addTargetData td pm = withPassManager pm $ FFI.addTargetData td
runFunctionPassManager :: PassManager -> Function -> IO Int
runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn
initializeFunctionPassManager :: PassManager -> IO Int
initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager
finalizeFunctionPassManager :: PassManager -> IO Int
finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager
constVector :: Int -> [Value] -> Value
constVector n xs = unsafePerformIO $ do
let xs' = take n (cycle xs)
withArrayLen xs' $ \ len ptr ->
return $ FFI.constVector ptr (fromIntegral len)
constArray :: Type -> Int -> [Value] -> Value
constArray t n xs = unsafePerformIO $ do
let xs' = take n (cycle xs)
withArrayLen xs' $ \ len ptr ->
return $ FFI.constArray t ptr (fromIntegral len)