X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=ff51c425b321c31d51fb536d4c99142d482cfea8;hb=f8031f577f9667ef1ab439b11fdd15fc39a79630;hp=6f8ed08abd6b6e28aec13c06d638d20c02032f84;hpb=3355c9d53b220ccb110e5a3c81a1a8b2c9c41555;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 6f8ed08..ff51c42 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -50,10 +50,11 @@ import Id ( idType, mkUserLocal ) import Var ( TyVar ) import Name ( getOccName, getSrcLoc ) import NameSet ( NameSet, mkNameSet, elemNameSet ) -import Class ( classBigSig ) +import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) -import PrelNames ( splitName, fstName, sndName ) +import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey) +import HscTypes ( GhciMode(Interactive) ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import TysWiredIn ( unitTy, pairTyCon ) @@ -63,6 +64,7 @@ import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) +import Unique ( hasKey ) import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts @@ -569,6 +571,7 @@ inferLoop doc tau_tvs wanteds | isClassDict inst = DontReduceUnlessConstant -- Dicts | otherwise = ReduceMe -- Lits and Methods in + traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` -- Step 2 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> @@ -741,7 +744,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie = -- Step 1 mappM zonkInst givens `thenM` \ givens' -> mappM zonkInst wanteds `thenM` \ wanteds' -> - get_qtvs `thenM` \ qtvs' -> + get_qtvs `thenM` \ qtvs' -> -- Step 2 let @@ -785,14 +788,13 @@ tcSimplifyRestricted doc tau_tvs wanteds -- foo = f (3::Int) -- We want to infer the polymorphic type -- foo :: forall b. b -> b - let - try_me inst = ReduceMe -- Reduce as far as we can. Don't stop at - -- dicts; the idea is to get rid of as many type - -- variables as possible, and we don't want to stop - -- at (say) Monad (ST s), because that reduces - -- immediately, with no constraint on s. - in - simpleReduceLoop doc try_me wanteds `thenM` \ (_, _, constrained_dicts) -> + + -- 'reduceMe': Reduce as far as we can. Don't stop at + -- dicts; the idea is to get rid of as many type + -- variables as possible, and we don't want to stop + -- at (say) Monad (ST s), because that reduces + -- immediately, with no constraint on s. + simpleReduceLoop doc reduceMe wanteds `thenM` \ (foo_frees, foo_binds, constrained_dicts) -> -- Next, figure out the tyvars we will quantify over zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> @@ -802,6 +804,10 @@ tcSimplifyRestricted doc tau_tvs wanteds qtvs = (tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs) `minusVarSet` constrained_tvs in + traceTc (text "tcSimplifyRestricted" <+> vcat [ + pprInsts wanteds, pprInsts foo_frees, pprInsts constrained_dicts, + ppr foo_binds, + ppr constrained_tvs, ppr tau_tvs', ppr qtvs ]) `thenM_` -- The first step may have squashed more methods than -- necessary, so try again, this time knowing the exact @@ -816,19 +822,28 @@ tcSimplifyRestricted doc tau_tvs wanteds -- Remember that we may need to do *some* simplification, to -- (for example) squash {Monad (ST s)} into {}. It's not enough -- just to float all constraints - mappM zonkInst wanteds `thenM` \ wanteds' -> + restrict_loop doc qtvs wanteds + -- We still need a loop because improvement can take place + -- E.g. if we have (C (T a)) and the instance decl + -- instance D Int b => C (T a) where ... + -- and there's a functional dependency for D. Then we may improve + -- the tyep variable 'b'. + +restrict_loop doc qtvs wanteds + = mappM zonkInst wanteds `thenM` \ wanteds' -> + zonkTcTyVarsAndFV (varSetElems qtvs) `thenM` \ qtvs' -> let - try_me inst | isFreeWrtTyVars qtvs inst = Free - | otherwise = ReduceMe + try_me inst | isFreeWrtTyVars qtvs' inst = Free + | otherwise = ReduceMe in reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> - ASSERT( no_improvement ) - ASSERT( null irreds ) - -- No need to loop because simpleReduceLoop will have - -- already done any improvement necessary - - extendLIEs frees `thenM_` - returnM (varSetElems qtvs, binds) + if no_improvement then + ASSERT( null irreds ) + extendLIEs frees `thenM_` + returnM (varSetElems qtvs', binds) + else + restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) -> + returnM (qtvs1, binds `AndMonoBinds` binds1) \end{code} @@ -907,12 +922,10 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = simpleReduceLoop doc try_me wanteds `thenM_` + = simpleReduceLoop doc reduceMe wanteds `thenM_` returnM () - where - doc = text "tcSimplifyBracket" - try_me inst = ReduceMe + doc = text "tcSimplifyBracket" \end{code} @@ -1635,8 +1648,12 @@ tcSimplifyTop wanteds (tidy_env, tidy_dicts) = tidyInsts bad_guys (bad_ips, non_ips) = partition isIPDict tidy_dicts (no_insts, ambigs) = partition no_inst non_ips - no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs - fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet + no_inst d = not (isTyVarDict d) + -- Previously, there was a more elaborate no_inst definition: + -- no_inst d = not (isTyVarDict d) || tyVarsOfInst d `subVarSet` fixed_tvs + -- fixed_tvs = oclose (fdPredsOfInsts tidy_dicts) emptyVarSet + -- But that seems over-elaborate to me; it only bites for class decls with + -- fundeps like this: class C a b | -> b where ... in -- Report definite errors @@ -1657,7 +1674,8 @@ tcSimplifyTop wanteds addTopAmbigErrs (tidy_env, ambigs) `thenM_` -- Disambiguate the ones that look feasible - mappM disambigGroup std_oks + getGhciMode `thenM` \ mode -> + mappM (disambigGroup mode) std_oks ) `thenM` \ binds_ambig -> returnM (binds `andMonoBinds` andMonoBindList binds_ambig) @@ -1704,12 +1722,13 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambigGroup :: [Inst] -- All standard classes of form (C a) +disambigGroup :: GhciMode + -> [Inst] -- All standard classes of form (C a) -> TcM TcDictBinds -disambigGroup dicts - | any isNumericClass classes -- Guaranteed all standard classes - -- see comment at the end of function for reasons as to +disambigGroup ghci_mode dicts + | any std_default_class classes -- Guaranteed all standard classes + -- See comment at the end of function for reasons as to -- why the defaulting mechanism doesn't apply to groups that -- include CCallable or CReturnable dicts. && not (any isCcallishClass classes) @@ -1735,35 +1754,39 @@ disambigGroup dicts in -- See if any default works tryM (try_default default_tys) `thenM` \ mb_ty -> - case mb_ty of { - Left _ -> -- If not, add an AmbigErr - addTopAmbigErrs (tidyInsts dicts) `thenM_` - returnM EmptyMonoBinds ; + case mb_ty of + Left _ -> bomb_out + Right chosen_default_ty -> choose_default chosen_default_ty - Right chosen_default_ty -> + | all isCreturnableClass classes -- Default CCall stuff to () + = choose_default unitTy - -- If so, bind the type variable + | otherwise -- No defaults + = bomb_out + + where + tyvar = get_tv (head dicts) -- Should be non-empty + classes = map get_clas dicts + + std_default_class cls + = isNumericClass cls + || (ghci_mode == Interactive && + classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) + -- In interactive mode, we default Show a to Show () + -- to avoid graututious errors on "show []" + + choose_default default_ty -- Commit to tyvar = default_ty + = -- Bind the type variable + unifyTauTy default_ty (mkTyVarTy tyvar) `thenM_` -- and reduce the context, for real this time - unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenM_` - simpleReduceLoop (text "disambig" <+> ppr dicts) + simpleReduceLoop (text "disambig" <+> ppr dicts) reduceMe dicts `thenM` \ (frees, binds, ambigs) -> - WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs ) - warnDefault dicts chosen_default_ty `thenM_` - returnM binds } - - | all isCreturnableClass classes - = -- Default CCall stuff to (); we don't even both to check that () is an - -- instance of CReturnable, because we know it is. - unifyTauTy (mkTyVarTy tyvar) unitTy `thenM_` - returnM EmptyMonoBinds - - | otherwise -- No defaults - = addTopAmbigErrs (tidyInsts dicts) `thenM_` - returnM EmptyMonoBinds + WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs ) + warnDefault dicts default_ty `thenM_` + returnM binds - where - tyvar = get_tv (head dicts) -- Should be non-empty - classes = map get_clas dicts + bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_` + returnM EmptyMonoBinds \end{code} [Aside - why the defaulting mechanism is turned off when