{-|
Module      : Foreign.Storable.Generic.Plugin
Copyright   : (c) Mateusz Kłoczko, 2016
License     : MIT
Maintainer  : mateusz.p.kloczko@gmail.com
Stability   : experimental
Portability : GHC-only

GHC Core plugin for optimising GStorable instances. 
For more information please refer to generic-storable package.

How to enable:

    * use @-fplugin Foreign.Storable.Generic.Plugin@ option
    * add @\{\-\# OPTIONS_GHC -fplugin Foreign.Storable.Generic.Plugin \#\-\}@ to the compiled module.

-}
{-# LANGUAGE CPP #-}
module Foreign.Storable.Generic.Plugin (plugin) where


#if   MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)
import GHC.Plugins
#else
import GhcPlugins
#endif

import Data.Maybe

import Foreign.Storable.Generic.Plugin.Internal
import Data.IORef
import Data.List
import Control.Monad (when)

import Foreign.Storable.Generic.Plugin.Internal.Error

-- | The plugin itself.
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin {
    installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install
#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
  , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = \[CommandLineOption]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PluginRecompile
NoForceRecompile
#endif
  }

defFlags :: Flags
defFlags = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
Some CrashOnWarning
False

orderingPass :: Flags -> IORef [[Type]] -> CoreToDo
orderingPass :: Flags -> IORef [[Type]] -> CoreToDo
orderingPass Flags
flags IORef [[Type]]
io_ref = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
"GStorable - type ordering" 
                                (Flags -> IORef [[Type]] -> CorePluginPass
groupTypes Flags
flags IORef [[Type]]
io_ref)

substitutionPass :: Flags -> IORef [[Type]] -> CoreToDo
substitutionPass :: Flags -> IORef [[Type]] -> CoreToDo
substitutionPass Flags
flags IORef [[Type]]
io_ref = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
"GStorable - substitution" 
                                (Flags -> IORef [[Type]] -> CorePluginPass
gstorableSubstitution Flags
flags IORef [[Type]]
io_ref)

-- | Checks whether the core pass is a simplifier phase 0.
isPhase0 :: CoreToDo 
         -> Bool
isPhase0 :: CoreToDo -> CrashOnWarning
isPhase0 (CoreDoSimplify PhaseNum
iters SimplMode
simpl_mode) = case SimplMode -> CompilerPhase
sm_phase forall a b. (a -> b) -> a -> b
$ SimplMode
simpl_mode of
    Phase PhaseNum
0 -> CrashOnWarning
True
    CompilerPhase
_       -> CrashOnWarning
False 
isPhase0 CoreToDo
_ = CrashOnWarning
False

-- | Return the index of simplifier phase 0. 
afterPhase0 :: [CoreToDo] -> Maybe Int
afterPhase0 :: [CoreToDo] -> Maybe PhaseNum
afterPhase0 [CoreToDo]
todos = forall a. (a -> CrashOnWarning) -> [a] -> Maybe PhaseNum
findIndex CoreToDo -> CrashOnWarning
isPhase0 [CoreToDo]
todos 

-- | Checks whether the core pass is a specialising pass.
isSpecialize :: CoreToDo -> Bool
isSpecialize :: CoreToDo -> CrashOnWarning
isSpecialize CoreToDo
CoreDoSpecialising = CrashOnWarning
True
isSpecialize CoreToDo
_                  = CrashOnWarning
False

-- | Return the index of the specialising pass. 
afterSpecialize :: [CoreToDo] -> Maybe Int
afterSpecialize :: [CoreToDo] -> Maybe PhaseNum
afterSpecialize [CoreToDo]
todos = forall a. (a -> CrashOnWarning) -> [a] -> Maybe PhaseNum
findIndex CoreToDo -> CrashOnWarning
isSpecialize [CoreToDo]
todos 

-- | Set the verbosity and ToCrash flags based on supplied arguments.
setOpts :: Flags -> String -> Flags
setOpts :: Flags -> CommandLineOption -> Flags
setOpts (Flags Verbosity
_    CrashOnWarning
crash) CommandLineOption
"-v0"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
None CrashOnWarning
crash
setOpts (Flags Verbosity
_    CrashOnWarning
crash) CommandLineOption
"-v1"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
Some CrashOnWarning
crash
setOpts (Flags Verbosity
_    CrashOnWarning
crash) CommandLineOption
"-v2"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
All  CrashOnWarning
crash
setOpts (Flags Verbosity
verb CrashOnWarning
_    ) CommandLineOption
"-crash" = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
verb CrashOnWarning
True
setOpts Flags
flags              CommandLineOption
opt      = Flags
flags

-- | Parse command line options.
parseOpts :: [CommandLineOption] -> Flags
parseOpts :: [CommandLineOption] -> Flags
parseOpts [CommandLineOption]
opts = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Flags -> CommandLineOption -> Flags
setOpts Flags
defFlags [CommandLineOption]
opts


putPasses :: Flags -> [CoreToDo] -> Int -> Int -> CoreM [CoreToDo] 
putPasses :: Flags -> [CoreToDo] -> PhaseNum -> PhaseNum -> CoreM [CoreToDo]
putPasses Flags
flags [CoreToDo]
todos PhaseNum
ph0 PhaseNum
sp = do
    IORef [[Type]]
the_ioref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
    let ([CoreToDo]
before_spec,[CoreToDo]
after_spec)   = forall a. PhaseNum -> [a] -> ([a], [a])
splitAt PhaseNum
sp  [CoreToDo]
todos
        ([CoreToDo]
before_ph0 ,[CoreToDo]
after_ph0)    = forall a. PhaseNum -> [a] -> ([a], [a])
splitAt (PhaseNum
ph0forall a. Num a => a -> a -> a
-PhaseNum
sp) [CoreToDo]
after_spec
        ordering :: CoreToDo
ordering   = Flags -> IORef [[Type]] -> CoreToDo
orderingPass     Flags
flags IORef [[Type]]
the_ioref
        substitute :: CoreToDo
substitute = Flags -> IORef [[Type]] -> CoreToDo
substitutionPass Flags
flags IORef [[Type]]
the_ioref
        new_todos :: [CoreToDo]
new_todos = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreToDo]
before_spec, [CoreToDo
ordering], [CoreToDo]
before_ph0, [CoreToDo
substitute] , [CoreToDo]
after_ph0]
    forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
