tcSimplifyBracket, tcSimplifyCheckPat,
tcSimplifyDeriv, tcSimplifyDefault,
- bindInstsOfLocalFuns, bindIrreds,
+ bindInstsOfLocalFuns,
misMatchMsg
) where
| 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
--
-- 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)
= 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,
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
]))
- ; 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
-- 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
-- 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 "----------------------"
given_binds `unionBags` normalise_binds1
`unionBags` normalise_binds2
`unionBags` binds,
- irreds ++ eq_irreds,
+ all_irreds,
needed_givens)
}
; 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
-- 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)
; 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
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}
if null irreds then
returnM ()
else
- failM
+ traceTc (ptext SLIT("tcSimplifyDefault failing")) >> failM
where
doc = ptext SLIT("default declaration")
\end{code}
-- 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,
(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)
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
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
projects / ghc-hetmet.git / blobdiff