X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=cf2974856180d35d367c8ee77ed5844524fe2ca3;hp=0e1e5b0077270ae32d9de49d260c4f28dbb0b7ec;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0 diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 0e1e5b0..cf29748 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -710,6 +710,12 @@ tcSimplifyInfer doc tau_tvs wanted -- irreds2 will be empty. But we don't want to generalise over b! ; let preds2 = fdPredsOfInsts irreds2 -- irreds2 is zonked qtvs = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2 + --------------------------------------------------- + -- BUG WARNING: there's a nasty bug lurking here + -- fdPredsOfInsts may return preds that mention variables quantified in + -- one of the implication constraints in irreds2; and that is clearly wrong: + -- we might quantify over too many variables through accidental capture + --------------------------------------------------- ; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2 ; extendLIEs free @@ -1109,7 +1115,9 @@ checkLoop env wanteds ; env' <- zonkRedEnv env ; wanteds' <- zonkInsts wanteds - ; (improved, binds, irreds) <- reduceContext env' wanteds' + ; (improved, tybinds, binds, irreds) + <- reduceContext env' wanteds' + ; execTcTyVarBinds tybinds ; if null irreds || not improved then return (irreds, binds) @@ -1444,7 +1452,8 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- HOWEVER, some unification may take place, if we instantiate -- a method Inst with an equality constraint ; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe) - ; (_imp, _binds, constrained_dicts) <- reduceContext env wanteds_z + ; (_imp, _tybinds, _binds, constrained_dicts) + <- reduceContext env wanteds_z -- Next, figure out the tyvars we will quantify over ; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs) @@ -1472,13 +1481,6 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds ppr _binds, ppr constrained_tvs', ppr tau_tvs', ppr qtvs ]) - -- Zonk wanteds again! The first call to reduceContext may have - -- instantiated some variables. - -- FIXME: If red_improve would work, we could propagate that into - -- the equality solver, too, to prevent instantating any - -- variables. - ; wanteds_zz <- zonkInsts wanteds_z - -- The first step may have squashed more methods than -- necessary, so try again, this time more gently, knowing the exact -- set of type variables to quantify over. @@ -1500,7 +1502,8 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds (is_nested_group || isDict inst) = Stop | otherwise = ReduceMe env = mkNoImproveRedEnv doc try_me - ; (_imp, binds, irreds) <- reduceContext env wanteds_zz + ; (_imp, tybinds, binds, irreds) <- reduceContext env wanteds_z + ; execTcTyVarBinds tybinds -- See "Notes on implicit parameters, Question 4: top level" ; ASSERT( all (isFreeWrtTyVars qtvs) irreds ) -- None should be captured @@ -1677,7 +1680,8 @@ tcSimplifyIPs given_ips wanteds -- Unusually for checking, we *must* zonk the given_ips ; let env = mkRedEnv doc try_me given_ips' - ; (improved, binds, irreds) <- reduceContext env wanteds' + ; (improved, tybinds, binds, irreds) <- reduceContext env wanteds' + ; execTcTyVarBinds tybinds ; if null irreds || not improved then ASSERT( all is_free irreds ) @@ -1866,6 +1870,7 @@ discharge with the explicit instance. reduceContext :: RedEnv -> [Inst] -- Wanted -> TcM (ImprovementDone, + TcTyVarBinds, -- Type variable bindings TcDictBinds, -- Dictionary bindings [Inst]) -- Irreducible @@ -1892,10 +1897,11 @@ reduceContext env wanteds0 givens = red_givens env ; (givens', wanteds', - normalise_binds, - eq_improved) <- tcReduceEqs givens wanteds + tybinds, + normalise_binds) <- tcReduceEqs givens wanteds ; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat - [ppr givens', ppr wanteds', ppr normalise_binds] + [ppr givens', ppr wanteds', ppr tybinds, + ppr normalise_binds] -- Build the Avail mapping from "given_dicts" ; (init_state, _) <- getLIE $ do @@ -1935,7 +1941,7 @@ reduceContext env wanteds0 -- Collect all irreducible instances, and determine whether we should -- go round again. We do so in either of two cases: -- (1) If dictionary reduction or equality solving led to - -- improvement (i.e., instantiated type variables). + -- improvement (i.e., bindings for type variables). -- (2) If we reduced dictionaries (i.e., got dictionary bindings), -- they may have exposed further opportunities to normalise -- family applications. See Note [Dictionary Improvement] @@ -1948,6 +1954,7 @@ reduceContext env wanteds0 ; let all_irreds = dict_irreds ++ implic_irreds ++ extra_eqs avails_improved = availsImproved avails + eq_improved = anyBag (not . isCoVarBind) tybinds improvedFlexible = avails_improved || eq_improved reduced_dicts = not (isEmptyBag dict_binds) improved = improvedFlexible || reduced_dicts @@ -1961,6 +1968,7 @@ reduceContext env wanteds0 text "given" <+> ppr givens, text "wanted" <+> ppr wanteds0, text "----", + text "tybinds" <+> ppr tybinds, text "avails" <+> pprAvails avails, text "improved =" <+> ppr improved <+> text improvedHint, text "(all) irreds = " <+> ppr all_irreds, @@ -1970,10 +1978,13 @@ reduceContext env wanteds0 ])) ; return (improved, + tybinds, normalise_binds `unionBags` dict_binds `unionBags` implic_binds, all_irreds) } + where + isCoVarBind (TcTyVarBind tv _) = isCoVar tv tcImproveOne :: Avails -> Inst -> TcM ImprovementDone tcImproveOne avails inst @@ -2845,6 +2856,7 @@ disambiguate doc interactive dflags insts where extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags + -- See also Trac #1974 ovl_strings = dopt Opt_OverloadedStrings dflags unaries :: [(Inst, Class, TcTyVar)] -- (C tv) constraints @@ -2891,12 +2903,16 @@ disambigGroup :: [Type] -- The default types -> TcM () -- Just does unification, to fix the default types disambigGroup default_tys dicts - = try_default default_tys + = do { mb_chosen_ty <- try_default default_tys + ; case mb_chosen_ty of + Nothing -> return () + Just chosen_ty -> do { unifyType chosen_ty (mkTyVarTy tyvar) + ; warnDefault dicts chosen_ty } } where (_,_,tyvar) = ASSERT(not (null dicts)) head dicts -- Should be non-empty classes = [c | (_,c,_) <- dicts] - try_default [] = return () + try_default [] = return Nothing try_default (default_ty : default_tys) = tryTcLIE_ (try_default default_tys) $ do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes] @@ -2906,10 +2922,7 @@ disambigGroup default_tys dicts -- For example, if Real a is reqd, but the only type in the -- default list is Int. - -- After this we can't fail - ; warnDefault dicts default_ty - ; unifyType default_ty (mkTyVarTy tyvar) - ; return () -- TOMDO: do something with the coercion + ; return (Just default_ty) -- TOMDO: do something with the coercion }