Removed CoreM uses from GHC.Core.Lint

3 files changed, 59 insertions, 26 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index c2eb27723a..27af90a3cb 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -13,6 +13,7 @@ See Note [Core Lint guarantee].
 -}
 
 module GHC.Core.Lint (
+    LintAnnotationsConfig (..),
     LintPassResultConfig (..),
     LintFlags (..),
     StaticPtrCheck (..),
@@ -60,8 +61,7 @@ import GHC.Core.Unify
 import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )
 import GHC.Core.Coercion.Opt ( checkAxInstCo )
 import GHC.Core.Opt.Arity    ( typeArity )
-
-import GHC.Plugins.Monad
+import GHC.Core.Opt.Utils    ( SimplCount )
 
 import GHC.Types.Literal
 import GHC.Types.Var as Var
@@ -3463,44 +3463,48 @@ dupExtVars vars
 ************************************************************************
 -}
 
+data LintAnnotationsConfig = LintAnnotationsConfig
+  { la_doAnnotationLinting :: !Bool
+  , la_passName :: !SDoc
+  , la_sourceLoc :: !SrcSpan
+  , la_debugLevel :: !Int
+  , la_printUnqual :: !PrintUnqualified
+  }
+
 -- | This checks whether a pass correctly looks through debug
 -- annotations (@SourceNote@). This works a bit different from other
 -- consistency checks: We check this by running the given task twice,
 -- noting all differences between the results.
-lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do
+lintAnnots :: Logger -> LintAnnotationsConfig -> (Int -> ModGuts -> IO (ModGuts, SimplCount)) -> ModGuts -> IO (ModGuts, SimplCount)
+lintAnnots logger cfg pass guts = {-# SCC "lintAnnots" #-} do
   -- Run the pass as we normally would
-  dflags <- getDynFlags
-  logger <- getLogger
-  when (gopt Opt_DoAnnotationLinting dflags) $
-    liftIO $ Err.showPass logger "Annotation linting - first run"
-  nguts <- pass guts
+  when (la_doAnnotationLinting cfg) $
+    Err.showPass logger "Annotation linting - first run"
+  res@(nguts, _) <- pass (la_debugLevel cfg) guts
   -- If appropriate re-run it without debug annotations to make sure
   -- that they made no difference.
-  when (gopt Opt_DoAnnotationLinting dflags) $ do
-    liftIO $ Err.showPass logger "Annotation linting - second run"
+  when (la_doAnnotationLinting cfg) $ do
+    Err.showPass logger "Annotation linting - second run"
     nguts' <- withoutAnnots pass guts
     -- Finally compare the resulting bindings
-    liftIO $ Err.showPass logger "Annotation linting - comparison"
+    Err.showPass logger "Annotation linting - comparison"
     let binds = flattenBinds $ mg_binds nguts
         binds' = flattenBinds $ mg_binds nguts'
         (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
-    when (not (null diffs)) $ GHC.Plugins.Monad.putMsg $ vcat
-      [ lint_banner "warning" pname
+        sty = mkUserStyle (la_printUnqual cfg) AllTheWay
+    when (not (null diffs)) $ logMsg logger MCInfo (la_sourceLoc cfg) $ withPprStyle sty $ vcat
+      [ lint_banner "warning" (la_passName cfg)
       , text "Core changes with annotations:"
       , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
       ]
-  -- Return actual new guts
-  return nguts
+  -- Return actual new guts along with the of the ticks counted
+  return res
 
 -- | Run the given pass without annotations. This means that we both
 -- set the debugLevel setting to 0 in the environment as well as all
 -- annotations from incoming modules.
-withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+withoutAnnots :: (Int -> ModGuts -> IO (ModGuts, SimplCount)) -> ModGuts -> IO ModGuts
 withoutAnnots pass guts = do
-  -- Remove debug flag from environment.
-  -- TODO: supply tag here as well ?
-  let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 }
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
   -- them in absence of debugLevel > 0.
@@ -3511,6 +3515,6 @@ withoutAnnots pass guts = do
         NonRec b e -> NonRec b $ nukeTicks e
       nukeAnnotsMod mg@ModGuts{mg_binds=binds}
         = mg{mg_binds = map nukeAnnotsBind binds}
-  -- Perform pass with all changes applied. Drop the simple count so it doesn't
-  -- effect the total also
-  dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts)
+  -- Perform pass with all changes applied and without debugging.
+  -- TODO: supply tag here as well ?
+  fst <$> pass 0 (nukeAnnotsMod guts)
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 8dc248ce77..6da7a614d9 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -30,7 +30,7 @@ import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
 import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
 import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
 import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )
-import GHC.Core.Lint    ( dumpPassResult, lintAnnots )
+import GHC.Core.Lint    ( LintAnnotationsConfig(..), dumpPassResult, lintAnnots )
 import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..), CoreDoSimplifyOpts(..) )
 import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules )
 import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
@@ -488,14 +488,35 @@ runCorePasses passes guts
     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
     do_pass guts pass = do
       logger <- getLogger
+      cfg <- initLintAnnotationsConfig pass
       withTiming logger (ppr pass <+> brackets (ppr mod))
                    (const ()) $ do
-            guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
+            (guts', sc) <- unliftCoreM $ \runInIO -> do
+              let passIO :: Int -> ModGuts -> IO (ModGuts, SimplCount)
+                  passIO debug_lvl nguts = runInIO
+                    $ mapDynFlagsCoreM (\(!dflags) -> dflags { debugLevel = debug_lvl })
+                    $ doCorePass pass nguts
+              lintAnnots logger cfg passIO guts
+            addSimplCount sc
             endPass pass (mg_binds guts') (mg_rules guts')
             return guts'
 
     mod = mg_module guts
 
+initLintAnnotationsConfig :: CoreToDo -> CoreM LintAnnotationsConfig
+initLintAnnotationsConfig pass = do
+  dflags <- getDynFlags
+  loc <- getSrcSpanM
+  let debug_lvl = debugLevel dflags
+  print_unqual <- getPrintUnqualified
+  return LintAnnotationsConfig
+    { la_doAnnotationLinting = gopt Opt_DoAnnotationLinting dflags
+    , la_passName = ppr pass
+    , la_sourceLoc = loc
+    , la_debugLevel = debug_lvl
+    , la_printUnqual = print_unqual
+    }
+
 doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
 doCorePass pass guts = do
   logger    <- getLogger
diff --git a/compiler/GHC/Plugins/Monad.hs b/compiler/GHC/Plugins/Monad.hs
index cf2385e96f..75f6e9a69d 100644
--- a/compiler/GHC/Plugins/Monad.hs
+++ b/compiler/GHC/Plugins/Monad.hs
@@ -14,7 +14,7 @@ module GHC.Plugins.Monad (
     bindsOnlyPass,
 
     -- * The monad
-    CoreM, runCoreM,
+    CoreM, runCoreM, unliftCoreM,
 
     mapDynFlagsCoreM,
 
@@ -183,6 +183,14 @@ runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m
     extract :: (a, CoreWriter) -> (a, SimplCount)
     extract (value, writer) = (value, cw_simpl_count writer)
 
+unliftCoreM :: ((CoreM a -> IO (a, SimplCount)) -> IO r) -> CoreM r
+unliftCoreM f = do
+  reader <- read id
+  liftIO $ f (liftM extract . runIOEnv reader . unCoreM)
+  where
+    extract :: (a, CoreWriter) -> (a, SimplCount)
+    extract (value, writer) = (value, cw_simpl_count writer)
+
 {-
 ************************************************************************
 *                                                                      *