[Git][ghc/ghc][master] Propagate long-distance info in generated code
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu May 25 22:58:23 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
fbc8e04e by sheaf at 2023-05-25T18:58:00-04:00
Propagate long-distance info in generated code
When desugaring generated pattern matches, we skip pattern match checks.
However, this ended up also discarding long-distance information, which
might be needed for user-written sub-expressions.
Example:
```haskell
okay (GADT di) cd =
let sr_field :: ()
sr_field = case getFooBar di of { Foo -> () }
in case cd of { SomeRec _ -> SomeRec sr_field }
```
With sr_field a generated FunBind, we still want to propagate the outer
long-distance information from the GADT pattern match into the checks
for the user-written RHS of sr_field.
Fixes #23445
- - - - -
6 changed files:
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/Tc/Gen/Expr.hs
- + testsuite/tests/pmcheck/should_compile/T23445.hs
- testsuite/tests/pmcheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -218,7 +218,7 @@ mkMatchGroup :: AnnoBody p body
-> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = origin
- , mg_alts = matches }
+ , mg_alts = matches }
mkLamCaseMatchGroup :: AnnoBody p body
=> Origin
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -36,7 +36,7 @@ import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
-import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
+import GHC.HsToCore.Pmc.Types ( Nablas )
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
@@ -783,16 +783,24 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-- Pattern match check warnings for /this match-group/.
-- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-- Each Match will split off one Nablas for its RHSs from this.
- ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
+ ; matches_nablas <-
+ if isMatchContextPmChecked dflags origin ctxt
+
+ -- See Note [Long-distance information] in GHC.HsToCore.Pmc
then addHsScrutTmCs (concat scrs) new_vars $
- -- See Note [Long-distance information]
pmcMatches (DsMatchContext ctxt locn) new_vars matches
- else pure (initNablasMatches matches)
+
+ -- When we're not doing PM checks on the match group,
+ -- we still need to propagate long-distance information.
+ -- See Note [Long-distance information in matchWrapper]
+ else do { ldi_nablas <- getLdiNablas
+ ; pure $ initNablasMatches ldi_nablas matches }
; eqns_info <- zipWithM mk_eqn_info matches matches_nablas
- ; result_expr <- handleWarnings $
+ ; result_expr <- discard_warnings_if_generated origin $
matchEquations ctxt new_vars eqns_info rhs_ty
+
; return (new_vars, result_expr) }
where
-- Called once per equation in the match, or alternative in the case
@@ -810,19 +818,67 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
, eqn_orig = FromSource
, eqn_rhs = match_result } }
- handleWarnings = if isGenerated origin
- then discardWarningsDs
- else id
+ discard_warnings_if_generated orig =
+ if isGenerated orig
+ then discardWarningsDs
+ else id
+
+ initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
+ initNablasMatches ldi_nablas ms
+ = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms
+
+ initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas
+ initNablasGRHSs ldi_nablas m
+ = expectJust "GRHSs non-empty"
+ $ NEL.nonEmpty
+ $ replicate (length (grhssGRHSs m)) ldi_nablas
+
+{- Note [Long-distance information in matchWrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checking in matchWrapper is done conditionally, depending
+on isMatchContextPmChecked. This means that we don't perform pattern match
+checking on e.g. generated pattern matches.
+
+However, when we skip pattern match checking, we still need to keep track
+of long-distance information in case we need it in a nested context.
+
+This came up in #23445. For example:
- initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
- initNablasMatches ms
- = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms
+ data GADT a where
+ IsUnit :: GADT ()
- initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
- initNablasGRHSs m = expectJust "GRHSs non-empty"
- $ NEL.nonEmpty
- $ replicate (length (grhssGRHSs m)) initNablas
+ data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+ data SomeRec = SomeRec { fld :: () }
+
+ bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+ bug IsUnit foo r =
+ let gen_fld :: ()
+ gen_fld = case foo of { FooUnit -> () }
+ in case r of { SomeRec _ -> SomeRec gen_fld }
+
+Here the body of 'bug' was generated by 'desugarRecordUpd' from the user-written
+record update
+
+ cd { fld = case foo of { FooUnit -> () } }
+
+As a result, we have a generated FunBind gen_fld whose RHS
+
+ case foo of { FooUnit -> () }
+
+is user-written. This all happens after the GADT pattern match on IsUnit,
+which brings into scope the Given equality [G] a ~ (). We need to make sure
+that this long distance information is visible when pattern match checking the
+user-written case statement.
+
+To propagate this long-distance information in 'matchWrapper', when we skip
+pattern match checks, we make sure to manually pass the long-distance
+information to 'mk_eqn_info', which is responsible for recurring further into
+the expression (in this case, it will end up recursively calling 'matchWrapper'
+on the user-written case statement).
+-}
matchEquations :: HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
=====================================
compiler/GHC/HsToCore/Pmc.hs
=====================================
@@ -39,7 +39,7 @@ module GHC.HsToCore.Pmc (
isMatchContextPmChecked,
-- See Note [Long-distance information]
- addTyCs, addCoreScrutTmCs, addHsScrutTmCs
+ addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas
) where
import GHC.Prelude
@@ -142,8 +142,8 @@ pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
-- each of a 'Match'es 'GRHS' for Note [Long-distance information].
--
--- Special case: When there are /no matches/, then the functionassumes it
--- checks and @-XEmptyCase@ with only a single match variable.
+-- Special case: When there are /no matches/, then the function assumes it
+-- checks an @-XEmptyCase@ with only a single match variable.
-- See Note [Checking EmptyCase].
pmcMatches
:: DsMatchContext -- ^ Match context, for warnings messages
=====================================
compiler/GHC/Tc/Gen/Expr.hs
=====================================
@@ -1070,7 +1070,7 @@ Wrinkle [GADT result type in tcRecordUpd]
-}
--- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression
+-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression
-- that matches on the constructors of the record @r@, as described in
-- Note [Record Updates].
--
=====================================
testsuite/tests/pmcheck/should_compile/T23445.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE GADTs #-}
+
+module T23445 where
+
+data GADT a where
+ IsUnit :: GADT ()
+
+data Foo b where
+ FooUnit :: Foo ()
+ FooInt :: Foo Int
+
+data SomeRec = SomeRec { fld :: () }
+
+bug :: GADT a -> Foo a -> SomeRec -> SomeRec
+bug IsUnit foo r =
+ r { fld = case foo of { FooUnit -> () } }
=====================================
testsuite/tests/pmcheck/should_compile/all.T
=====================================
@@ -112,6 +112,10 @@ test('CaseOfKnownCon', [], compile, [overlapping_incomplete])
test('TooManyDeltas', [], compile, [overlapping_incomplete+'-fmax-pmcheck-models=0'])
test('LongDistanceInfo', [], compile, [overlapping_incomplete])
test('T21662', [], compile, [overlapping_incomplete])
+test('T19271', [], compile, [overlapping_incomplete])
+test('T21761', [], compile, [overlapping_incomplete])
+test('T22964', [], compile, [overlapping_incomplete])
+test('T23445', [], compile, [overlapping_incomplete])
# Series (inspired) by Luke Maranget
@@ -156,6 +160,4 @@ test('EmptyCase007', [], compile, [overlapping_incomplete])
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])
-test('T22964', [], compile, [overlapping_incomplete])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbc8e04e5d8fb05ff60568042802ab2fb34e1a70
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fbc8e04e5d8fb05ff60568042802ab2fb34e1a70
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/20230525/6c4a90b2/attachment-0001.html>
More information about the ghc-commits
mailing list