[Git][ghc/ghc][wip/T22039] DmdAnal: Don't panic in addCaseBndrDmd (#22039)

[Sebastian Graf (@sgraf812)]

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


Commits:
14a81b15 by Sebastian Graf at 2022-08-25T15:07:09+02:00
DmdAnal: Don't panic in addCaseBndrDmd (#22039)

Rather conservatively return Top.
See Note [Untyped demand on case-alternative binders].

Fixes #22039.

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- + testsuite/tests/stranal/should_compile/T22039.hs
- testsuite/tests/stranal/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -586,7 +586,6 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
   = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $
     WithDmdType alt_ty (Alt con new_ids rhs')
 
--- Precondition: The SubDemand is not a Call
 -- See Note [Demand on the scrutinee of a product case]
 -- and Note [Demand on case-alternative binders]
 addCaseBndrDmd :: SubDemand -- On the case binder
@@ -598,8 +597,9 @@ addCaseBndrDmd case_sd fld_dmds
   | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd
   -- , pprTrace "addCaseBndrDmd" (ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) True
   = (scrut_sd, ds)
-  | otherwise
-  = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition
+  | otherwise -- Either an arity mismatch or scrut_sd was a call demand.
+              -- See Note [Untyped demand on case-alternative binders]
+  = (topSubDmd, map (const topDmd) fld_dmds)
   where
     scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds
 
@@ -830,6 +830,39 @@ thunk for a let binder that was an an absent case-alt binder during DmdAnal.
 This is needed even for non-product types, in case the case-binder
 is used but the components of the case alternative are not.
 
+Note [Untyped demand on case-alternative binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder
+may be a call demand or have a different number of fields than the constructor
+of the case alternative it is used in. From T22039:
+
+  blarg :: (Int, Int) -> String
+  blarg = show
+
+  f :: Either Int Int -> String
+  f Left{} = "no"
+  f e = blarg (unsafeCoerce e)
+  ==> { desugars to }
+  f = \ (ds_d1nV :: Either Int Int) ->
+      case ds_d1nV of wild_X1 {
+        Left ds_d1oV -> lvl_s1Q6;
+        Right ipv_s1Pl ->
+          blarg
+            (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of
+             { UnsafeRefl co_a1oT ->
+             wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))
+             })
+      }
+
+The case binder `e`/`wild_X1` has demand 1P(L,L), with two fields, from the call
+to `blarg`, but `Right` only has one field. Although the code will crash when
+executed, we must be able to analyse it and conservatively approximate with Top
+instead of panicking because of the mismatch.
+In #22039, this kind of code was guarded behind a safe `cast` and thus dead
+code, but nevertheless led to a panic of the compiler.
+
+See also Note [mkWWstr and unsafeCoerce] for a related issue.
+
 Note [Aggregated demand for cardinality]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 FIXME: This Note should be named [LetUp vs. LetDown] and probably predates


=====================================
testsuite/tests/stranal/should_compile/T22039.hs
=====================================
@@ -0,0 +1,59 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Bug where
+
+import Control.Exception
+import Data.Typeable
+import Unsafe.Coerce
+
+data Error
+  = Error Int String
+  | forall e . Exception e => SomeError Int e
+  deriving (Typeable)
+
+fromError :: Exception e => Error -> Maybe e
+fromError e@(Error _ _)   = cast e
+fromError (SomeError _ e) = cast e
+-- {-# NOINLINE fromError #-}
+
+instance Eq Error where
+  Error i s == Error i' s' = i == i' && s == s'
+  SomeError i e == SomeError i' e' = i == i' && show e == show e'
+  _ == _ = False
+
+instance Show Error where
+  show _ = ""
+
+instance Exception Error
+
+-- newtype
+data
+  UniquenessError = UniquenessError [((String, String), Int)]
+  deriving (Show, Eq)
+
+instance Exception UniquenessError
+
+test :: SomeException -> IO ()
+test e = case fromError =<< fromException e :: Maybe UniquenessError of
+  Just err -> print err
+  _ -> pure ()
+
+--
+-- Smaller reproducer by sgraf
+--
+
+blarg :: (Int,Int) -> String
+blarg = show
+{-# NOINLINE blarg #-}
+
+f :: Either Int Int -> String
+f Left{} = "no"
+f e = blarg (unsafeCoerce e)
+
+blurg :: (Int -> String) -> String
+blurg f = f 42
+{-# NOINLINE blurg #-}
+
+g :: Either Int Int -> String
+g Left{} = "no"
+g e = blurg (unsafeCoerce e)


=====================================
testsuite/tests/stranal/should_compile/all.T
=====================================
@@ -85,3 +85,4 @@ test('T21150', [ grep_errmsg(r'( t\d? :: Int)') ], compile, ['-dsuppress-uniques
 test('T21128', [ grep_errmsg(r'let { y = I\#') ], multimod_compile, ['T21128', '-v0 -dsuppress-uniques -dsuppress-all -ddump-simpl'])
 test('T21265', normal, compile, [''])
 test('EtaExpansion', normal, compile, [''])
+test('T22039', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14a81b15c63b563b67fe88d8d99fe492db60be1c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14a81b15c63b563b67fe88d8d99fe492db60be1c
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/20220825/732af611/attachment-0001.html>