{-# 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
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)
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
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
isSpecialize :: CoreToDo -> Bool
isSpecialize :: CoreToDo -> CrashOnWarning
isSpecialize CoreDoSpecialising = CrashOnWarning
True
isSpecialize _ = CrashOnWarning
False
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
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
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
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