{-|
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]
_ -> PluginRecompile -> IO PluginRecompile
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 Int
iters SimplMode
simpl_mode) = case SimplMode -> CompilerPhase
sm_phase (SimplMode -> CompilerPhase) -> SimplMode -> CompilerPhase
forall a b. (a -> b) -> a -> b
$ SimplMode
simpl_mode of
    Phase Int
0 -> CrashOnWarning
True
    CompilerPhase
_       -> CrashOnWarning
False 
isPhase0 CoreToDo
_ = CrashOnWarning
False

-- | Return the index of simplifier phase 0. 
afterPhase0 :: [CoreToDo] -> Maybe Int
afterPhase0 :: [CoreToDo] -> Maybe Int
afterPhase0 [CoreToDo]
todos = (CoreToDo -> CrashOnWarning) -> [CoreToDo] -> Maybe Int
forall a. (a -> CrashOnWarning) -> [a] -> Maybe Int
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 Int
afterSpecialize [CoreToDo]
todos = (CoreToDo -> CrashOnWarning) -> [CoreToDo] -> Maybe Int
forall a. (a -> CrashOnWarning) -> [a] -> Maybe Int
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 = (Flags -> CommandLineOption -> Flags)
-> Flags -> [CommandLineOption] -> Flags
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] -> Int -> Int -> CoreM [CoreToDo]
putPasses Flags
flags [CoreToDo]
todos Int
ph0 Int
sp = do
    IORef [[Type]]
the_ioref <- IO (IORef [[Type]]) -> CoreM (IORef [[Type]])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [[Type]]) -> CoreM (IORef [[Type]]))
-> IO (IORef [[Type]]) -> CoreM (IORef [[Type]])
forall a b. (a -> b) -> a -> b
$ [[Type]] -> IO (IORef [[Type]])
forall a. a -> IO (IORef a)
newIORef []
    let ([CoreToDo]
before_spec,[CoreToDo]
after_spec)   = Int -> [CoreToDo] -> ([CoreToDo], [CoreToDo])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
sp  [CoreToDo]
todos
        ([CoreToDo]
before_ph0 ,[CoreToDo]
after_ph0)    = Int -> [CoreToDo] -> ([CoreToDo], [CoreToDo])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
ph0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 = [[CoreToDo]] -> [CoreToDo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CoreToDo]
before_spec, [CoreToDo
ordering], [CoreToDo]
before_ph0, [CoreToDo
substitute] , [CoreToDo]
after_ph0]
    [CoreToDo] -> CoreM [CoreToDo]
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  -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Verbosity
other -> SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
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
    CrashOnWarning -> CoreM () -> CoreM ()
forall (f :: * -> *).
Applicative f =>
CrashOnWarning -> f () -> f ()
when CrashOnWarning
to_crash (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ (() -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> CoreM ()) -> () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> ()
forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"Crashing...")
    


install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [CommandLineOption]
opts [CoreToDo]
todos = do
    DynFlags
dyn_flags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let opt_level :: Int
opt_level = DynFlags -> Int
optLevel DynFlags
dyn_flags 
        flags :: Flags
flags     = [CommandLineOption] -> Flags
parseOpts [CommandLineOption]
opts
        m_phase0 :: Maybe Int
m_phase0  = [CoreToDo] -> Maybe Int
afterPhase0     [CoreToDo]
todos
        m_spec :: Maybe Int
m_spec    = [CoreToDo] -> Maybe Int
afterSpecialize [CoreToDo]
todos

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