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

import GhcPlugins

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 = \_ -> 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
flags io_ref :: IORef [[Type]]
io_ref = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass "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
flags io_ref :: IORef [[Type]]
io_ref = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass "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 iters :: Int
iters simpl_mode :: SimplMode
simpl_mode) = case SimplMode -> CompilerPhase
sm_phase (SimplMode -> CompilerPhase) -> SimplMode -> CompilerPhase
forall a b. (a -> b) -> a -> b
$ SimplMode
simpl_mode of
    Phase 0 -> CrashOnWarning
True
    _       -> CrashOnWarning
False 
isPhase0 _ = CrashOnWarning
False

-- | Return the index of simplifier phase 0. 
afterPhase0 :: [CoreToDo] -> Maybe Int
afterPhase0 :: [CoreToDo] -> Maybe Int
afterPhase0 todos :: [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 CoreDoSpecialising = CrashOnWarning
True
isSpecialize _                  = CrashOnWarning
False

-- | Return the index of the specialising pass. 
afterSpecialize :: [CoreToDo] -> Maybe Int
afterSpecialize :: [CoreToDo] -> Maybe Int
afterSpecialize todos :: [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 _    crash :: CrashOnWarning
crash) "-v0"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
None CrashOnWarning
crash
setOpts (Flags _    crash :: CrashOnWarning
crash) "-v1"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
Some CrashOnWarning
crash
setOpts (Flags _    crash :: CrashOnWarning
crash) "-v2"    = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
All  CrashOnWarning
crash
setOpts (Flags verb :: Verbosity
verb _    ) "-crash" = Verbosity -> CrashOnWarning -> Flags
Flags Verbosity
verb CrashOnWarning
True
setOpts flags :: Flags
flags              opt :: CommandLineOption
opt      = Flags
flags

-- | Parse command line options.
parseOpts :: [CommandLineOption] -> Flags
parseOpts :: [CommandLineOption] -> Flags
parseOpts opts :: [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
flags todos :: [CoreToDo]
todos ph0 :: Int
ph0 sp :: 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 (before_spec :: [CoreToDo]
before_spec,after_spec :: [CoreToDo]
after_spec)   = Int -> [CoreToDo] -> ([CoreToDo], [CoreToDo])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
sp  [CoreToDo]
todos
        (before_ph0 :: [CoreToDo]
before_ph0 ,after_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
flags = do
    let (Flags verb :: Verbosity
verb to_crash :: CrashOnWarning
to_crash) = Flags
flags
        printer :: CoreM ()
printer = case Verbosity
verb of
            None  -> () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            other :: Verbosity
other -> SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
text "The GStorable plugin requires simplifier phases with inlining and rules on, as well as a specialiser phase."
                          SDoc -> SDoc -> SDoc
$$ CommandLineOption -> SDoc
text "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 "Crashing...")
    


install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install opts :: [CommandLineOption]
opts todos :: [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
        (_       ,_       ,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 ph0 :: Int
ph0, Just sp :: Int
sp,_) -> Flags -> [CoreToDo] -> Int -> Int -> CoreM [CoreToDo]
putPasses   Flags
flags [CoreToDo]
todos (Int
ph0Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Int
spInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
        (_       ,_       ,_) -> 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