[Git][ghc/ghc][wip/T21761] Respect -XStrict in the pattern-match checker (#21761)

[Sebastian Graf (@sgraf812)]

Sebastian Graf pushed to branch wip/T21761 at Glasgow Haskell Compiler / GHC


Commits:
0daecee7 by Sebastian Graf at 2022-12-07T16:30:01+01:00
Respect -XStrict in the pattern-match checker (#21761)

We were missing a call to `decideBangHood` in the pattern-match checker.
Unfortunately the ones in `mk_eqn_info` happen *after* the pattern-match checker
on the match has run and there is a conflicting data dependency for
long-distance information.

Fixes #21761.

- - - - -


4 changed files:

- compiler/GHC/HsToCore/Pmc/Desugar.hs
- + testsuite/tests/pmcheck/should_compile/T21761.hs
- + testsuite/tests/pmcheck/should_compile/T21761.stderr
- testsuite/tests/pmcheck/should_compile/all.T


Changes:

=====================================
compiler/GHC/HsToCore/Pmc/Desugar.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Core.Coercion
 import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
 import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
 import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
-import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar)
+import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood)
 import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
 import GHC.HsToCore.Monad
 import GHC.Core.TyCo.Rep
@@ -334,7 +334,14 @@ desugarMatches vars matches =
 -- Desugar a single match
 desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
 desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
-  pats'  <- concat <$> zipWithM desugarLPat vars pats
+  dflags <- getDynFlags
+  -- We take account of -XStrict here (#21761). Ideally, we'd share the call
+  -- to `decideBangHood` with `GHC.HsToCore.Match.mk_eqn_info` and do it
+  -- *before* Pmc runs, but there is a conflicting data dependency with
+  -- long-distance information prohibiting the rearrangement.
+  -- It's simplest to call `decideBangHood` here on our own.
+  let banged_pats = map (decideBangHood dflags) pats
+  pats'  <- concat <$> zipWithM desugarLPat vars banged_pats
   grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
   -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
   return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }


=====================================
testsuite/tests/pmcheck/should_compile/T21761.hs
=====================================
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
+
+module T21761 where
+
+data Void
+
+idV :: Void -> Void
+idV v = v
+
+idV' :: Void -> Void
+idV' v = case v of w -> w
+
+bangIdV :: Void -> Void
+bangIdV !v = v
+
+bangIdV' :: Void -> Void
+bangIdV' v = case v of !w -> w


=====================================
testsuite/tests/pmcheck/should_compile/T21761.stderr
=====================================
@@ -0,0 +1,24 @@
+
+T21761.hs:10:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘idV’: idV v = ...
+
+T21761.hs:13:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘idV'’: idV' v = ...
+
+T21761.hs:13:20: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In a case alternative: w -> ...
+
+T21761.hs:16:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘bangIdV’: bangIdV !v = ...
+
+T21761.hs:19:1: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In an equation for ‘bangIdV'’: bangIdV' v = ...
+
+T21761.hs:19:24: warning: [GHC-94210] [-Woverlapping-patterns (in -Wdefault)]
+    Pattern match has inaccessible right hand side
+    In a case alternative: !w -> ...


=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -157,3 +157,4 @@ test('EmptyCase008', [],  compile, [overlapping_incomplete])
 test('EmptyCase009', [],  compile, [overlapping_incomplete])
 test('EmptyCase010', [],  compile, [overlapping_incomplete])
 test('T19271', [],  compile, [overlapping_incomplete])
+test('T21761', [],  compile, [overlapping_incomplete])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0daecee722326a8031337bb0e55411996b26546e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0daecee722326a8031337bb0e55411996b26546e
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/20221207/d23d0f87/attachment-0001.html>