[Git][ghc/ghc][master] Fix a float-out error

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
03c5dfbf by Simon Peyton Jones at 2024-05-05T12:53:15-04:00
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.

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/SetLevels.hs
- + testsuite/tests/simplCore/should_compile/T24768.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
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


=====================================
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 []


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03c5dfbf52969504ca3473cb2eb7b3f7cf96d4b3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03c5dfbf52969504ca3473cb2eb7b3f7cf96d4b3
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240505/8b31d600/attachment-0001.html>