X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=aff019e851b649d76fe60fffdb9a09d77386d26d;hp=b771502c0914833146005f0d94819edc04caf089;hb=aafdba3bce91afb003f5f50e001e141744837bae;hpb=35fca9fe01fc4eb0d2603577e5d4c300dfb1f919 diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index b771502..aff019e 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -22,7 +22,7 @@ module TcSimplify ( tcSimplifyBracket, tcSimplifyCheckPat, tcSimplifyDeriv, tcSimplifyDefault, - bindInstsOfLocalFuns, bindIrreds, + bindInstsOfLocalFuns, misMatchMsg ) where @@ -950,8 +950,10 @@ bindIrredsR loc qtvs co_vars reft givens irreds | null irreds = return emptyBag | otherwise - = do { let givens' = filter isDict givens - -- The givens can include methods + = do { let givens' = filter isAbstractableInst givens + -- The givens can (redundantly) include methods + -- We want to retain both EqInsts and Dicts + -- There should be no implicadtion constraints -- See Note [Pruning the givens in an implication constraint] -- If there are no 'givens' *and* the refinement is empty @@ -987,7 +989,8 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -> Refinement -- -- This binding must line up the 'rhs' in reduceImplication makeImplicationBind loc all_tvs reft - givens -- Guaranteed all Dicts (TOMDO: true?) + givens -- Guaranteed all Dicts + -- or EqInsts irreds | null irreds -- If there are no irreds, we are done = return ([], emptyBag) @@ -995,7 +998,10 @@ makeImplicationBind loc all_tvs reft = do { uniq <- newUnique ; span <- getSrcSpanM ; let (eq_givens, dict_givens) = partition isEqInst givens - eq_tyvar_cos = map TyVarTy $ uniqSetToList $ tyVarsOfTypes $ map eqInstType eq_givens + eq_tyvar_cos = mkTyVarTys (varSetElems $ tyVarsOfTypes $ map eqInstType eq_givens) + -- Urgh! See line 2187 or thereabouts. I believe that all these + -- 'givens' must be a simple CoVar. This MUST be cleaned up. + ; let name = mkInternalName uniq (mkVarOcc "ic") span implic_inst = ImplicInst { tci_name = name, tci_reft = reft, tci_tyvars = all_tvs, @@ -1008,14 +1014,17 @@ makeImplicationBind loc all_tvs reft tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids) pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) - co = mkWpApps (map instToId dict_givens) <.> mkWpTyApps eq_tyvar_cos <.> mkWpTyApps (mkTyVarTys all_tvs) + co = mkWpApps (map instToId dict_givens) + <.> mkWpTyApps eq_tyvar_cos + <.> mkWpTyApps (mkTyVarTys all_tvs) bind | [dict_irred_id] <- dict_irred_ids = VarBind dict_irred_id rhs | otherwise = PatBind { pat_lhs = L span pat, pat_rhs = unguardedGRHSs rhs, pat_rhs_ty = tup_ty, bind_fvs = placeHolderNames } - ; -- pprTrace "Make implic inst" (ppr (implic_inst,irreds,dict_irreds,tup_ty)) $ - return ([implic_inst], unitBag (L span bind)) } + ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst + ; return ([implic_inst], unitBag (L span bind)) + } ----------------------------------------------------------- tryHardCheckLoop :: SDoc @@ -1748,14 +1757,14 @@ reduceContext env wanteds ])) - ; let givens = red_givens env - (given_eqs0, given_dicts0) = partition isEqInst givens - (wanted_eqs0, wanted_dicts) = partition isEqInst wanteds + ; let givens = red_givens env + (given_eqs0, given_dicts0) = partition isEqInst givens + (wanted_eqs0, wanted_dicts0) = partition isEqInst wanteds -- We want to add as wanted equalities those that (transitively) -- occur in superclass contexts of wanted class constraints. -- See Note [Ancestor Equalities] - ; ancestor_eqs <- ancestorEqualities wanted_dicts + ; ancestor_eqs <- ancestorEqualities wanted_dicts0 ; let wanted_eqs = wanted_eqs0 ++ ancestor_eqs ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs @@ -1764,35 +1773,44 @@ reduceContext env wanteds -- 2. Normalise the *given* *dictionary* constraints -- wrt. the toplevel and given equations - ; (given_dicts, given_binds) <- normaliseGivenDicts given_eqs + ; (given_dicts, given_binds) <- normaliseGivenDicts given_eqs given_dicts0 - -- 3. Solve the *wanted* *equation* constraints - ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs - - -- 4. Normalise the *wanted* equality constraints with respect to - -- each other - ; eq_irreds <- normaliseWantedEqs eq_irreds0 - -- 5. Build the Avail mapping from "given_dicts" -- Add dicts refined by the current type refinement - ; init_state <- foldlM addGiven emptyAvails given_dicts - ; let reft = red_reft env - ; init_state <- if isEmptyRefinement reft then return init_state - else foldlM (addRefinedGiven reft) - init_state given_dicts + ; (init_state, extra_givens) <- getLIE $ do + { init_state <- foldlM addGiven emptyAvails given_dicts + ; let reft = red_reft env + ; if isEmptyRefinement reft then return init_state + else foldlM (addRefinedGiven reft) + init_state given_dicts } + + -- *** ToDo: what to do with the "extra_givens"? For the + -- moment I'm simply discarding them, which is probably wrong + + -- 7. Normalise the *wanted* *dictionary* constraints + -- wrt. the toplevel and given equations + -- NB: normalisation includes zonking as part of what it does + -- so it's important to do it after any unifications + -- that happened as a result of the addGivens + ; (wanted_dicts,normalise_binds1) <- normaliseWantedDicts given_eqs wanted_dicts0 -- 6. Solve the *wanted* *dictionary* constraints -- This may expose some further equational constraints... - ; wanted_dicts' <- zonkInsts wanted_dicts - ; avails <- reduceList env wanted_dicts' init_state - ; (binds, irreds0, needed_givens) <- extractResults avails wanted_dicts' + ; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state) + ; let (binds, irreds1, needed_givens) = extractResults avails wanted_dicts ; traceTc $ text "reduceContext extractresults" <+> vcat - [ppr avails,ppr wanted_dicts',ppr binds,ppr needed_givens] + [ppr avails,ppr wanted_dicts,ppr binds,ppr needed_givens] - -- 7. Normalise the *wanted* *dictionary* constraints - -- wrt. the toplevel and given equations - ; (irreds1,normalise_binds1) <- normaliseWantedDicts given_eqs irreds0 + -- *** ToDo: what to do with the "extra_eqs"? For the + -- moment I'm simply discarding them, which is probably wrong + + -- 3. Solve the *wanted* *equation* constraints + ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs + + -- 4. Normalise the *wanted* equality constraints with respect to + -- each other + ; eq_irreds <- normaliseWantedEqs eq_irreds0 -- 8. Substitute the wanted *equations* in the wanted *dictionaries* ; (irreds,normalise_binds2) <- substEqInDictInsts eq_irreds irreds1 @@ -1800,23 +1818,38 @@ reduceContext env wanteds -- 9. eliminate the artificial skolem constants introduced in 1. ; eliminate_skolems - -- If there was some FD improvement, - -- or new wanted equations have been exposed, - -- we should have another go at solving. - ; let improved = availsImproved avails - || (not $ isEmptyBag normalise_binds1) - || (not $ isEmptyBag normalise_binds2) - || (any isEqInst irreds) + -- Figure out whether we should go round again + -- My current plan is to see if any of the mutable tyvars in + -- givens or irreds has been filled in by improvement. + -- If so, there is merit in going around again, because + -- we may make further progress + -- + -- ToDo: is it only mutable stuff? We may have exposed new + -- equality constraints and should probably go round again + -- then as well. But currently we are dropping them on the + -- floor anyway. + + ; let all_irreds = irreds ++ eq_irreds + ; improved <- anyM isFilledMetaTyVar $ varSetElems $ + tyVarsOfInsts (givens ++ all_irreds) + + -- The old plan (fragile) + -- improveed = availsImproved avails + -- || (not $ isEmptyBag normalise_binds1) + -- || (not $ isEmptyBag normalise_binds2) + -- || (any isEqInst irreds) ; traceTc (text "reduceContext end" <+> (vcat [ text "----------------------", red_doc env, - text "given" <+> ppr (red_givens env), + text "given" <+> ppr givens, + text "given_eqs" <+> ppr given_eqs, text "wanted" <+> ppr wanteds, + text "wanted_dicts" <+> ppr wanted_dicts, text "----", text "avails" <+> pprAvails avails, text "improved =" <+> ppr improved, - text "irreds = " <+> ppr irreds, + text "(all) irreds = " <+> ppr all_irreds, text "binds = " <+> ppr binds, text "needed givens = " <+> ppr needed_givens, text "----------------------" @@ -1826,7 +1859,7 @@ reduceContext env wanteds given_binds `unionBags` normalise_binds1 `unionBags` normalise_binds2 `unionBags` binds, - irreds ++ eq_irreds, + all_irreds, needed_givens) } @@ -2166,12 +2199,11 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc ; traceTc (text "reduceImplication condition" <+> ppr ((isEmptyLHsBinds binds) || (null irreds))) -- Progress is no longer measered by the number of bindings --- ; if isEmptyLHsBinds binds then -- No progress - ; if (isEmptyLHsBinds binds) && (not $ null irreds) then + ; if (isEmptyLHsBinds binds) && (not $ null irreds) then -- No progress + -- If there are any irreds, we back off and return NoInstance return (ret_avails, NoInstance) else do - { - ; (implic_insts, bind) <- makeImplicationBind inst_loc tvs reft extra_givens irreds + { (implic_insts, bind) <- makeImplicationBind inst_loc tvs reft extra_givens irreds -- This binding is useless if the recursive simplification -- made no progress; but currently we don't try to optimise that -- case. After all, we only try hard to reduce at top level, or @@ -2183,12 +2215,17 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc -- equations depending on whether we solve -- dictionary constraints or equational constraints - eq_tyvars = uniqSetToList $ tyVarsOfTypes $ map eqInstType extra_eq_givens + eq_tyvars = varSetElems $ tyVarsOfTypes $ map eqInstType extra_eq_givens -- SLPJ Sept07: this looks Utterly Wrong to me, but I think -- that current extra_givens has no EqInsts, so -- it makes no difference - -- dict_ids = map instToId extra_givens - co = mkWpTyLams tvs <.> mkWpTyLams eq_tyvars <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) + co = wrap_inline -- Note [Always inline implication constraints] + <.> mkWpTyLams tvs + <.> mkWpTyLams eq_tyvars + <.> mkWpLams dict_ids + <.> WpLet (binds `unionBags` bind) + wrap_inline | null dict_ids = idHsWrapper + | otherwise = WpInline rhs = mkHsWrap co payload loc = instLocSpan inst_loc payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted) @@ -2198,12 +2235,21 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc ; traceTc (vcat [text "reduceImplication" <+> ppr name, ppr implic_insts, text "->" <+> sep [ppr needed_givens, ppr rhs]]) - -- If there are any irreds, we back off and return NoInstance ; return (ret_avails, GenInst (implic_insts ++ needed_givens) (L loc rhs)) } } \end{code} +Note [Always inline implication constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose an implication constraint floats out of an INLINE function. +Then although the implication has a single call site, it won't be +inlined. And that is bad because it means that even if there is really +*no* overloading (type signatures specify the exact types) there will +still be dictionary passing in the resulting code. To avert this, +we mark the implication constraints themselves as INLINE, at least when +there is no loss of sharing as a result. + Note [Reducing implication constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are trying to simplify @@ -2366,64 +2412,56 @@ We assume that they'll be wrapped in a big Rec, so that the dependency analyser can sort them out later \begin{code} +type DoneEnv = FiniteMap Inst [Id] +-- Tracks which things we have evidence for + extractResults :: Avails -> [Inst] -- Wanted - -> TcM ( TcDictBinds, -- Bindings - [Inst], -- Irreducible ones - [Inst]) -- Needed givens, i.e. ones used in the bindings + -> (TcDictBinds, -- Bindings + [Inst], -- Irreducible ones + [Inst]) -- Needed givens, i.e. ones used in the bindings -- Postcondition: needed-givens = free vars( binds ) \ irreds -- needed-gives is subset of Givens in incoming Avails -- Note [Reducing implication constraints] extractResults (Avails _ avails) wanteds - = go avails emptyBag [] [] wanteds + = go emptyBag [] [] emptyFM wanteds where - go :: AvailEnv -> TcDictBinds -> [Inst] -> [Inst] -> [Inst] - -> TcM (TcDictBinds, [Inst], [Inst]) - go avails binds irreds givens [] - = returnM (binds, irreds, givens) - - go avails binds irreds givens (w:ws) + go :: TcDictBinds -- Bindings for dicts + -> [Inst] -- Irreds + -> [Inst] -- Needed givens + -> DoneEnv -- Has an entry for each inst in the above three sets + -> [Inst] -- Wanted + -> (TcDictBinds, [Inst], [Inst]) + go binds irreds givens done [] + = (binds, irreds, givens) + + go binds irreds givens done (w:ws) + | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w + = if w_id `elem` done_ids then + go binds irreds givens done ws + else + go (add_bind (nlHsVar done_id)) irreds givens + (addToFM done w (done_id : w_id : rest_done_ids)) ws + + | otherwise -- Not yet done = case findAvailEnv avails w of Nothing -> pprTrace "Urk: extractResults" (ppr w) $ - go avails binds irreds givens ws - - Just (Given g) -> go (avails_with g g_id) - (add_triv_bind g_id) - irreds (g:givens) ws - -- avail_with g ensures that we don't emit the - -- same given twice into needed-givens - where - g_id = instToId g - - Just IsIrred -> go (avails_with w w_id) binds (w:irreds) givens ws + go binds irreds givens done ws - -- The avails_with_w handles the case where we want (Ord a, Eq a), and we - -- don't want to emit *two* Irreds for Ord a, one via the superclass chain - -- This showed up in a dupliated Ord constraint in the error message for - -- test tcfail043 - -- More generally, we don't want to emit two irreds with - -- the same type + Just IsIrred -> go binds (w:irreds) givens done' ws - Just (Rhs rhs@(L _ (HsVar g_id)) ws') - -> go avails (add_triv_bind g_id) irreds givens (ws' ++ ws) + Just (Rhs rhs ws') -> go (add_bind rhs) irreds givens done' (ws' ++ ws) - Just (Rhs rhs ws') - -> go (avails_with w w_id) (add_bind rhs) - irreds givens (ws' ++ ws) - -- The avails-with w replaces a complex RHS with a simple one - -- for the benefit of subsequent lookups + Just (Given g) -> go binds' irreds (g:givens) (addToFM done w [g_id]) ws + where + g_id = instToId g + binds' | w_id == g_id = binds + | otherwise = add_bind (nlHsVar g_id) where - w_id = instToId w - - add_triv_bind rhs_id | rhs_id == w_id = binds - | otherwise = add_bind (nlHsVar rhs_id) - -- The sought Id can be one of the givens, via a - -- superclass chain and then we definitely don't - -- want to generate an x=x binding! - + w_id = instToId w + done' = addToFM done w [w_id] add_bind rhs = addInstToDictBind binds w rhs - avails_with w w_id = extendAvailEnv avails w (Rhs (nlHsVar w_id) []) \end{code} @@ -2890,7 +2928,7 @@ tcSimplifyDefault theta if null irreds then returnM () else - failM + traceTc (ptext SLIT("tcSimplifyDefault failing")) >> failM where doc = ptext SLIT("default declaration") \end{code} @@ -2914,11 +2952,10 @@ groupErrs :: ([Inst] -> TcM ()) -- Deal with one group -- We want to report them together in error messages groupErrs report_err [] - = returnM () + = return () groupErrs report_err (inst:insts) - = do_one (inst:friends) `thenM_` - groupErrs report_err others - + = do { do_one (inst:friends) + ; groupErrs report_err others } where -- (It may seem a bit crude to compare the error messages, -- but it makes sure that we combine just what the user sees, @@ -2983,11 +3020,11 @@ report_no_instances tidy_env mb_what insts (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 (eqInsts, insts3) = partition isEqInst insts2 ; traceTc (text "reportNoInstances" <+> vcat - [ppr implics, ppr insts1, ppr insts2]) + [ppr insts, ppr implics, ppr insts1, ppr insts2]) ; mapM_ complain_implic implics ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps ; groupErrs complain_no_inst insts3 - ; mapM_ eqInstMisMatch eqInsts + ; mapM_ (addErrTcM . mk_eq_err) eqInsts } where complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts) @@ -3033,6 +3070,9 @@ report_no_instances tidy_env mb_what insts where ispecs = [ispec | (ispec, _) <- matches] + mk_eq_err :: Inst -> (TidyEnv, SDoc) + mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst) + mk_no_inst_err insts | null insts = empty @@ -3118,10 +3158,6 @@ mkMonomorphismMsg tidy_env inst_tvs nest 2 (vcat docs), monomorphism_fix dflags] -isRuntimeUnk :: TcTyVar -> Bool -isRuntimeUnk x | SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True - | otherwise = False - monomorphism_fix :: DynFlags -> SDoc monomorphism_fix dflags = ptext SLIT("Probable fix:") <+> vcat