From 03c5dfbf52969504ca3473cb2eb7b3f7cf96d4b3 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Sat, 4 May 2024 22:56:03 +0100
Subject: [PATCH] Fix a float-out error
Ticket #24768 showed that the Simplifier was accidentally destroying
a join point. It turned out to be that we were sending a bottoming
join point to the top, accidentally abstracting over /other/ join
points.
Easily fixed.
---
compiler/GHC/Core/Opt/SetLevels.hs | 11 +++-
.../tests/simplCore/should_compile/T24768.hs | 56 +++++++++++++++++++
.../tests/simplCore/should_compile/all.T | 1 +
3 files changed, 66 insertions(+), 2 deletions(-)
create mode 100644 testsuite/tests/simplCore/should_compile/T24768.hs
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index 5ec370aa7cea..803ba19c2cef 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -1088,6 +1088,11 @@ But, as ever, we need to be careful:
as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
argument.
+ Do /not/ do this for bottoming /join-point/ bindings. They may call other
+ join points (#24768), and floating to the top would abstract over those join
+ points, which we should never do.
+
+
See Maessen's paper 1999 "Bottom extraction: factoring error handling out
of functional programs" (unpublished I think).
@@ -1252,9 +1257,11 @@ lvlBind env (AnnNonRec bndr rhs)
deann_rhs = deAnnotate rhs
mb_bot_str = exprBotStrictness_maybe deann_rhs
- is_bot_lam = isJust mb_bot_str
+ is_bot_lam = not is_join && isJust mb_bot_str
-- is_bot_lam: looks like (\xy. bot), maybe zero lams
- -- NB: not isBottomThunk! See Note [Bottoming floats] point (3)
+ -- NB: not isBottomThunk!
+ -- NB: not is_join: don't send bottoming join points to the top.
+ -- See Note [Bottoming floats] point (3)
is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty
n_extra = count isId abs_vars
diff --git a/testsuite/tests/simplCore/should_compile/T24768.hs b/testsuite/tests/simplCore/should_compile/T24768.hs
new file mode 100644
index 000000000000..4a239fe7dd3d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T24768.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- In this example the simplifer destroyed a join point,
+-- namely the `loop` inside `detectLeaks`
+
+module T24768 (detectLeaks) where
+
+import Control.Monad (zipWithM_)
+import Control.Monad.Reader (ReaderT(..))
+import Control.Monad.State (StateT, evalStateT)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+data Debuggee
+
+newtype DebugM a = DebugM (ReaderT Debuggee IO a)
+ deriving (Functor, Applicative, Monad)
+
+runSimple :: Debuggee -> DebugM a -> IO a
+runSimple d (DebugM a) = runReaderT a d
+
+cands :: [a]
+cands = []
+{-# NOINLINE cands #-}
+
+detectLeaks :: Debuggee -> IO ()
+detectLeaks e = loop M.empty
+ where
+ loop :: M.Map () RankInfo -> IO ()
+ loop rm = do
+ gs <- runSimple e $ mapM (findSlice rm) cands
+ zipWithM_ (\n _g -> writeFile
+ ("slices/" ++ show @Int n ++ ".dot")
+ "abcd")
+ [0..] gs
+ loop rm
+
+data RankInfo = RankInfo !Double !Int
+
+lookupRM :: () -> M.Map () RankInfo -> [((), RankInfo)]
+lookupRM k m = M.assocs filtered_map
+ where
+ (res_map, _) = M.partitionWithKey (\e _ -> e == k) m
+ filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map
+
+findSlice :: forall m a. Monad m => M.Map () RankInfo -> () -> m [a]
+findSlice rm _k = evalStateT go S.empty
+ where
+ go :: StateT s m [a]
+ go = do
+ let next_edges = lookupRM () rm
+ _ss <- concat <$> mapM (\_ -> go) next_edges
+ return []
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 05324f58b116..4d01b3678150 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -515,3 +515,4 @@ test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
+test('T24768', normal, compile, ['-O'])
--
GitLab