diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 23 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/InertSet.hs | 15 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Interact.hs | 103 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 28 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types/Origin.hs-boot | 4 |
7 files changed, 150 insertions, 54 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 9880c13a9c..10d1c60fb1 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE InstanceSigs #-} module GHC.Tc.Errors.Ppr ( pprTypeDoesNotHaveFixedRuntimeRep @@ -1305,7 +1306,18 @@ instance Diagnostic TcRnMessage where , text "Combine alternative minimal complete definitions with `|'" ] where sigs = sig1 : sig2 : otherSigs - + TcRnLoopySuperclassSolve wtd_loc wtd_pty -> + mkSimpleDecorated $ vcat [ header, warning, user_manual ] + where + header, warning, user_manual :: SDoc + header + = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma + , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma + , text "in a way that might turn out to loop at runtime." ] + warning + = vcat [ text "Future versions of GHC will turn this warning into an error." ] + user_manual = + vcat [ text "See the user manual, ยง Undecidable instances and loopy superclasses." ] diagnosticReason = \case TcRnUnknownMessage m @@ -1734,6 +1746,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnDuplicateMinimalSig{} -> ErrorWithoutFlag + TcRnLoopySuperclassSolve{} + -> WarningWithFlag Opt_WarnLoopySuperclassSolve diagnosticHints = \case TcRnUnknownMessage m @@ -2173,6 +2187,13 @@ instance Diagnostic TcRnMessage where -> noHints TcRnDuplicateMinimalSig{} -> noHints + TcRnLoopySuperclassSolve wtd_loc wtd_pty + -> [LoopySuperclassSolveHint wtd_pty cls_or_qc] + where + cls_or_qc :: ClsInstOrQC + cls_or_qc = case ctLocOrigin wtd_loc of + ScOrigin c_or_q _ -> c_or_q + _ -> IsClsInst -- shouldn't happen diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index c1b8461839..e2707b4aa4 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -2924,6 +2924,23 @@ data TcRnMessage where -} TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage + {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@, + that is triggered when GHC solves a constraint in a possibly-loopy way, + violating the class instance termination rules described in the section + "Undecidable instances and loopy superclasses" of the user's guide. + + Example: + + class Foo f + class Foo f => Bar f g + instance Bar f f => Bar f (h k) + + Test cases: T20666, T20666{a,b}, T22891, T22912. + -} + TcRnLoopySuperclassSolve :: CtLoc -- ^ Wanted 'CtLoc' + -> PredType -- ^ Wanted 'PredType' + -> TcRnMessage + deriving Generic -- | Things forbidden in @type data@ declarations. diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs index 5dc3431b9a..60b422e1fc 100644 --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -1633,10 +1633,17 @@ mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc = False can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv -prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... - -> CtLoc -- ^ ... to solve this one? - -> Bool -- ^ True ==> don't solve it --- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2) +-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? +-- +-- Necessary (but not sufficient) conditions for this function to return @True@: +-- +-- - @ct1@ and @ct2@ both arise from superclass expansion, +-- - @ct1@ is a Given and @ct2@ is a Wanted. +-- +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2). +prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... + -> CtLoc -- ^ ... to solve this one? + -> Bool -- ^ True ==> don't solve it prohibitedSuperClassSolve given_loc wanted_loc | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc , blocked diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index e69e7ae0fe..df53e39fcd 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -449,7 +449,7 @@ instance Outputable InteractResult where solveOneFromTheOther :: Ct -- Inert (Dict or Irred) -> Ct -- WorkItem (same predicate as inert) - -> TcS InteractResult + -> InteractResult -- Precondition: -- * inert and work item represent evidence for the /same/ predicate -- * Both are CDictCan or CIrredCan @@ -461,28 +461,28 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred) solveOneFromTheOther ct_i ct_w | CtWanted { ctev_loc = loc_w } <- ev_w , prohibitedSuperClassSolve loc_i loc_w + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance = -- Inert must be Given - do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) - ; return KeepWork } + KeepWork | CtWanted {} <- ev_w = -- Inert is Given or Wanted case ev_i of - CtGiven {} -> return KeepInert + CtGiven {} -> KeepInert -- work is Wanted; inert is Given: easy choice. CtWanted {} -- Both are Wanted -- If only one has no pending superclasses, use it -- Otherwise we can get infinite superclass expansion (#22516) -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> return KeepInert - | is_psc_i, not is_psc_w -> return KeepWork + | not is_psc_i, is_psc_w -> KeepInert + | is_psc_i, not is_psc_w -> KeepWork -- If only one is a WantedSuperclassOrigin (arising from expanding -- a Wanted class constraint), keep the other: wanted superclasses -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> return KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> return KeepWork + | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert + | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork -- otherwise, just choose the lower span -- reason: if we have something like (abs 1) (where the @@ -490,29 +490,28 @@ solveOneFromTheOther ct_i ct_w -- get an error about abs than about 1. -- This test might become more elaborate if we see an -- opportunity to improve the error messages - | ((<) `on` ctLocSpan) loc_i loc_w -> return KeepInert - | otherwise -> return KeepWork + | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert + | otherwise -> KeepWork -- From here on the work-item is Given | CtWanted { ctev_loc = loc_i } <- ev_i , prohibitedSuperClassSolve loc_w loc_i - = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) - ; return KeepInert } -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first + = KeepInert -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first | CtWanted {} <- ev_i - = return KeepWork + = KeepWork -- From here on both are Given -- See Note [Replacement vs keeping] | lvl_i == lvl_w - = return same_level_strategy + = same_level_strategy | otherwise -- Both are Given, levels differ - = return different_level_strategy + = different_level_strategy where ev_i = ctEvidence ct_i ev_w = ctEvidence ct_w @@ -662,14 +661,12 @@ interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) , ((ct_i, swap) : _rest) <- bagToList matching_irreds -- See Note [Multiple matching irreds] , let ev_i = ctEvidence ct_i - = do { what_next <- solveOneFromTheOther ct_i ct_w - ; traceTcS "iteractIrred" $ + = do { traceTcS "iteractIrred" $ vcat [ text "wanted:" <+> (ppr ct_w $$ ppr (ctOrigin ct_w)) - , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) - , ppr what_next ] - ; case what_next of + , text "inert: " <+> (ppr ct_i $$ ppr (ctOrigin ct_i)) ] + ; case solveOneFromTheOther ct_i ct_w of KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } + ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) ; updInertIrreds (\_ -> others) ; continueWith ct_w } } @@ -1007,7 +1004,9 @@ and Given/instance fundeps entirely. interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - , let ev_i = ctEvidence ct_i + , let ev_i = ctEvidence ct_i + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w = -- There is a matching dictionary in the inert set do { -- First to try to solve it /completely/ from top level instances -- See Note [Shortcut solving] @@ -1015,16 +1014,24 @@ interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = t ; short_cut_worked <- shortCutSolver dflags ev_w ev_i ; if short_cut_worked then stopWith ev_w "interactDict/solved from instance" - else - do { -- Ths short-cut solver didn't fire, so we - -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ct_i ct_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) + -- Next see if we are in "loopy-superclass" land. If so, + -- we don't want to replace the (Given) inert with the + -- (Wanted) work-item, or vice versa; we want to hang on + -- to both, and try to solve the work-item via an instance. + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + else if prohibitedSuperClassSolve loc_i loc_w + then continueWith ct_w + else + do { -- The short-cut solver didn't fire, and loopy superclasses + -- are dealt with, so we can either solve + -- the inert from the work-item or vice-versa. + ; case solveOneFromTheOther ct_i ct_w of + KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr ct_w) + ; setEvBindIfWanted ev_w (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> ppr ct_w) } + KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr ct_w) + ; setEvBindIfWanted ev_i (ctEvTerm ev_w) ; updInertDicts $ \ ds -> delDict ds cls tys ; continueWith ct_w } } } @@ -1894,7 +1901,7 @@ as the fundeps. #7875 is a case in point. -} -doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct) +doTopFundepImprovement :: Ct -> TcS () -- Try to functional-dependency improvement between the constraint -- and the top-level instance declarations -- See Note [Fundeps with instances, and equality orientation] @@ -1904,8 +1911,7 @@ doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls = do { traceTcS "try_fundeps" (ppr work_item) ; instEnvs <- getInstEnvs ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis - ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns - ; continueWith work_item } + ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns } where dict_pred = mkClassPred cls xis dict_loc = ctEvLoc ev @@ -2276,14 +2282,35 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls ; chooseInstance work_item lkup_res } _ -> -- NoInstance or NotSure -- We didn't solve it; so try functional dependencies with - -- the instance environment, and return - doTopFundepImprovement work_item } + -- the instance environment + do { doTopFundepImprovement work_item + ; tryLastResortProhibitedSuperclass inerts work_item } } where dict_loc = ctEvLoc ev doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) +-- | As a last resort, we TEMPORARILY allow a prohibited superclass solve, +-- emitting a loud warning when doing so: we might be creating non-terminating +-- evidence (as we are in T22912 for example). +-- +-- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance. +tryLastResortProhibitedSuperclass :: InertSet -> Ct -> TcS (StopOrContinue Ct) +tryLastResortProhibitedSuperclass inerts + work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = xis }) + | let loc_w = ctEvLoc ev_w + orig_w = ctLocOrigin loc_w + , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted + , Just ct_i <- lookupInertDict (inert_cans inerts) loc_w cls xis + , let ev_i = ctEvidence ct_i + , isGiven ev_i + = do { setEvBindIfWanted ev_w (ctEvTerm ev_i) + ; ctLocWarnTcS loc_w $ + TcRnLoopySuperclassSolve loc_w (ctPred work_item) + ; return $ Stop ev_w (text "Loopy superclass") } +tryLastResortProhibitedSuperclass _ work_item + = continueWith work_item chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct) chooseInstance work_item diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index b9a9354eff..7ff59baf4e 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -15,7 +15,7 @@ module GHC.Tc.Solver.Monad ( -- The TcS monad TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts, - failTcS, warnTcS, addErrTcS, wrapTcS, + failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, @@ -673,16 +673,18 @@ lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) lookupInInerts loc pty | ClassPred cls tys <- classifyPredType pty = do { inerts <- getTcSInerts - ; return $ -- Maybe monad - do { found_ev <- - lookupSolvedDict inerts loc cls tys `mplus` - fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys) - ; guard (not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc)) - -- We're about to "solve" the wanted we're looking up, so we - -- must make sure doing so wouldn't run afoul of - -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - -- Forgetting this led to #20666. - ; return found_ev }} + ; let mb_solved = lookupSolvedDict inerts loc cls tys + mb_inert = fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys) + ; return $ do -- Maybe monad + found_ev <- mb_solved `mplus` mb_inert + + -- We're about to "solve" the wanted we're looking up, so we + -- must make sure doing so wouldn't run afoul of + -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. + -- Forgetting this led to #20666. + guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc) + + return found_ev } | otherwise -- NB: No caching for equalities, IPs, holes, or errors = return Nothing @@ -855,6 +857,10 @@ warnTcS msg = wrapTcS (TcM.addDiagnostic msg) addErrTcS = wrapTcS . TcM.addErr panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc +-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. +ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () +ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg + traceTcS :: String -> SDoc -> TcS () traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) {-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 3d9b5dd550..9213ceeab2 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1661,6 +1661,20 @@ Answer: superclass selection, except at a smaller type. This test is implemented by GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve +Note [Migrating away from loopy superclass solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The logic from Note [Solving superclass constraints] was implemented in GHC 9.6. +However, we want to provide a migration strategy for users, to avoid suddenly +breaking their code going when upgrading to GHC 9.6. To this effect, we temporarily +continue to allow the constraint solver to create these potentially non-terminating +solutions, but emit a loud warning when doing so: see +GHC.Tc.Solver.Interact.tryLastResortProhibitedSuperclass. + +Users can silence the warning by manually adding the necessary constraint to the +context. GHC will then keep this user-written Given, dropping the Given arising +from superclass expansion which has greater SC depth, as explained in +Note [Replacement vs keeping] in GHC.Tc.Solver.Interact. + Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB1: this note describes our *old* solution to the diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot index eecb8cb490..a84c44cf4a 100644 --- a/compiler/GHC/Tc/Types/Origin.hs-boot +++ b/compiler/GHC/Tc/Types/Origin.hs-boot @@ -7,4 +7,8 @@ data SkolemInfo data FixedRuntimeRepContext data FixedRuntimeRepOrigin +data CtOrigin +data ClsInstOrQC = IsClsInst + | IsQC CtOrigin + unkSkol :: HasCallStack => SkolemInfo |