Avoid retaining bindings via ModGuts held on the stack

It's better to overwrite the bindings fields of the ModGuts before
starting an iteration as then all the old bindings can be collected as
soon as the simplifier has processed them. Otherwise we end up with the
old bindings being alive until right at the end of the simplifier pass
as the mg_binds field is only modified right at the end.

2 files changed, 24 insertions, 19 deletions

diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 44f6c9d710..f9168a46b2 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -3437,24 +3437,26 @@ lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do
   logger <- getLogger
   when (gopt Opt_DoAnnotationLinting dflags) $
     liftIO $ Err.showPass logger "Annotation linting - first run"
-  nguts <- pass 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"
-    nguts' <- withoutAnnots pass guts
-    -- Finally compare the resulting bindings
-    liftIO $ 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.Core.Opt.Monad.putMsg $ vcat
-      [ lint_banner "warning" pname
-      , text "Core changes with annotations:"
-      , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
-      ]
-  -- Return actual new guts
-  return nguts
+  if gopt Opt_DoAnnotationLinting dflags
+    then do
+      nguts <- pass guts
+      liftIO $ Err.showPass logger "Annotation linting - second run"
+      nguts' <- withoutAnnots pass guts
+      -- Finally compare the resulting bindings
+      liftIO $ 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.Core.Opt.Monad.putMsg $ vcat
+        [ lint_banner "warning" pname
+        , text "Core changes with annotations:"
+        , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs
+        ]
+      return nguts
+    else
+      pass guts
 
 -- | Run the given pass without annotations. This means that we both
 -- set the debugLevel setting to 0 in the environment as well as all
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 33ecf3cb86..1c84db9eea 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -153,7 +153,7 @@ simplifyPgm logger unit_env opts
                           , mg_binds = binds, mg_rules = rules
                           , mg_fam_inst_env = fam_inst_env })
   = do { (termination_msg, it_count, counts_out, guts')
-           <- do_iteration 1 [] binds rules
+            <- do_iteration 1 [] binds rules
 
         ; when (logHasDumpFlag logger Opt_D_verbose_core2core
                 && logHasDumpFlag logger Opt_D_dump_simpl_stats) $
@@ -175,6 +175,9 @@ simplifyPgm logger unit_env opts
     print_unqual    = mkPrintUnqualified unit_env rdr_env
     active_rule     = activeRule mode
     active_unf      = activeUnfolding mode
+    -- Note the bang in !guts_no_binds.  If you don't force `guts_no_binds`
+    -- the old bindings are retained until the end of all simplifier iterations
+    !guts_no_binds = guts { mg_binds = [], mg_rules = [] }
 
     do_iteration :: Int -- Counts iterations
                  -> [SimplCount] -- Counts from earlier iterations, reversed
@@ -198,7 +201,7 @@ simplifyPgm logger unit_env opts
                 -- number of iterations we actually completed
         return ( "Simplifier baled out", iteration_no - 1
                , totalise counts_so_far
-               , guts { mg_binds = binds, mg_rules = rules } )
+               , guts_no_binds { mg_binds = binds, mg_rules = rules } )
 
       -- Try and force thunks off the binds; significantly reduces
       -- space usage, especially with -O.  JRS, 000620.
@@ -253,7 +256,7 @@ simplifyPgm logger unit_env opts
            if isZeroSimplCount counts1 then
                 return ( "Simplifier reached fixed point", iteration_no
                        , totalise (counts1 : counts_so_far)  -- Include "free" ticks
-                       , guts { mg_binds = binds1, mg_rules = rules1 } )
+                       , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } )
            else do {
                 -- Short out indirections
                 -- We do this *after* at least one run of the simplifier