[Git][ghc/ghc][wip/T22439] Wibble

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T22439 at Glasgow Haskell Compiler / GHC


Commits:
7f986a7d by Simon Peyton Jones at 2022-11-21T11:10:24+00:00
Wibble

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/Exitify.hs
- + testsuite/tests/simplCore/should_compile/T22439.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -36,19 +36,23 @@ Now `t` is no longer in a recursive function, and good things happen!
 -}
 
 import GHC.Prelude
+import GHC.Core
+import GHC.Core.Type
+import GHC.Core.Utils
+import GHC.Core.Opt.Arity( exprBotStrictness_maybe )
+import GHC.Core.FVs
+
 import GHC.Types.Var
 import GHC.Types.Id
 import GHC.Types.Id.Info
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Utils.Monad.State.Strict
-import GHC.Builtin.Uniques
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
-import GHC.Core.FVs
+
+import GHC.Builtin.Uniques
 import GHC.Data.FastString
-import GHC.Core.Type
+
 import GHC.Utils.Misc( mapSnd )
+import GHC.Utils.Monad.State.Strict
 
 import Data.Bifunctor
 import Control.Monad
@@ -254,28 +258,34 @@ exitifyRec in_scope pairs
         captures_join_points = any isJoinId abs_vars
 
 
+addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
 -- Picks a new unique, which is disjoint from
 --  * the free variables of the whole joinrec
 --  * any bound variables (captured)
 --  * any exit join points created so far.
-mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
-mkExitJoinId in_scope ty join_arity = do
-    fs <- get
-    let avoid = in_scope `extendInScopeSetList` (map fst fs)
-                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
-    return (uniqAway avoid exit_id_tmpl)
+--
+-- If it's a bottoming expression (which is very plausible) give it
+--   a bottoming demand/cpr sig right away, for the same reasons
+--   as given in Note [Bottoming floats] in GHC.Core.Opt.SetLevels
+--   Especially: if we fail to attach the signature we might CSE with
+--   another binding that /does/ have a bottoming signature, and lose
+--   the signature ==> Lint errors.
+addExit in_scope join_arity rhs
+  = do { fs <- get
+       ; let avoid = in_scope `extendInScopeSetList` (map fst fs)
+                              `extendInScopeSet` exit_id1 -- just cosmetics
+             final_exit_id = uniqAway avoid exit_id2
+       ; put ((final_exit_id,rhs):fs)
+       ; return final_exit_id }
   where
-    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty
-                    `asJoinId` join_arity
-
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
-    -- Pick a suitable name
-    let ty = exprType rhs
-    v <- mkExitJoinId in_scope ty join_arity
-    fs <- get
-    put ((v,rhs):fs)
-    return v
+    ty = exprType rhs
+    exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty
+               `asJoinId` join_arity
+    exit_id2 | Just (arity, str_sig, cpr_sig) <- exprBotStrictness_maybe rhs
+             = exit_id1 `setIdArity`  arity
+                        `setIdDmdSig` str_sig
+                        `setIdCprSig` cpr_sig
+             | otherwise = exit_id1
 
 {-
 Note [Interesting expression]


=====================================
testsuite/tests/simplCore/should_compile/T22439.hs
=====================================
@@ -0,0 +1,33 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- This test caused a Lint error because Exitify didn't pin on a
+-- bottoming signature when floating.
+
+module Bug where
+
+import qualified Data.Text.Lazy as T
+import GHC.Exts (IsList(..))
+import Prelude (Bool, Char, otherwise)
+
+class (IsList full, item ~ Item full) => ListLike full item | full -> item where
+    empty :: full
+    cons :: item -> full -> full
+    head :: full -> item
+    tail :: full -> full
+    null :: full -> Bool
+
+    deleteBy :: (item -> item -> Bool) -> item -> full -> full
+    deleteBy func i l
+        | null l = empty
+        | otherwise =
+            if func i (head l)
+               then tail l
+               else cons (head l) (deleteBy func i (tail l))
+
+instance ListLike T.Text Char where
+    empty = T.empty
+    cons = T.cons
+    head = T.head
+    tail = T.tail
+    null = T.null


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -446,3 +446,5 @@ test('T17366_AR',  [grep_errmsg(r'SPEC')], multimod_compile, ['T17366_AR', '-O -
 # One module, T21851_2.hs, has OPTIONS_GHC -ddump-simpl
 # Expecting to see $s$wwombat
 test('T21851_2', [grep_errmsg(r'wwombat') ], multimod_compile, ['T21851_2', '-O -dno-typeable-binds -dsuppress-uniques'])
+
+test('T22439', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f986a7d1e50ce09d83a0ff67d3a9d96cc28888e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f986a7d1e50ce09d83a0ff67d3a9d96cc28888e
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/20221121/d39fbdf9/attachment-0001.html>