new_todos

-- | Inform about installation errors.
install_err :: Flags -> CoreM ()
install_err :: Flags -> CoreM ()
install_err Flags
flags = do
    let (Flags Verbosity
verb CrashOnWarning
to_crash) = Flags
flags
        printer :: CoreM ()
printer = case Verbosity
verb of
            Verbosity
None  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Verbosity
other -> SDoc -> CoreM ()
putMsg forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
text CommandLineOption
"The GStorable plugin requires simplifier phases with inlining and rules on, as well as a specialiser phase."
                          SDoc -> SDoc -> SDoc
$$ CommandLineOption -> SDoc
text CommandLineOption
"Try to compile the code with -O1 or -O2 optimisation flags." 
    CoreM ()
printer
    forall (f :: * -> *).
Applicative f =>
CrashOnWarning -> f () -> f ()
when CrashOnWarning
to_crash forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"Crashing...")
    


install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [CommandLineOption]
opts [CoreToDo]
todos = do
    DynFlags
dyn_flags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if MIN_VERSION_GLASGOW_HASKELL(9,4,0,0)
    let opt_level = llvmOptLevel dyn_flags
#else
    let opt_level :: PhaseNum
opt_level = DynFlags -> PhaseNum
optLevel DynFlags
dyn_flags
#endif
        flags :: Flags
flags     = [CommandLineOption] -> Flags
parseOpts [CommandLineOption]
opts
        m_phase0 :: Maybe PhaseNum
m_phase0  = [CoreToDo] -> Maybe PhaseNum
afterPhase0     [CoreToDo]
todos
        m_spec :: Maybe PhaseNum
m_spec    = [CoreToDo] -> Maybe PhaseNum
afterSpecialize [CoreToDo]
todos

    case (Maybe PhaseNum
m_phase0, Maybe PhaseNum
m_spec, PhaseNum
opt_level) of
        (Maybe PhaseNum
_       ,Maybe PhaseNum
_       ,PhaseNum
0) -> Flags -> CoreM ()
install_err Flags
flags forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
todos
        (Just PhaseNum
ph0, Just PhaseNum
sp,PhaseNum
_) -> Flags -> [CoreToDo] -> PhaseNum -> PhaseNum -> CoreM [CoreToDo]
putPasses   Flags
flags [CoreToDo]
todos (PhaseNum
ph0forall a. Num a => a -> a -> a
+PhaseNum
1) (PhaseNum
spforall a. Num a => a -> a -> a
+PhaseNum
1)
        (Maybe PhaseNum
_       ,Maybe PhaseNum
_       ,PhaseNum
_) -> Flags -> CoreM ()
install_err Flags
flags forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
todos