diff options
Diffstat (limited to 'compiler/GHC/Tc/Solver')
| -rw-r--r-- | compiler/GHC/Tc/Solver/Dict.hs | 46 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/InertSet.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 4 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Types.hs | 24 |
4 files changed, 46 insertions, 49 deletions
diff --git a/compiler/GHC/Tc/Solver/Dict.hs b/compiler/GHC/Tc/Solver/Dict.hs index f0303a9aa0..ac5f3aae25 100644 --- a/compiler/GHC/Tc/Solver/Dict.hs +++ b/compiler/GHC/Tc/Solver/Dict.hs @@ -106,8 +106,10 @@ solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } updInertDicts :: DictCt -> TcS () -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev }) - = do { -- See Note [Shadowing of Implicit Parameters] +updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) + + -- See Note [Shadowing of Implicit Parameters] ; when (isGiven ev && isIPClass cls) $ updInertCans (updDicts (delIPDict dict_ct)) @@ -195,7 +197,24 @@ in two places: (?x :: ty) in the inert set and an identical (?x :: ty) as the work item. * In `updInertDicts` in this module, when adding [G] (?x :: ty), remove any - existing [G] (?x :: ty'), regardless of ty' + existing [G] (?x :: ty'), regardless of ty'. + +* Wrinkle (SIP1): we must be careful of superclasses. Consider + f,g :: (?x::Int, C a) => a -> a + f v = let ?x = 4 in g v + + The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). + We must /not/ solve this from the Given (?x::Int, C a), because of + the intervening binding for (?x::Int). #14218. + + We deal with this by arranging that when we add [G] (?x::ty) we delete any + existing [G] (?x::ty) /and/ any [G] C tys, where (C tys) has a superclass + with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. + An important special case is constraint tuples like [G] (% ?x::ty, Eq a ) + +* Wrinkle (SIP2): we delete dictionaries in inert_dicts, but we don't need to + look in inert_solved_dicts. They are never implicit parameters. See + Note [Solved dictionaries] in GHC.Tc.Solver.InertSet Example 1: @@ -248,13 +267,14 @@ behaviour. All this works for the normal cases but it has an odd side effect in some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x + -- This is accepted, the second parameter shadows + f1 :: (?x :: Int, ?x :: Char) => Char + f1 = ?x + + -- This is rejected, the second parameter shadows + f2 :: (?x :: Int, ?x :: Char) => Int + f2 = ?x Both of these are actually wrong: when we try to use either one, we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), @@ -618,7 +638,8 @@ try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys ; continueWith () } } } | otherwise - = continueWith () + = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys) + ; continueWith () } -- See Note [Shortcut solving] shortCutSolver :: DynFlags @@ -810,9 +831,10 @@ matchClassInst dflags inerts clas tys loc -- whether top level, or local quantified constraints. -- See Note [Instance and Given overlap] | not (xopt LangExt.IncoherentInstances dflags) + , not (isCTupleClass clas) -- It is always safe to unpack constraint tuples , not (noMatchableGivenDicts inerts loc clas tys) = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys ] + vcat [ text "Work item:" <+> pprClassPred clas tys ] ; return NotSure } | otherwise @@ -989,7 +1011,7 @@ The same reasoning applies to And less obviously to: * Tuple classes. For reasons described in GHC.Tc.Solver.Types - Note [Tuples hiding implicit parameters], we may have a constraint + Note [Shadowing of implicit parameters], we may have a constraint [W] (?x::Int, C a) with an exactly-matching Given constraint. We must decompose this tuple and solve the components separately, otherwise we won't solve diff --git a/compiler/GHC/Tc/Solver/InertSet.hs b/compiler/GHC/Tc/Solver/InertSet.hs index 1b85fdab0c..f621de211b 100644 --- a/compiler/GHC/Tc/Solver/InertSet.hs +++ b/compiler/GHC/Tc/Solver/InertSet.hs @@ -79,6 +79,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Maybe import GHC.Data.Bag +import GHC.Data.FastString import Data.List.NonEmpty ( NonEmpty(..), (<|) ) import qualified Data.List.NonEmpty as NE @@ -321,6 +322,7 @@ data InertSet , inert_solved_dicts :: DictMap CtEvidence -- All Wanteds, of form (C t1 .. tn) + -- Always a dictionary solved by an instance decl; never an implict parameter -- See Note [Solved dictionaries] -- and Note [Do not add superclasses of solved dictionaries] } @@ -1323,20 +1325,15 @@ delDict (DictCt { di_cls = cls, di_tys = tys }) m = delTcApp m (classTyCon cls) tys delIPDict :: DictCt -> DictMap DictCt -> DictMap DictCt -delIPDict (DictCt { di_cls = cls, di_tys = tys }) m - | [ip_str, _] <- tys - = assert (isIPClass cls) $ - filterDicts (doesn't_match ip_str) m +delIPDict dict@(DictCt { di_cls = cls, di_tys = tys }) dict_map + | Just (fs, _) <- isIPPred_maybe cls tys + = filterDicts (doesn't_match fs) dict_map | otherwise - = m + = pprPanic "delIPDict" (ppr dict) where - doesn't_match :: TcType -> DictCt -> Bool - doesn't_match ip_str (DictCt { di_cls = cls, di_tys = tys }) - | isIPClass cls - , [ip_str', _] <- tys - = not (ip_str `eqType` ip_str') - | otherwise - = True + doesn't_match :: FastString -> DictCt -> Bool + doesn't_match fs (DictCt { di_cls = cls, di_tys = tys }) + = not (mentionsIP fs cls tys) addDict :: DictCt -> DictMap DictCt -> DictMap DictCt addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index d385d27b29..c89a9f282b 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -707,9 +707,7 @@ lookupInInerts loc pty -- | Look up a dictionary inert. lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe DictCt lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just ct - _ -> Nothing + = findDict dicts loc cls tys -- | Look up a solved inert. lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence diff --git a/compiler/GHC/Tc/Solver/Types.hs b/compiler/GHC/Tc/Solver/Types.hs index 0d34022df7..d47eef71b7 100644 --- a/compiler/GHC/Tc/Solver/Types.hs +++ b/compiler/GHC/Tc/Solver/Types.hs @@ -133,9 +133,6 @@ emptyDictMap = emptyTcAppMap findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a findDict m loc cls tys - | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters] - = Nothing - | Just {} <- isCallStackPred cls tys , isPushCallStackOrigin (ctLocOrigin loc) = Nothing -- See Note [Solving CallStack constraints] @@ -157,25 +154,8 @@ dictsToBag = tcAppMapToBag foldDicts :: (a -> b -> b) -> DictMap a -> b -> b foldDicts = foldTcAppMap -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f,g :: (?x::Int, C a) => a -> a - f v = let ?x = 4 in g v - -The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). -We must /not/ solve this from the Given (?x::Int, C a), because of -the intervening binding for (?x::Int). #14218. - -We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Note that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Solving CallStack constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence. Suppose f :: HasCallStack => blah. Then |