{-# 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

-- | <http://llvm.org/doxygen/classllvm_1_1PassManager.html>
-- Note: a PassManager does substantive behind-the-scenes work, arranging for the
-- results of various analyses to be available as needed by transform passes, shared
-- as possible.
newtype PassManager = PassManager (Ptr FFI.PassManager)

-- | There are different ways to get a 'PassManager'. This type embodies them.
data PassSetSpec
  -- | a 'PassSetSpec' is a lower-level, detailed specification of a set of passes. It
  -- allows fine-grained control of what passes are to be run when, and the specification
  -- of passes not available through 'CuratedPassSetSpec'.
  = PassSetSpec {
      PassSetSpec -> [Pass]
transforms :: [Pass],
      PassSetSpec -> Maybe DataLayout
dataLayout :: Maybe DataLayout,
      PassSetSpec -> Maybe TargetLibraryInfo
targetLibraryInfo :: Maybe TargetLibraryInfo,
      PassSetSpec -> Maybe TargetMachine
targetMachine :: Maybe TargetMachine
    }
  -- | This type is a high-level specification of a set of passes. It uses the same
  -- collection of passes chosen by the LLVM team in the command line tool 'opt'.  The fields
  -- of this spec are much like typical compiler command-line flags - e.g. -O\<n\>, etc.
  | 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
    }

-- | Helper to make a curated 'PassSetSpec'
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
}

-- | an empty 'PassSetSpec'
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

-- | bracket the creation of a 'PassManager'
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)

-- | run the passes in a 'PassManager' on a 'Module', modifying the 'Module'.
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'