diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/VarEnv.hs | 5 | ||||
| -rw-r--r-- | compiler/typecheck/TcEvidence.hs | 7 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.hs | 33 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 6 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 46 | ||||
| -rw-r--r-- | compiler/typecheck/TcSMonad.hs | 36 | ||||
| -rw-r--r-- | compiler/typecheck/TcSimplify.hs | 247 | ||||
| -rw-r--r-- | compiler/typecheck/TcUnify.hs | 17 |
8 files changed, 234 insertions, 163 deletions
diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs index f8ab574bc5..2c50e8dcbf 100644 --- a/compiler/basicTypes/VarEnv.hs +++ b/compiler/basicTypes/VarEnv.hs @@ -34,7 +34,7 @@ module VarEnv ( extendDVarEnvList, lookupDVarEnv, elemDVarEnv, isEmptyDVarEnv, foldDVarEnv, - mapDVarEnv, + mapDVarEnv, filterDVarEnv, modifyDVarEnv, alterDVarEnv, plusDVarEnv, plusDVarEnv_C, @@ -557,6 +557,9 @@ foldDVarEnv = foldUDFM mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b mapDVarEnv = mapUDFM +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a alterDVarEnv = alterUDFM diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 0287818b44..249362dde5 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -13,7 +13,8 @@ module TcEvidence ( -- Evidence bindings TcEvBinds(..), EvBindsVar(..), EvBindMap(..), emptyEvBindMap, extendEvBinds, - lookupEvBind, evBindMapBinds, foldEvBindMap, isEmptyEvBindMap, + lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, + isEmptyEvBindMap, EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, sccEvBinds, evBindVar, EvTerm(..), mkEvCast, evVarsOfTerm, mkEvScSelectors, @@ -442,6 +443,10 @@ evBindMapBinds = foldEvBindMap consBag emptyBag foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) +filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap +filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) + = EvBindMap { ev_bind_varenv = filterDVarEnv k env } + instance Outputable EvBindMap where ppr (EvBindMap m) = ppr m diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 6580758788..e5960cb1b1 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -843,16 +843,14 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , sc_implics `unionBags` meth_implics ) } ; env <- getLclEnv - ; emitImplication $ Implic { ic_tclvl = tclvl - , ic_skols = inst_tyvars - , ic_no_eqs = False - , ic_given = dfun_ev_vars - , ic_wanted = mkImplicWC sc_meth_implics - , ic_status = IC_Unsolved - , ic_binds = dfun_ev_binds_var - , ic_needed = emptyVarSet - , ic_env = env - , ic_info = InstSkol } + ; emitImplication $ + newImplication { ic_tclvl = tclvl + , ic_skols = inst_tyvars + , ic_given = dfun_ev_vars + , ic_wanted = mkImplicWC sc_meth_implics + , ic_binds = dfun_ev_binds_var + , ic_env = env + , ic_info = InstSkol } -- Create the result bindings ; self_dict <- newDict clas inst_tys @@ -1062,16 +1060,11 @@ checkInstConstraints thing_inside ; ev_binds_var <- newTcEvBinds ; env <- getLclEnv - ; let implic = Implic { ic_tclvl = tclvl - , ic_skols = [] - , ic_no_eqs = False - , ic_given = [] - , ic_wanted = wanted - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_needed = emptyVarSet - , ic_env = env - , ic_info = InstSkol } + ; let implic = newImplication { ic_tclvl = tclvl + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = InstSkol } ; return (implic, ev_binds_var, result) } diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 5bc200c1a0..184093f066 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -90,7 +90,7 @@ module TcRnMonad( -- * Type constraints newTcEvBinds, addTcEvBind, - getTcEvTyCoVars, getTcEvBindsMap, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, @@ -1372,6 +1372,10 @@ getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) = readTcRef ev_ref +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM () +setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds + = writeTcRef ev_ref binds + addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 4d7a8e8390..7766a38aa1 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -90,7 +90,8 @@ module TcRnTypes( isDroppableDerivedLoc, isDroppableDerivedCt, insolubleImplic, arisesFromGivens, - Implication(..), ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + Implication(..), newImplication, + ImplicStatus(..), isInsolubleStatus, isSolvedStatus, SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, @@ -2414,17 +2415,38 @@ data Implication ic_binds :: EvBindsVar, -- Points to the place to fill in the -- abstraction and bindings. - ic_needed :: VarSet, -- Union of the ics_need fields of any /discarded/ - -- solved implications in ic_wanted + -- The ic_need fields keep track of which Given evidence + -- is used by this implication or its children + -- NB: including stuff used by nested implications that have since + -- been discarded + ic_need_inner :: VarSet, -- Includes all used Given evidence + ic_need_outer :: VarSet, -- Includes only the free Given evidence + -- i.e. ic_need_inner after deleting + -- (a) givens (b) binders of ic_binds ic_status :: ImplicStatus } +newImplication :: Implication +newImplication + = Implic { -- These fields must be initialisad + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + , ic_env = panic "newImplic:env" + + -- The rest have sensible default values + , ic_skols = [] + , ic_given = [] + , ic_wanted = emptyWC + , ic_no_eqs = False + , ic_status = IC_Unsolved + , ic_need_inner = emptyVarSet + , ic_need_outer = emptyVarSet } + data ImplicStatus = IC_Solved -- All wanteds in the tree are solved, all the way down - { ics_need :: VarSet -- Evidence variables bound further out, - -- but needed by this solved implication - , ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed -- See Note [Tracking redundant constraints] in TcSimplify | IC_Insoluble -- At least one insoluble constraint in the tree @@ -2435,7 +2457,8 @@ instance Outputable Implication where ppr (Implic { ic_tclvl = tclvl, ic_skols = skols , ic_given = given, ic_no_eqs = no_eqs , ic_wanted = wanted, ic_status = status - , ic_binds = binds, ic_needed = needed , ic_info = info }) + , ic_binds = binds, ic_need_inner = need_in + , ic_need_outer = need_out, ic_info = info }) = hang (text "Implic" <+> lbrace) 2 (sep [ text "TcLevel =" <+> ppr tclvl , text "Skolems =" <+> pprTyVars skols @@ -2444,16 +2467,15 @@ instance Outputable Implication where , hang (text "Given =") 2 (pprEvVars given) , hang (text "Wanted =") 2 (ppr wanted) , text "Binds =" <+> ppr binds - , text "Needed =" <+> ppr needed + , text "Needed inner =" <+> ppr need_in + , text "Needed outer =" <+> ppr need_out , pprSkolInfo info ] <+> rbrace) instance Outputable ImplicStatus where ppr IC_Insoluble = text "Insoluble" ppr IC_Unsolved = text "Unsolved" - ppr (IC_Solved { ics_need = vs, ics_dead = dead }) - = text "Solved" - <+> (braces $ vcat [ text "Dead givens =" <+> ppr dead - , text "Needed =" <+> ppr vs ]) + ppr (IC_Solved { ics_dead = dead }) + = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) {- Note [Needed evidence variables] diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 41a50976a0..d79a8a465a 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -42,9 +42,8 @@ module TcSMonad ( getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getLclEnv, getTcEvBindsVar, getTcLevel, - getTcEvBindsAndTCVs, getTcEvBindsMap, - tcLookupClass, - tcLookupId, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, -- Inerts InertSet(..), InertCans(..), @@ -2636,16 +2635,13 @@ buildImplication skol_info skol_tvs givens (TcS thing_inside) null (wl_deriv wl) && null (wl_implics wl), ppr wl ) WC { wc_simple = listToCts eqs , wc_impl = emptyBag } - imp = Implic { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_no_eqs = True - , ic_given = givens - , ic_wanted = wc - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_env = env - , ic_needed = emptyVarSet - , ic_info = skol_info } + imp = newImplication { ic_tclvl = new_tclvl + , ic_skols = skol_tvs + , ic_given = givens + , ic_wanted = wc + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } ; return (unitBag imp, TcEvBinds ev_binds_var, res) } } {- @@ -2718,16 +2714,18 @@ getTcEvBindsVar = TcS (return . tcs_ev_binds) getTcLevel :: TcS TcLevel getTcLevel = wrapTcS TcM.getTcLevel -getTcEvBindsAndTCVs :: EvBindsVar -> TcS (EvBindMap, TyCoVarSet) -getTcEvBindsAndTCVs ev_binds_var - = wrapTcS $ do { bnds <- TcM.getTcEvBindsMap ev_binds_var - ; tcvs <- TcM.getTcEvTyCoVars ev_binds_var - ; return (bnds, tcvs) } +getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet +getTcEvTyCoVars ev_binds_var + = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap getTcEvBindsMap ev_binds_var = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () +setTcEvBindsMap ev_binds_var binds + = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds + unifyTyVar :: TcTyVar -> TcType -> TcS () -- Unify a meta-tyvar with a type -- We keep track of how many unifications have happened in tcs_unified, @@ -2883,7 +2881,7 @@ newFlattenSkolem flav loc tc xis ---------------------------- unflattenGivens :: IORef InertSet -> TcM () -- Unflatten all the fsks created by flattening types in Given --- constraints We must be sure to do this, else we end up with +-- constraints. We must be sure to do this, else we end up with -- flatten-skolems buried in any residual Wanteds -- -- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv) diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index f1d7e9ade8..76765f7396 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -28,7 +28,6 @@ import DynFlags ( WarningFlag ( Opt_WarnMonomorphism ) import Id ( idType ) import Inst import ListSetOps -import Maybes import Name import Outputable import PrelInfo @@ -722,16 +721,13 @@ emitResidualConstraints rhs_tclvl tc_lcl_env ev_binds_var } where mk_implic inner_wanted - = Implic { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_no_eqs = False - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_info = skol_info - , ic_needed = emptyVarSet - , ic_env = tc_lcl_env } + = newImplication { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_info = skol_info + , ic_env = tc_lcl_env } full_theta = map idType full_theta_vars skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) @@ -1540,7 +1536,8 @@ solveImplication imp@(Implic { ic_tclvl = tclvl ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs , ic_wanted = final_wanted }) - ; (evbinds, tcvs) <- TcS.getTcEvBindsAndTCVs ev_binds_var + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var ; traceTcS "solveImplication end }" $ vcat [ text "no_given_eqs =" <+> ppr no_given_eqs , text "floated_eqs =" <+> ppr floated_eqs @@ -1557,97 +1554,75 @@ setImplicationStatus :: Implication -> TcS (Maybe Implication) -- * Trim the ic_wanted field to remove Derived constraints -- Precondition: the ic_status field is not already IC_Solved -- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_binds = ev_binds_var - , ic_status = status +setImplicationStatus implic@(Implic { ic_status = status , ic_info = info , ic_wanted = wc - , ic_needed = old_discarded_needs , ic_given = givens }) | ASSERT2( not (isSolvedStatus status ), ppr info ) -- Precondition: we only set the status if it is not already solved - some_insoluble - = return $ Just $ - implic { ic_status = IC_Insoluble - , ic_needed = new_discarded_needs - , ic_wanted = pruned_wc } - - | some_unsolved - = do { traceTcS "setImplicationStatus" $ - vcat [ppr givens $$ ppr simples $$ ppr mb_implic_needs] - ; return $ Just $ - implic { ic_status = IC_Unsolved - , ic_needed = new_discarded_needs - , ic_wanted = pruned_wc } - } - - | otherwise -- Everything is solved; look at the implications + not all_solved + = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) + + ; implic <- neededEvVars implic + + ; let new_status | insolubleWC pruned_wc = IC_Insoluble + | otherwise = IC_Unsolved + new_implic = implic { ic_status = new_status + , ic_wanted = pruned_wc } + + ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) + + ; return $ Just new_implic } + + | otherwise -- Everything is solved + -- Set status to IC_Solved, + -- and compute the dead givens and outer needs -- See Note [Tracking redundant constraints] - = do { ev_binds <- TcS.getTcEvBindsAndTCVs ev_binds_var - ; let all_needs = neededEvVars ev_binds $ - solved_implic_needs `unionVarSet` new_discarded_needs + = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) - dead_givens | warnRedundantGivens info - = filterOut (`elemVarSet` all_needs) givens - | otherwise = [] -- None to report + ; implic <- neededEvVars implic - final_needs = all_needs `delVarSetList` givens + ; let dead_givens | warnRedundantGivens info + = filterOut (`elemVarSet` ic_need_inner implic) givens + | otherwise = [] -- None to report discard_entire_implication -- Can we discard the entire implication? = null dead_givens -- No warning from this implication && isEmptyBag pruned_implics -- No live children - && isEmptyVarSet final_needs -- No needed vars to pass up to parent + && isEmptyVarSet (ic_need_outer implic) -- No needed vars to pass up to parent - final_status = IC_Solved { ics_need = final_needs - , ics_dead = dead_givens } + final_status = IC_Solved { ics_dead = dead_givens } final_implic = implic { ic_status = final_status - , ic_needed = emptyVarSet -- Irrelevant for IC_Solved , ic_wanted = pruned_wc } - -- Check that there are no term-level evidence bindings - -- in the cases where we have no place to put them - ; MASSERT2( termEvidenceAllowed info || isEmptyEvBindMap (fst ev_binds) - , ppr info $$ ppr ev_binds ) + ; traceTcS "setImplicationStatus(all-solved) }" $ + vcat [ text "discard:" <+> ppr discard_entire_implication + , text "new_implic:" <+> ppr final_implic ] - ; traceTcS "setImplicationStatus 2" $ - vcat [ppr givens $$ ppr ev_binds $$ ppr all_needs] ; return $ if discard_entire_implication then Nothing else Just final_implic } where WC { wc_simple = simples, wc_impl = implics } = wc - some_insoluble = insolubleWC wc - some_unsolved = not (isEmptyBag simples) - || isNothing mb_implic_needs - pruned_simples = dropDerivedSimples simples - (pruned_implics, discarded_needs) = partitionBagWith discard_me implics - pruned_wc = wc { wc_simple = pruned_simples + pruned_implics = filterBag keep_me implics + pruned_wc = WC { wc_simple = pruned_simples , wc_impl = pruned_implics } - new_discarded_needs = foldrBag unionVarSet old_discarded_needs discarded_needs - - mb_implic_needs :: Maybe VarSet - -- Just vs => all implics are IC_Solved, with 'vs' needed - -- Nothing => at least one implic is not IC_Solved - mb_implic_needs = foldrBag add_implic (Just emptyVarSet) pruned_implics - Just solved_implic_needs = mb_implic_needs - - add_implic implic acc - | Just vs_acc <- acc - , IC_Solved { ics_need = vs } <- ic_status implic - = Just (vs `unionVarSet` vs_acc) - | otherwise = Nothing - - discard_me :: Implication -> Either Implication VarSet - discard_me ic - | IC_Solved { ics_dead = dead_givens, ics_need = needed } <- ic_status ic + + all_solved = isEmptyBag pruned_simples + && allBag (isSolvedStatus . ic_status) pruned_implics + + keep_me :: Implication -> Bool + keep_me ic + | IC_Solved { ics_dead = dead_givens } <- ic_status ic -- Fully solved , null dead_givens -- No redundant givens to report , isEmptyBag (wc_impl (ic_wanted ic)) -- And no children that might have things to report - = Right needed + = False -- Tnen we don't need to keep it | otherwise - = Left ic + = True -- Otherwise, keep it warnRedundantGivens :: SkolemInfo -> Bool warnRedundantGivens (SigSkol ctxt _ _) @@ -1661,38 +1636,82 @@ warnRedundantGivens (SigSkol ctxt _ _) warnRedundantGivens (InstSkol {}) = True warnRedundantGivens _ = False -neededEvVars :: (EvBindMap, TcTyVarSet) -> VarSet -> VarSet +neededEvVars :: Implication -> TcS Implication -- Find all the evidence variables that are "needed", --- and then delete all those bound by the evidence bindings --- See Note [Tracking redundant constraints] +-- and delete dead evidence bindings +-- See Note [Tracking redundant constraints] +-- See Note [Delete dead Given evidence bindings] -- -- - Start from initial_seeds (from nested implications) +-- -- - Add free vars of RHS of all Wanted evidence bindings -- and coercion variables accumulated in tcvs (all Wanted) --- - Do transitive closure through Given bindings --- e.g. Neede {a,b} +-- +-- - Generate 'needed', the needed set of EvVars, by doing transitive +-- closure through Given bindings +-- e.g. Needed {a,b} -- Given a = sc_sel a2 -- Then a2 is needed too --- - Finally delete all the binders of the evidence bindings -- -neededEvVars (ev_binds, tcvs) initial_seeds - = needed `minusVarSet` bndrs +-- - Prune out all Given bindings that are not needed +-- +-- - From the 'needed' set, delete ev_bndrs, the binders of the +-- evidence bindings, to give the final needed variables +-- +neededEvVars implic@(Implic { ic_info = info + , ic_given = givens + , ic_binds = ev_binds_var + , ic_wanted = WC { wc_impl = implics } + , ic_need_inner = old_needs }) + = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + + -- Check that there are no term-level evidence bindings + -- in the cases where we have no place to put them + ; MASSERT2( termEvidenceAllowed info || isEmptyEvBindMap ev_binds + , ppr info $$ ppr ev_binds ) + + ; let seeds1 = foldrBag add_implic_seeds old_needs implics + seeds2 = foldEvBindMap add_wanted seeds1 ev_binds + seeds3 = seeds2 `unionVarSet` tcvs + need_inner = transCloVarSet (also_needs ev_binds) seeds3 + live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds + need_outer = foldEvBindMap del_ev_bndr need_inner live_ev_binds + `delVarSetList` givens + + ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds + -- See Note [Delete dead Given evidence bindings] + + ; traceTcS "neededEvVars" $ + vcat [ text "old_needs:" <+> ppr old_needs + , text "seeds3:" <+> ppr seeds3 + , text "ev_binds:" <+> ppr ev_binds + , text "live_ev_binds:" <+> ppr live_ev_binds ] + + ; return (implic { ic_need_inner = need_inner + , ic_need_outer = need_outer }) } where - needed = transCloVarSet also_needs seeds - seeds = foldEvBindMap add_wanted initial_seeds ev_binds - `unionVarSet` tcvs - bndrs = foldEvBindMap add_bndr emptyVarSet ev_binds + add_implic_seeds (Implic { ic_need_outer = needs, ic_given = givens }) acc + = (needs `delVarSetList` givens) `unionVarSet` acc + + needed_ev_bind needed (EvBind { eb_lhs = ev_var + , eb_is_given = is_given }) + | is_given = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings + + del_ev_bndr :: EvBind -> VarSet -> VarSet + del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v add_wanted :: EvBind -> VarSet -> VarSet add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs | is_given = needs -- Add the rhs vars of the Wanted bindings only | otherwise = evVarsOfTerm rhs `unionVarSet` needs - also_needs :: VarSet -> VarSet - also_needs needs + also_needs :: EvBindMap -> VarSet -> VarSet + also_needs ev_binds needs = nonDetFoldUniqSet add emptyVarSet needs - -- It's OK to use nonDetFoldUFM here because we immediately forget - -- about the ordering by creating a set + -- It's OK to use nonDetFoldUFM here because we immediately + -- forget about the ordering by creating a set where add v needs | Just ev_bind <- lookupEvBind ev_binds v @@ -1702,11 +1721,43 @@ neededEvVars (ev_binds, tcvs) initial_seeds | otherwise = needs - add_bndr :: EvBind -> VarSet -> VarSet - add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v - +{- Note [Delete dead Given evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a result of superclass expansion, we speculatively +generate evidence bindings for Givens. E.g. + f :: (a ~ b) => a -> b -> Bool + f x y = ... +We'll have + [G] d1 :: (a~b) +and we'll specuatively generate the evidence binding + [G] d2 :: (a ~# b) = sc_sel d + +Now d2 is available for solving. But it may not be needed! Usually +such dead superclass selections will eventually be dropped as dead +code, but: + + * It won't always be dropped (Trac #13032). In the case of an + unlifted-equality superclass like d2 above, we generate + case heq_sc d1 of d2 -> ... + and we can't (in general) drop that case exrpession in case + d1 is bottom. So it's technically unsound to have added it + in the first place. + + * Simply generating all those extra superclasses can generate lots of + code that has to be zonked, only to be discarded later. Better not + to generate it in the first place. + + Moreover, if we simplify this implication more than once + (e.g. because we can't solve it completely on the first iteration + of simpl_looop), we'll generate all the same bindings AGAIN! + +Easy solution: take advantage of the work we are doing to track dead +(unused) Givens, and use it to prune the Given bindings too. This is +all done by neededEvVars. + +This led to a remarkable 25% overall compiler allocation decrease in +test T12227. -{- Note [Tracking redundant constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With Opt_WarnRedundantConstraints, GHC can report which @@ -1743,18 +1794,16 @@ works: ----- How tracking works +* The ic_need fields of an Implic records in-scope (given) evidence + variables bound by the context, that were needed to solve this + implication (so far). See the declaration of Implication. + * When the constraint solver finishes solving all the wanteds in an implication, it sets its status to IC_Solved - The ics_dead field, of IC_Solved, records the subset of this implication's ic_given that are redundant (not needed). - - The ics_need field of IC_Solved then records all the - in-scope (given) evidence variables bound by the context, that - were needed to solve this implication, including all its nested - implications. (We remove the ic_given of this implication from - the set, of course.) - * We compute which evidence variables are needed by an implication in setImplicationStatus. A variable is needed if a) it is free in the RHS of a Wanted EvBind, diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index fc2763ab1b..2c374285fc 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -1186,16 +1186,13 @@ buildImplicationFor tclvl skol_info skol_tvs given wanted = ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs ) do { ev_binds_var <- newTcEvBinds ; env <- getLclEnv - ; let implic = Implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_no_eqs = False - , ic_given = given - , ic_wanted = wanted - , ic_status = IC_Unsolved - , ic_binds = ev_binds_var - , ic_env = env - , ic_needed = emptyVarSet - , ic_info = skol_info } + ; let implic = newImplication { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_env = env + , ic_info = skol_info } ; return (unitBag implic, TcEvBinds ev_binds_var) } |