module LLVM.General.Internal.PassManager where
import qualified Language.Haskell.TH as TH
import Control.Exception
import Control.Monad hiding (forM_)
import Control.Monad.IO.Class
import Control.Applicative
import Control.Monad.AnyCont
import Data.Word
import Data.Foldable (forM_)
import Foreign.C (CString)
import Foreign.Ptr
import qualified LLVM.General.Internal.FFI.PassManager as FFI
import qualified LLVM.General.Internal.FFI.Transforms as FFI
import qualified LLVM.General.Internal.FFI.Target as FFI
import LLVM.General.Internal.Module
import LLVM.General.Internal.Target
import LLVM.General.Internal.Coding
import LLVM.General.Internal.DataLayout
import LLVM.General.Transforms
import LLVM.General.AST.DataLayout
newtype PassManager = PassManager (Ptr FFI.PassManager)
data PassSetSpec
= PassSetSpec {
transforms :: [Pass],
dataLayout :: Maybe DataLayout,
targetLibraryInfo :: Maybe TargetLibraryInfo,
targetMachine :: Maybe TargetMachine
}
| CuratedPassSetSpec {
optLevel :: Maybe Word,
sizeLevel :: Maybe Word,
unitAtATime :: Maybe Bool,
simplifyLibCalls :: Maybe Bool,
loopVectorize :: Maybe Bool,
superwordLevelParallelismVectorize :: Maybe Bool,
useInlinerWithThreshold :: Maybe Word,
dataLayout :: Maybe DataLayout,
targetLibraryInfo :: Maybe TargetLibraryInfo,
targetMachine :: Maybe TargetMachine
}
defaultCuratedPassSetSpec = CuratedPassSetSpec {
optLevel = Nothing,
sizeLevel = Nothing,
unitAtATime = Nothing,
simplifyLibCalls = Nothing,
loopVectorize = Nothing,
superwordLevelParallelismVectorize = Nothing,
useInlinerWithThreshold = Nothing,
dataLayout = Nothing,
targetLibraryInfo = Nothing,
targetMachine = Nothing
}
defaultPassSetSpec = PassSetSpec {
transforms = [],
dataLayout = Nothing,
targetLibraryInfo = Nothing,
targetMachine = Nothing
}
instance (Monad m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where
encodeM (GCOVVersion cs@[_,_,_,_]) = encodeM cs
createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager)
createPassManager pss = flip runAnyContT return $ do
pm <- liftIO $ FFI.createPassManager
forM_ (dataLayout pss) $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm
forM_ (targetLibraryInfo pss) $ \(TargetLibraryInfo tli) -> do
liftIO $ FFI.addTargetLibraryInfoPass pm tli
forM_ (targetMachine pss) $ \(TargetMachine tm) -> liftIO $ FFI.addAnalysisPasses tm pm
case pss of
s@CuratedPassSetSpec {} -> liftIO $ do
bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do
let handleOption g m = forM_ (m s) (g b <=< encodeM)
handleOption FFI.passManagerBuilderSetOptLevel optLevel
handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel
handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime)
handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls)
handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold
handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize
handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize
FFI.passManagerBuilderPopulateModulePassManager b pm
PassSetSpec ps dl tli tm' -> do
tl <- liftIO $ maybe (return nullPtr) (\(TargetMachine tm) -> FFI.getTargetLowering tm) tm'
forM_ ps $ \p -> $(
do
TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass
TH.caseE [| p |] $ flip map cons $ \con -> do
let
(n, fns) = case con of
TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ])
TH.NormalC n [] -> (n, [])
actions =
[ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ]
++ [
TH.noBindS [|
liftIO $(
foldl1 TH.appE
(map TH.dyn $
["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"]
++ ["tl" | FFI.needsTargetLowering (TH.nameBase n)]
++ fns)
)
|]
]
TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) []
)
return pm
withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a
withPassManager s = bracket (createPassManager s) FFI.disposePassManager . (. PassManager)
runPassManager :: PassManager -> Module -> IO Bool
runPassManager (PassManager p) (Module m) = toEnum . fromIntegral <$> FFI.runPassManager p m