module LLVM.General.Internal.Target where
import Control.Monad hiding (forM)
import Control.Monad.Exceptable hiding (forM)
import Control.Exception
import Data.Functor
import Data.Traversable (forM)
import Control.Monad.AnyCont
import Foreign.Ptr
import Data.List (intercalate)
import Data.Set (Set)
import qualified Data.Set as Set
import LLVM.General.Internal.Coding
import LLVM.General.Internal.String ()
import LLVM.General.Internal.LibraryFunction
import LLVM.General.DataLayout
import LLVM.General.AST.DataLayout
import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI
import qualified LLVM.General.Internal.FFI.Target as FFI
import qualified LLVM.General.Relocation as Reloc
import qualified LLVM.General.Target.Options as TO
import qualified LLVM.General.CodeModel as CodeModel
import qualified LLVM.General.CodeGenOpt as CodeGenOpt
genCodingInstance [t| Reloc.Model |] ''FFI.RelocModel [
(FFI.relocModelDefault, Reloc.Default),
(FFI.relocModelStatic, Reloc.Static),
(FFI.relocModelPIC, Reloc.PIC),
(FFI.relocModelDynamicNoPic, Reloc.DynamicNoPIC)
]
genCodingInstance [t| CodeModel.Model |] ''FFI.CodeModel [
(FFI.codeModelDefault,CodeModel.Default),
(FFI.codeModelJITDefault, CodeModel.JITDefault),
(FFI.codeModelSmall, CodeModel.Small),
(FFI.codeModelKernel, CodeModel.Kernel),
(FFI.codeModelMedium, CodeModel.Medium),
(FFI.codeModelLarge, CodeModel.Large)
]
genCodingInstance [t| CodeGenOpt.Level |] ''FFI.CodeGenOptLevel [
(FFI.codeGenOptLevelNone, CodeGenOpt.None),
(FFI.codeGenOptLevelLess, CodeGenOpt.Less),
(FFI.codeGenOptLevelDefault, CodeGenOpt.Default),
(FFI.codeGenOptLevelAggressive, CodeGenOpt.Aggressive)
]
genCodingInstance [t| TO.FloatABI |] ''FFI.FloatABIType [
(FFI.floatABIDefault, TO.FloatABIDefault),
(FFI.floatABISoft, TO.FloatABISoft),
(FFI.floatABIHard, TO.FloatABIHard)
]
genCodingInstance [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMode [
(FFI.fpOpFusionModeFast, TO.FloatingPointOperationFusionFast),
(FFI.fpOpFusionModeStandard, TO.FloatingPointOperationFusionStandard),
(FFI.fpOpFusionModeStrict, TO.FloatingPointOperationFusionStrict)
]
newtype Target = Target (Ptr FFI.Target)
newtype CPUFeature = CPUFeature String
deriving (Eq, Ord, Read, Show)
instance EncodeM e String es => EncodeM e (Set CPUFeature) es where
encodeM = encodeM . intercalate " " . map (\(CPUFeature f) -> f) . Set.toList
instance (Monad d, DecodeM d String es) => DecodeM d (Set CPUFeature) es where
decodeM = liftM (Set.fromList . map CPUFeature . words) . decodeM
lookupTarget ::
Maybe String
-> String
-> ExceptT String IO (Target, String)
lookupTarget arch triple = unExceptableT $ flip runAnyContT return $ do
cErrorP <- alloca
cNewTripleP <- alloca
arch <- encodeM (maybe "" id arch)
triple <- encodeM triple
target <- liftIO $ FFI.lookupTarget arch triple cNewTripleP cErrorP
when (target == nullPtr) $ throwError =<< decodeM cErrorP
liftM (Target target, ) $ decodeM cNewTripleP
newtype TargetOptions = TargetOptions (Ptr FFI.TargetOptions)
withTargetOptions :: (TargetOptions -> IO a) -> IO a
withTargetOptions = bracket FFI.createTargetOptions FFI.disposeTargetOptions . (. TargetOptions)
pokeTargetOptions :: TO.Options -> TargetOptions -> IO ()
pokeTargetOptions hOpts (TargetOptions cOpts) = do
mapM_ (\(c, ha) -> FFI.setTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [
(FFI.targetOptionFlagPrintMachineCode, TO.printMachineCode),
(FFI.targetOptionFlagNoFramePointerElim, TO.noFramePointerElimination),
(FFI.targetOptionFlagLessPreciseFPMADOption, TO.lessPreciseFloatingPointMultiplyAddOption),
(FFI.targetOptionFlagUnsafeFPMath, TO.unsafeFloatingPointMath),
(FFI.targetOptionFlagNoInfsFPMath, TO.noInfinitiesFloatingPointMath),
(FFI.targetOptionFlagNoNaNsFPMath, TO.noNaNsFloatingPointMath),
(FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption, TO.honorSignDependentRoundingFloatingPointMathOption),
(FFI.targetOptionFlagUseSoftFloat, TO.useSoftFloat),
(FFI.targetOptionFlagNoZerosInBSS, TO.noZerosInBSS),
(FFI.targetOptionFlagJITEmitDebugInfo, TO.jITEmitDebugInfo),
(FFI.targetOptionFlagJITEmitDebugInfoToDisk, TO.jITEmitDebugInfoToDisk),
(FFI.targetOptionFlagGuaranteedTailCallOpt, TO.guaranteedTailCallOptimization),
(FFI.targetOptionFlagDisableTailCalls, TO.disableTailCalls),
(FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection),
(FFI.targetOptionFlagPositionIndependentExecutable, TO.positionIndependentExecutable),
(FFI.targetOptionFlagEnableSegmentedStacks, TO.enableSegmentedStacks),
(FFI.targetOptionFlagUseInitArray, TO.useInitArray)
]
FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts)
flip runAnyContT return $ do
n <- encodeM (TO.trapFunctionName hOpts)
liftIO $ FFI.setTrapFuncName cOpts n
FFI.setFloatABIType cOpts =<< encodeM (TO.floatABIType hOpts)
FFI.setAllowFPOpFusion cOpts =<< encodeM (TO.allowFloatingPointOperationFusion hOpts)
peekTargetOptions :: TargetOptions -> IO TO.Options
peekTargetOptions (TargetOptions tOpts) = do
let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts
printMachineCode
<- gof FFI.targetOptionFlagPrintMachineCode
noFramePointerElimination
<- gof FFI.targetOptionFlagNoFramePointerElim
lessPreciseFloatingPointMultiplyAddOption
<- gof FFI.targetOptionFlagLessPreciseFPMADOption
unsafeFloatingPointMath
<- gof FFI.targetOptionFlagUnsafeFPMath
noInfinitiesFloatingPointMath
<- gof FFI.targetOptionFlagNoInfsFPMath
noNaNsFloatingPointMath
<- gof FFI.targetOptionFlagNoNaNsFPMath
honorSignDependentRoundingFloatingPointMathOption
<- gof FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption
useSoftFloat
<- gof FFI.targetOptionFlagUseSoftFloat
noZerosInBSS
<- gof FFI.targetOptionFlagNoZerosInBSS
jITEmitDebugInfo
<- gof FFI.targetOptionFlagJITEmitDebugInfo
jITEmitDebugInfoToDisk
<- gof FFI.targetOptionFlagJITEmitDebugInfoToDisk
guaranteedTailCallOptimization
<- gof FFI.targetOptionFlagGuaranteedTailCallOpt
disableTailCalls
<- gof FFI.targetOptionFlagDisableTailCalls
enableFastInstructionSelection
<- gof FFI.targetOptionFlagEnableFastISel
positionIndependentExecutable
<- gof FFI.targetOptionFlagPositionIndependentExecutable
enableSegmentedStacks
<- gof FFI.targetOptionFlagEnableSegmentedStacks
useInitArray
<- gof FFI.targetOptionFlagUseInitArray
stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts
trapFunctionName <- decodeM =<< FFI.getTrapFuncName tOpts
floatABIType <- decodeM =<< FFI.getFloatABIType tOpts
allowFloatingPointOperationFusion <- decodeM =<< FFI.getAllowFPOpFusion tOpts
return TO.Options { .. }
newtype TargetMachine = TargetMachine (Ptr FFI.TargetMachine)
withTargetMachine ::
Target
-> String
-> String
-> Set CPUFeature
-> TargetOptions
-> Reloc.Model
-> CodeModel.Model
-> CodeGenOpt.Level
-> (TargetMachine -> IO a)
-> IO a
withTargetMachine
(Target target)
triple
cpu
features
(TargetOptions targetOptions)
relocModel
codeModel
codeGenOptLevel = runAnyContT $ do
triple <- encodeM triple
cpu <- encodeM cpu
features <- encodeM features
relocModel <- encodeM relocModel
codeModel <- encodeM codeModel
codeGenOptLevel <- encodeM codeGenOptLevel
anyContToM $ bracket (
FFI.createTargetMachine
target
triple
cpu
features
targetOptions
relocModel
codeModel
codeGenOptLevel
)
FFI.disposeTargetMachine
. (. TargetMachine)
newtype TargetLowering = TargetLowering (Ptr FFI.TargetLowering)
getTargetLowering :: TargetMachine -> IO TargetLowering
getTargetLowering (TargetMachine tm) = TargetLowering <$> FFI.getTargetLowering tm
initializeNativeTarget :: IO ()
initializeNativeTarget = do
failure <- decodeM =<< liftIO FFI.initializeNativeTarget
when failure $ fail "native target initialization failed"
getDefaultTargetTriple :: IO String
getDefaultTargetTriple = decodeM =<< FFI.getDefaultTargetTriple
getProcessTargetTriple :: IO String
getProcessTargetTriple = decodeM =<< FFI.getProcessTargetTriple
getHostCPUName :: IO String
getHostCPUName = decodeM =<< FFI.getHostCPUName
getHostCPUFeatures :: IO (Set CPUFeature)
getHostCPUFeatures = decodeM =<< FFI.getHostCPUFeatures
getTargetMachineDataLayout :: TargetMachine -> IO DataLayout
getTargetMachineDataLayout (TargetMachine m) = do
dl <- decodeM =<< FFI.getTargetMachineDataLayout m
maybe (fail "parseDataLayout failed") return $ parseDataLayout dl
initializeAllTargets :: IO ()
initializeAllTargets = FFI.initializeAllTargets
withDefaultTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a
withDefaultTargetMachine f = do
liftIO $ initializeAllTargets
triple <- liftIO $ getDefaultTargetTriple
cpu <- liftIO $ getHostCPUName
features <- liftIO $ getHostCPUFeatures
(target, _) <- lookupTarget Nothing triple
liftIO $ withTargetOptions $ \options ->
withTargetMachine target triple cpu features options Reloc.Default CodeModel.Default CodeGenOpt.Default f
newtype TargetLibraryInfo = TargetLibraryInfo (Ptr FFI.TargetLibraryInfo)
getLibraryFunction :: TargetLibraryInfo -> String -> IO (Maybe LibraryFunction)
getLibraryFunction (TargetLibraryInfo f) name = flip runAnyContT return $ do
libFuncP <- alloca
name <- encodeM name
r <- decodeM =<< (liftIO $ FFI.getLibFunc f name libFuncP)
forM (if r then Just libFuncP else Nothing) $ decodeM <=< peek
getLibraryFunctionName :: TargetLibraryInfo -> LibraryFunction -> IO String
getLibraryFunctionName (TargetLibraryInfo f) l = flip runAnyContT return $ do
l <- encodeM l
decodeM $ FFI.libFuncGetName f l
setLibraryFunctionAvailableWithName ::
TargetLibraryInfo
-> LibraryFunction
-> String
-> IO ()
setLibraryFunctionAvailableWithName (TargetLibraryInfo f) libraryFunction name = flip runAnyContT return $ do
name <- encodeM name
libraryFunction <- encodeM libraryFunction
liftIO $ FFI.libFuncSetAvailableWithName f libraryFunction name
withTargetLibraryInfo ::
String
-> (TargetLibraryInfo -> IO a)
-> IO a
withTargetLibraryInfo triple f = flip runAnyContT return $ do
triple <- encodeM triple
liftIO $ bracket (FFI.createTargetLibraryInfo triple) FFI.disposeTargetLibraryInfo (f . TargetLibraryInfo)