{-# LANGUAGE
TemplateHaskell,
MultiParamTypeClasses,
CPP
#-}
module LLVM.Internal.PassManager where
import LLVM.Prelude
import qualified Language.Haskell.TH as TH
import Control.Monad.AnyCont
import Control.Monad.Catch
import Control.Monad.IO.Class
import qualified Data.ByteString.Short as ByteString
import Foreign.C (CString)
import Foreign.Ptr
import qualified LLVM.Internal.FFI.PassManager as FFI
import qualified LLVM.Internal.FFI.Transforms as FFI
import LLVM.Exception
import LLVM.Internal.Module
import LLVM.Internal.Target
import LLVM.Internal.Coding
import LLVM.Transforms
import LLVM.AST.DataLayout
newtype PassManager = PassManager (Ptr FFI.PassManager)
data PassSetSpec
= PassSetSpec {
PassSetSpec -> [Pass]
transforms :: [Pass],
PassSetSpec -> Maybe DataLayout
dataLayout :: Maybe DataLayout,
PassSetSpec -> Maybe TargetLibraryInfo
targetLibraryInfo :: Maybe TargetLibraryInfo,
PassSetSpec -> Maybe TargetMachine
targetMachine :: Maybe TargetMachine
}
| CuratedPassSetSpec {
PassSetSpec -> Maybe Word
optLevel :: Maybe Word,
PassSetSpec -> Maybe Word
sizeLevel :: Maybe Word,
PassSetSpec -> Maybe Bool
unitAtATime :: Maybe Bool,
PassSetSpec -> Maybe Bool
simplifyLibCalls :: Maybe Bool,
PassSetSpec -> Maybe Bool
loopVectorize :: Maybe Bool,
PassSetSpec -> Maybe Bool
superwordLevelParallelismVectorize :: Maybe Bool,
PassSetSpec -> Maybe Word
useInlinerWithThreshold :: Maybe Word,
dataLayout :: Maybe DataLayout,
targetLibraryInfo :: Maybe TargetLibraryInfo,
targetMachine :: Maybe TargetMachine
}
defaultCuratedPassSetSpec :: PassSetSpec
defaultCuratedPassSetSpec :: PassSetSpec
defaultCuratedPassSetSpec = CuratedPassSetSpec :: Maybe Word
-> Maybe Word
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Word
-> Maybe DataLayout
-> Maybe TargetLibraryInfo
-> Maybe TargetMachine
-> PassSetSpec
CuratedPassSetSpec {
optLevel :: Maybe Word
optLevel = Maybe Word
forall a. Maybe a
Nothing,
sizeLevel :: Maybe Word
sizeLevel = Maybe Word
forall a. Maybe a
Nothing,
unitAtATime :: Maybe Bool
unitAtATime = Maybe Bool
forall a. Maybe a
Nothing,
simplifyLibCalls :: Maybe Bool
simplifyLibCalls = Maybe Bool
forall a. Maybe a
Nothing,
loopVectorize :: Maybe Bool
loopVectorize = Maybe Bool
forall a. Maybe a
Nothing,
superwordLevelParallelismVectorize :: Maybe Bool
superwordLevelParallelismVectorize = Maybe Bool
forall a. Maybe a
Nothing,
useInlinerWithThreshold :: Maybe Word
useInlinerWithThreshold = Maybe Word
forall a. Maybe a
Nothing,
dataLayout :: Maybe DataLayout
dataLayout = Maybe DataLayout
forall a. Maybe a
Nothing,
targetLibraryInfo :: Maybe TargetLibraryInfo
targetLibraryInfo = Maybe TargetLibraryInfo
forall a. Maybe a
Nothing,
targetMachine :: Maybe TargetMachine
targetMachine = Maybe TargetMachine
forall a. Maybe a
Nothing
}
defaultPassSetSpec :: PassSetSpec
defaultPassSetSpec :: PassSetSpec
defaultPassSetSpec = PassSetSpec :: [Pass]
-> Maybe DataLayout
-> Maybe TargetLibraryInfo
-> Maybe TargetMachine
-> PassSetSpec
PassSetSpec {
transforms :: [Pass]
transforms = [],
dataLayout :: Maybe DataLayout
dataLayout = Maybe DataLayout
forall a. Maybe a
Nothing,
targetLibraryInfo :: Maybe TargetLibraryInfo
targetLibraryInfo = Maybe TargetLibraryInfo
forall a. Maybe a
Nothing,
targetMachine :: Maybe TargetMachine
targetMachine = Maybe TargetMachine
forall a. Maybe a
Nothing
}
instance (Monad m, MonadThrow m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where
encodeM :: GCOVVersion -> m CString
encodeM (GCOVVersion cs :: ShortByteString
cs)
| ShortByteString -> Int
ByteString.length ShortByteString
cs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4 = ShortByteString -> m CString
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM ShortByteString
cs
| Bool
otherwise = EncodeException -> m CString
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> EncodeException
EncodeException "GCOVVersion should consist of exactly 4 characters")
createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager)
createPassManager :: PassSetSpec -> IO (Ptr PassManager)
createPassManager pss :: PassSetSpec
pss = (AnyContT IO (Ptr PassManager)
-> (Ptr PassManager -> IO (Ptr PassManager))
-> IO (Ptr PassManager))
-> (Ptr PassManager -> IO (Ptr PassManager))
-> AnyContT IO (Ptr PassManager)
-> IO (Ptr PassManager)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AnyContT IO (Ptr PassManager)
-> (Ptr PassManager -> IO (Ptr PassManager))
-> IO (Ptr PassManager)
forall (m :: * -> *) a. AnyContT m a -> forall r. (a -> m r) -> m r
runAnyContT Ptr PassManager -> IO (Ptr PassManager)
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyContT IO (Ptr PassManager) -> IO (Ptr PassManager))
-> AnyContT IO (Ptr PassManager) -> IO (Ptr PassManager)
forall a b. (a -> b) -> a -> b
$ do
Ptr PassManager
pm <- IO (Ptr PassManager) -> AnyContT IO (Ptr PassManager)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ptr PassManager) -> AnyContT IO (Ptr PassManager))
-> IO (Ptr PassManager) -> AnyContT IO (Ptr PassManager)
forall a b. (a -> b) -> a -> b
$ IO (Ptr PassManager)
FFI.createPassManager
Maybe TargetLibraryInfo
-> (TargetLibraryInfo -> AnyContT IO ()) -> AnyContT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (PassSetSpec -> Maybe TargetLibraryInfo
targetLibraryInfo PassSetSpec
pss) ((TargetLibraryInfo -> AnyContT IO ()) -> AnyContT IO ())
-> (TargetLibraryInfo -> AnyContT IO ()) -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ \(TargetLibraryInfo tli :: Ptr TargetLibraryInfo
tli) -> do
IO () -> AnyContT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AnyContT IO ()) -> IO () -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ Ptr PassManager -> Ptr TargetLibraryInfo -> IO ()
FFI.addTargetLibraryInfoPass Ptr PassManager
pm Ptr TargetLibraryInfo
tli
Maybe TargetMachine
-> (TargetMachine -> AnyContT IO ()) -> AnyContT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (PassSetSpec -> Maybe TargetMachine
targetMachine PassSetSpec
pss) ((TargetMachine -> AnyContT IO ()) -> AnyContT IO ())
-> (TargetMachine -> AnyContT IO ()) -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ \(TargetMachine tm :: Ptr TargetMachine
tm) -> IO () -> AnyContT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AnyContT IO ()) -> IO () -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ Ptr TargetMachine -> Ptr PassManager -> IO ()
FFI.addAnalysisPasses Ptr TargetMachine
tm Ptr PassManager
pm
case PassSetSpec
pss of
s :: PassSetSpec
s@CuratedPassSetSpec {} -> IO () -> AnyContT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AnyContT IO ()) -> IO () -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ do
IO (Ptr PassManagerBuilder)
-> (Ptr PassManagerBuilder -> IO ())
-> (Ptr PassManagerBuilder -> IO ())
-> IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO (Ptr PassManagerBuilder)
FFI.passManagerBuilderCreate Ptr PassManagerBuilder -> IO ()
FFI.passManagerBuilderDispose ((Ptr PassManagerBuilder -> IO ()) -> IO ())
-> (Ptr PassManagerBuilder -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \b :: Ptr PassManagerBuilder
b -> do
let handleOption :: (Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption g :: Ptr PassManagerBuilder -> b -> m b
g m :: PassSetSpec -> t h
m = t h -> (h -> m b) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (PassSetSpec -> t h
m PassSetSpec
s) (Ptr PassManagerBuilder -> b -> m b
g Ptr PassManagerBuilder
b (b -> m b) -> (h -> m b) -> h -> m b
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< h -> m b
forall (e :: * -> *) h c. EncodeM e h c => h -> e c
encodeM)
(Ptr PassManagerBuilder -> CUInt -> IO ())
-> (PassSetSpec -> Maybe Word) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> CUInt -> IO ()
FFI.passManagerBuilderSetOptLevel PassSetSpec -> Maybe Word
optLevel
(Ptr PassManagerBuilder -> CUInt -> IO ())
-> (PassSetSpec -> Maybe Word) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> CUInt -> IO ()
FFI.passManagerBuilderSetSizeLevel PassSetSpec -> Maybe Word
sizeLevel
(Ptr PassManagerBuilder -> LLVMBool -> IO ())
-> (PassSetSpec -> Maybe Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> LLVMBool -> IO ()
FFI.passManagerBuilderSetDisableUnitAtATime ((Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Maybe Bool -> Maybe Bool)
-> (PassSetSpec -> Maybe Bool) -> PassSetSpec -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassSetSpec -> Maybe Bool
unitAtATime)
(Ptr PassManagerBuilder -> LLVMBool -> IO ())
-> (PassSetSpec -> Maybe Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> LLVMBool -> IO ()
FFI.passManagerBuilderSetDisableSimplifyLibCalls ((Bool -> Bool) -> Maybe Bool -> Maybe Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Maybe Bool -> Maybe Bool)
-> (PassSetSpec -> Maybe Bool) -> PassSetSpec -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PassSetSpec -> Maybe Bool
simplifyLibCalls)
(Ptr PassManagerBuilder -> CUInt -> IO ())
-> (PassSetSpec -> Maybe Word) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> CUInt -> IO ()
FFI.passManagerBuilderUseInlinerWithThreshold PassSetSpec -> Maybe Word
useInlinerWithThreshold
(Ptr PassManagerBuilder -> LLVMBool -> IO ())
-> (PassSetSpec -> Maybe Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> LLVMBool -> IO ()
FFI.passManagerBuilderSetLoopVectorize PassSetSpec -> Maybe Bool
loopVectorize
(Ptr PassManagerBuilder -> LLVMBool -> IO ())
-> (PassSetSpec -> Maybe Bool) -> IO ()
forall (t :: * -> *) (m :: * -> *) h b b.
(Foldable t, Monad m, EncodeM m h b) =>
(Ptr PassManagerBuilder -> b -> m b)
-> (PassSetSpec -> t h) -> m ()
handleOption Ptr PassManagerBuilder -> LLVMBool -> IO ()
FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize PassSetSpec -> Maybe Bool
superwordLevelParallelismVectorize
Ptr PassManagerBuilder -> Ptr PassManager -> IO ()
FFI.passManagerBuilderPopulateModulePassManager Ptr PassManagerBuilder
b Ptr PassManager
pm
PassSetSpec ps :: [Pass]
ps _ _ tm' :: Maybe TargetMachine
tm' -> do
let tm :: Ptr TargetMachine
tm = Ptr TargetMachine
-> (TargetMachine -> Ptr TargetMachine)
-> Maybe TargetMachine
-> Ptr TargetMachine
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ptr TargetMachine
forall a. Ptr a
nullPtr (\(TargetMachine tm :: Ptr TargetMachine
tm) -> Ptr TargetMachine
tm) Maybe TargetMachine
tm'
[Pass] -> (Pass -> AnyContT IO ()) -> AnyContT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Pass]
ps ((Pass -> AnyContT IO ()) -> AnyContT IO ())
-> (Pass -> AnyContT IO ()) -> AnyContT IO ()
forall a b. (a -> b) -> a -> b
$ \p :: Pass
p -> $(
do
#if __GLASGOW_HASKELL__ < 800
TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass
#else
TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''Pass
#endif
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, [])
_ -> error "pass descriptor constructors with fields need to be records"
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)) []
)
Ptr PassManager -> AnyContT IO (Ptr PassManager)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr PassManager
pm
withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a
withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a
withPassManager s :: PassSetSpec
s = IO (Ptr PassManager)
-> (Ptr PassManager -> IO ()) -> (Ptr PassManager -> IO a) -> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (PassSetSpec -> IO (Ptr PassManager)
createPassManager PassSetSpec
s) Ptr PassManager -> IO ()
FFI.disposePassManager ((Ptr PassManager -> IO a) -> IO a)
-> ((PassManager -> IO a) -> Ptr PassManager -> IO a)
-> (PassManager -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PassManager -> IO a)
-> (Ptr PassManager -> PassManager) -> Ptr PassManager -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr PassManager -> PassManager
PassManager)
runPassManager :: PassManager -> Module -> IO Bool
runPassManager :: PassManager -> Module -> IO Bool
runPassManager (PassManager p :: Ptr PassManager
p) m :: Module
m = do
Ptr Module
m' <- Module -> IO (Ptr Module)
forall (m :: * -> *). MonadIO m => Module -> m (Ptr Module)
readModule Module
m
Int -> Bool
forall a. Enum a => Int -> a
toEnum (Int -> Bool) -> (CUInt -> Int) -> CUInt -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CUInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUInt -> Bool) -> IO CUInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr PassManager -> Ptr Module -> IO CUInt
FFI.runPassManager Ptr PassManager
p Ptr Module
m'