diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs index 63ca5cb7..19561d5b 100644 --- a/src/Reflex/Optimizer.hs +++ b/src/Reflex/Optimizer.hs @@ -14,26 +14,57 @@ module Reflex.Optimizer ) where #ifdef ghcjs_HOST_OS + import Plugins + +-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used. +plugin :: Plugin +plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS." + #else -import Control.Arrow -import CoreMonad -import Data.String -import GhcPlugins #if MIN_VERSION_base(4,9,0) import Prelude hiding ((<>)) #endif -#endif +import Control.Arrow +import Data.String -#ifdef ghcjs_HOST_OS +#if MIN_VERSION_base(4,15,0) +import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types +import GHC.Plugins +import GHC.Types.Error --- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used. +-- | The GHC plugin itself. See "GHC.Plugins" for more details. plugin :: Plugin -plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS." +plugin = defaultPlugin { installCoreToDos = install } +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install [] p = do + liftIO $ putStrLn $ showSDocUnsafe $ ppr p + let f = \case + simpl@(CoreDoSimplify _) -> [CoreDoSpecialising, simpl] + x -> [x] + return $ makeInlinable : concatMap f p +install options@(_:_) p = do + msg MCInfo $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options" + install [] p + +makeInlinable :: CoreToDo +makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do + let f v = setIdInfo v $ let i = idInfo v in + setInlinePragInfo i $ let p = inlinePragInfo i in + if isDefaultInlinePragma p + then defaultInlinePragma { inl_inline = Inlinable (inl_src p) } + else p + newBinds = flip map (mg_binds modGuts) $ \case + NonRec b e -> NonRec (f b) e + Rec bes -> Rec $ map (first f) bes + return $ modGuts { mg_binds = newBinds } #else +import CoreMonad +import GhcPlugins -- | The GHC plugin itself. See "GhcPlugins" for more details. plugin :: Plugin @@ -61,5 +92,6 @@ makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do NonRec b e -> NonRec (f b) e Rec bes -> Rec $ map (first f) bes return $ modGuts { mg_binds = newBinds } +#endif #endif