From 844d88d10cbf0db8ad8677a9c72f6a10e811c0f4 Mon Sep 17 00:00:00 2001
From: ymeister <47071325+ymeister@users.noreply.github.com>
Date: Wed, 7 Aug 2024 08:41:52 +0400
Subject: [PATCH] Fix optimizer plugin

---
 src/Reflex/Optimizer.hs | 48 ++++++++++++++++++++++++++++++++++-------
 1 file changed, 40 insertions(+), 8 deletions(-)

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