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 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
let tm = maybe nullPtr (\(TargetMachine tm) -> 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"]
++ ["tm" | FFI.needsTargetMachine (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