diff options
author | Sebastian Graf <sebastian.graf@kit.edu> | 2022-08-22 16:05:31 +0200 |
---|---|---|
committer | Zubin Duggal <zubin.duggal@gmail.com> | 2023-02-07 18:47:09 +0530 |
commit | a090f5c3d4376810617237ff5be589fafc0d96b6 (patch) | |
tree | ea1a9659990f19a0ac98a4ab8373da96fd579ba0 | |
parent | eadbbbcf8fbb0ff0f47f1819966fd2e564fa3d8e (diff) | |
download | haskell-a090f5c3d4376810617237ff5be589fafc0d96b6.tar.gz |
DmdAnal: Don't panic in addCaseBndrDmd (#22039)
Rather conservatively return Top.
See Note [Untyped demand on case-alternative binders].
I also factored `addCaseBndrDmd` into two separate functions `scrutSubDmd` and
`fieldBndrDmds`.
Fixes #22039.
(cherry picked from commit d2be80fd9b222963e8dd09a30f78c106e00da7f9)
-rw-r--r-- | compiler/GHC/Core/Opt/DmdAnal.hs | 121 | ||||
-rw-r--r-- | testsuite/tests/stranal/should_compile/T22039.hs | 59 | ||||
-rw-r--r-- | testsuite/tests/stranal/should_compile/all.T | 1 |
3 files changed, 173 insertions, 8 deletions
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 87306bd5d7..c11f84dc70 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -439,10 +439,11 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- whole DmdEnv !(!bndrs', !scrut_sd) | DataAlt _ <- alt - , id_dmds <- addCaseBndrDmd case_bndr_sd dmds - -- See Note [Demand on scrutinee of a product case] - = let !new_info = setBndrsDemandInfo bndrs id_dmds - !new_prod = mkProd id_dmds + -- See Note [Demand on the scrutinee of a product case] + , let !scrut_sd = scrutSubDmd case_bndr_sd dmds + , let !fld_dmds' = fieldBndrDmds scrut_sd (length dmds) + = let !new_info = setBndrsDemandInfo bndrs fld_dmds' + !new_prod = mkProd fld_dmds' in (new_info, new_prod) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the @@ -556,11 +557,32 @@ dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on scrutinee of a product case] - id_dmds = addCaseBndrDmd case_bndr_sd dmds + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + scrut_sd = scrutSubDmd case_bndr_sd dmds + id_dmds = fieldBndrDmds scrut_sd (length dmds) -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs id_dmds - = WithDmdType alt_ty (Alt con new_ids rhs') + !new_ids = setBndrsDemandInfo bndrs id_dmds + = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ + WithDmdType alt_ty (Alt con new_ids rhs') + +-- See Note [Demand on the scrutinee of a product case] +scrutSubDmd :: SubDemand -> [Demand] -> SubDemand +scrutSubDmd case_sd fld_dmds = + -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ + case_sd `plusSubDmd` mkProd fld_dmds + +-- See Note [Demand on case-alternative binders] +fieldBndrDmds :: SubDemand -- on the scrutinee + -> Arity + -> [Demand] -- Final demands for the components of the DataCon +fieldBndrDmds scrut_sd n_flds = + case viewProd n_flds scrut_sd of + Just ds -> ds + Nothing -> replicate n_flds topDmd + -- Either an arity mismatch or scrut_sd was a call demand. + -- See Note [Untyped demand on case-alternative binders] {- Note [Analysing with absent demand] @@ -672,6 +694,89 @@ worker, so the worker will rebuild x = (a, absent-error) and that'll crash. +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis, forgetting (b): + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +Note that ds_dnz is syntactically dead, but the expression bound to it is +reachable through the case binder wild_X7. Now watch what happens if we inline +foo's wrapper: + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of _ [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> $wfoo_soq GHC.Types.True ds_dnz } + +Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second +run of demand analysis would no longer infer ds_dnz to be absent. +But unlike occurrence analysis, which infers properties of the *syntactic* +shape of the program, the results of demand analysis describe expressions +*semantically* and are supposed to be mostly stable across Simplification. +That's why we should better account for (b). +In #10148, we ended up emitting a single-entry thunk instead of an updateable +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) -> Int + blarg (x,y) = x+y + -- blarg :: <1!P(1L,1L)> + + f :: Either Int Int -> Int + f Left{} = 0 + 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 1!P(1L,1L), 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 in 'fieldBndrDmds' 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. + +You might wonder why the same problem doesn't come up when scrutinising a +product type instead of a sum type. It appears that for products, `wild_X1` +will be inlined before DmdAnal. + +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 diff --git a/testsuite/tests/stranal/should_compile/T22039.hs b/testsuite/tests/stranal/should_compile/T22039.hs new file mode 100644 index 0000000000..034be06cae --- /dev/null +++ b/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) -> Int +blarg (x,y) = x+y +{-# NOINLINE blarg #-} + +f :: Either Int Int -> Int +f Left{} = 0 +f e = blarg (unsafeCoerce e) + +blurg :: (Int -> Int) -> Int +blurg f = f 42 +{-# NOINLINE blurg #-} + +g :: Either Int Int -> Int +g Left{} = 0 +g e = blurg (unsafeCoerce e) diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index 84d0f36641..46516744af 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -69,3 +69,4 @@ test('T20663', [ grep_errmsg(r'\$wyeah ::') ], compile, ['-dppr-cols=1000 -ddump test('T19180', normal, compile, ['']) test('T19849', normal, compile, ['']) +test('T22039', normal, compile, ['']) |