module LLVM.General.Internal.Target where
import LLVM.General.Prelude
import Control.Monad.Trans.Except (runExcept)
import Control.Monad.Exceptable
import Control.Exception
import Control.Monad.AnyCont
import Foreign.Ptr
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Text.ParserCombinators.Parsec hiding (many)
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 (Map CPUFeature Bool) es where
encodeM = encodeM . intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") ++ f) . Map.toList
instance (Monad d, DecodeM d String es) => DecodeM d (Map CPUFeature Bool) es where
decodeM es = do
s <- decodeM es
let flag = do
en <- choice [char '-' >> return False, char '+' >> return True]
s <- many1 (noneOf ",")
return (CPUFeature s, en)
features = liftM Map.fromList (flag `sepBy` (char ','))
case parse (do f <- features; eof; return f) "CPU Feature string" (s :: String) of
Right features -> return features
Left _ -> fail "failure to parse CPUFeature string"
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.targetOptionFlagUseInitArray, TO.useInitArray),
(FFI.targetOptionFlagDisableIntegratedAS, TO.disableIntegratedAssembler),
(FFI.targetOptionFlagCompressDebugSections, TO.compressDebugSections),
(FFI.targetOptionFlagTrapUnreachable, TO.trapUnreachable)
]
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
useInitArray
<- gof FFI.targetOptionFlagUseInitArray
disableIntegratedAssembler
<- gof FFI.targetOptionFlagDisableIntegratedAS
compressDebugSections
<- gof FFI.targetOptionFlagCompressDebugSections
trapUnreachable
<- gof FFI.targetOptionFlagTrapUnreachable
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
-> Map CPUFeature Bool
-> 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 (Map CPUFeature Bool)
getHostCPUFeatures = decodeM =<< FFI.getHostCPUFeatures
getTargetMachineDataLayout :: TargetMachine -> IO DataLayout
getTargetMachineDataLayout (TargetMachine m) = do
dlString <- decodeM =<< FFI.getTargetMachineDataLayout m
let Right (Just dl) = runExcept . parseDataLayout BigEndian $ dlString
return dl
initializeAllTargets :: IO ()
initializeAllTargets = FFI.initializeAllTargets
withHostTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a
withHostTargetMachine f = do
liftIO $ initializeAllTargets
triple <- liftIO $ getProcessTargetTriple
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)