Commit 34be452f authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Minor fixes, mostly simplificaitons

parent ee578b6f
......@@ -27,7 +27,7 @@ module Inst (
-- Simple functions over evidence variables
hasEqualities,
tyVarsOfZonkedWC, tyVarsOfBag,
tyVarsOfWC, tyVarsOfBag,
tyVarsOfCt, tyVarsOfCts,
tidyEvVar, tidyCt, tidyGivenLoc,
......@@ -528,18 +528,19 @@ tyVarsOfCt (CNonCanonical { cc_ev = fl }) = tyVarsOfType (ctEvPred
tyVarsOfCts :: Cts -> TcTyVarSet
tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
tyVarsOfZonkedWC :: WantedConstraints -> TyVarSet
tyVarsOfWC :: WantedConstraints -> TyVarSet
-- Only called on *zonked* things, hence no need to worry about flatten-skolems
tyVarsOfZonkedWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfCts flat `unionVarSet`
tyVarsOfBag tyVarsOfZonkedImplic implic `unionVarSet`
tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
tyVarsOfCts insol
tyVarsOfZonkedImplic :: Implication -> TyVarSet
tyVarsOfImplic :: Implication -> TyVarSet
-- Only called on *zonked* things, hence no need to worry about flatten-skolems
tyVarsOfZonkedImplic (Implic { ic_skols = skols, ic_given = givens, ic_wanted = wanted })
= (tyVarsOfZonkedWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
`delVarSetList` skols
tyVarsOfImplic (Implic { ic_skols = skols, ic_fsks = fsks
, ic_given = givens, ic_wanted = wanted })
= (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
`delVarSetList` skols `delVarSetList` fsks
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
......
......@@ -502,14 +502,13 @@ tcPolyInfer
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
= do { (((binds', mono_infos), untch), wanted)
= do { ((binds', mono_infos), wanted)
<- captureConstraints $
captureUntouchables $
tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
; (qtvs, givens, mr_bites, ev_binds) <-
simplifyInfer closed mono name_taus (untch,wanted)
simplifyInfer closed mono name_taus wanted
; theta <- zonkTcThetaType (map evVarPred givens)
; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
......
......@@ -77,7 +77,7 @@ reportUnsolved runtimeCoercionErrors wanted
; errs_so_far <- ifErrsM (return True) (return False)
; let tidy_env = tidyFreeTyVars env0 free_tvs
free_tvs = tyVarsOfZonkedWC wanted
free_tvs = tyVarsOfWC wanted
err_ctxt = CEC { cec_encl = []
, cec_insol = errs_so_far || insolubleWC wanted
-- Don't report ambiguity errors if
......
......@@ -25,7 +25,7 @@ module TcMType (
newFlexiTyVarTy, -- Kind -> TcM TcType
newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]
newMetaKindVar, newMetaKindVars, mkKindSigVar,
mkTcTyVarName,
mkTcTyVarName, cloneMetaTyVar,
newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar,
......@@ -322,6 +322,17 @@ newMetaTyVar meta_info kind
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
cloneMetaTyVar tv
= ASSERT( isTcTyVar tv )
do { uniq <- newUnique
; ref <- newMutVar Flexi
; let name' = setNameUnique (tyVarName tv) uniq
details' = case tcTyVarDetails tv of
details@(MetaTv {}) -> details { mtv_ref = ref }
_ -> pprPanic "cloneMetaTyVar" (ppr tv)
; return (mkTcTyVar name' (tyVarKind tv) details') }
mkTcTyVarName :: Unique -> FastString -> Name
-- Make sure that fresh TcTyVar names finish with a digit
-- leaving the un-cluttered names free for user names
......
......@@ -1522,14 +1522,14 @@ tcRnExpr hsc_env ictxt rdr_expr
-- it might have a rank-2 type (e.g. :t runST)
uniq <- newUnique ;
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
(((_tc_expr, res_ty), untch), lie) <- captureConstraints $
captureUntouchables (tcInferRho rn_expr) ;
((_tc_expr, res_ty), lie) <- captureConstraints $
tcInferRho rn_expr ;
((qtvs, dicts, _, _), lie_top) <- captureConstraints $
{-# SCC "simplifyInfer" #-}
simplifyInfer True {- Free vars are closed -}
False {- No MR for now -}
[(fresh_it, res_ty)]
(untch,lie) ;
lie ;
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
......
......@@ -76,6 +76,7 @@ module TcSMonad (
instDFunType, -- Instantiation
newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
cloneMetaTyVar,
compatKind, mkKindErrorCtxtTcS,
......@@ -1350,6 +1351,9 @@ instDFunType dfun_id mb_inst_tys
newFlexiTcSTy :: Kind -> TcS TcType
newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
instFlexiTcS :: [TKVar] -> TcS (TvSubst, [TcType])
instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
where
......
......@@ -324,14 +324,14 @@ simplifyInfer :: Bool
-> Bool -- Apply monomorphism restriction
-> [(Name, TcTauType)] -- Variables to be generalised,
-- and their tau-types
-> (Untouchables, WantedConstraints)
-> WantedConstraints
-> TcM ([TcTyVar], -- Quantify over these type variables
[EvVar], -- ... and these constraints
Bool, -- The monomorphism restriction did something
-- so the results type is not as general as
-- it could be
TcEvBinds) -- ... binding these evidence variables
simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
simplifyInfer _top_lvl apply_mr name_taus wanteds
| isEmptyWC wanteds
= do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked
; zonked_taus <- zonkTcTypes (map snd name_taus)
......@@ -342,8 +342,7 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
; return (qtvs, [], False, emptyTcEvBinds) }
| otherwise
= TcRnMonad.setUntouchables untch $
do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
= do { runtimeCoercionErrors <- doptM Opt_DeferTypeErrors
; gbl_tvs <- tcGetGlobalTyVars
; zonked_tau_tvs <- zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus))
; zonked_wanteds <- zonkWC wanteds
......@@ -355,7 +354,6 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
, ptext (sLit "gbl_tvs =") <+> ppr gbl_tvs
, ptext (sLit "closed =") <+> ppr _top_lvl
, ptext (sLit "apply_mr =") <+> ppr apply_mr
, ptext (sLit "untch =") <+> ppr untch
, ptext (sLit "wanted =") <+> ppr zonked_wanteds
]
......@@ -453,7 +451,9 @@ simplifyInfer _top_lvl apply_mr name_taus (untch,wanteds)
; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds
; lcl_env <- getLclTypeEnv
; gloc <- getCtLoc skol_info
; let implic = Implic { ic_untch = untch
; untch <- TcRnMonad.getUntouchables
; uniq <- TcRnMonad.newUnique
; let implic = Implic { ic_untch = pushUntouchables uniq untch
, ic_env = lcl_env
, ic_skols = qtvs_to_return
, ic_fsks = [] -- wanted_tansformed arose only from solveWanteds
......@@ -802,7 +802,9 @@ solveNestedImplications implics
; (floated_eqs, unsolved_implics)
<- flatMapBagPairM (solveImplication thinner_inerts) implics
; floated_eqs <- promoteFloatedUnificationVars floated_eqs
; promoteFloatedUnificationVars floated_eqs
-- Performs some unifications, adding to monadically-carried ty_binds
-- These will be used when processing floated_eqs later
-- ... and we are back in the original TcS inerts
-- Notice that the original includes the _insoluble_flats so it was safe to ignore
......@@ -859,29 +861,23 @@ solveImplication inerts
Note [Floating equalities]
\begin{code}
promoteFloatedUnificationVars :: Cts -> TcS Cts
promoteFloatedUnificationVars :: Cts -> TcS ()
promoteFloatedUnificationVars cts
= do { untch <- TcSMonad.getUntouchables
; let tvs = filter (isFloatedTouchableMetaTyVar untch) $
varSetElems (tyVarsOfCts cts)
; tv_eqs <- mapM promote_tv tvs
; mapM_ (promote_tv untch) tvs
; ty_binds <- getTcSTyBindsMap
; traceTcS "promoteFloated" (vcat [ text "Ctxt untoucables =" <+> ppr untch
, text "Floated eqs =" <+> ppr cts
, text "Promoted tvs =" <+> ppr tvs
, text "Promoted eqs =" <+> ppr tv_eqs])
; return (cts `unionBags` listToBag tv_eqs) }
, text "Ty binds =" <+> ppr ty_binds])
; return () }
where
wloc = ctev_wloc (cc_ev (head (bagToList cts))) -- Yuk, but not needed soon
promote_tv tv
= do { rhs_ty <- newFlexiTcSTy (tyVarKind tv)
; let refl_evtm = EvCoercion (mkTcReflCo rhs_ty)
refl_pred = mkTcEqPred (mkTyVarTy tv) rhs_ty
given_ev = Given { ctev_gloc = mkGivenLoc wloc UnkSkol
, ctev_pred = refl_pred
, ctev_evtm = refl_evtm }
; setWantedTyBind tv rhs_ty
; return (CTyEqCan { cc_ev = given_ev, cc_tyvar = tv
, cc_rhs = rhs_ty, cc_depth = 0 }) }
promote_tv untch tv
= do { cloned_tv <- TcSMonad.cloneMetaTyVar tv
; let rhs_tv = setMetaTyVarUntouchables cloned_tv untch
; setWantedTyBind tv (mkTyVarTy rhs_tv) }
floatEqualities :: [TcTyVar] -> [EvVar] -> WantedConstraints -> (Cts, WantedConstraints)
-- Post: The returned FlavoredEvVar's are only Wanted or Derived
......@@ -1166,7 +1162,6 @@ applyDefaultingRules wanteds
Note [tryTcS in defaulting]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
defaultTyVar and disambigGroup create new evidence variables for
default equations, and hence update the EvVar cache. However, after
applyDefaultingRules we will try to solve these default equations
......@@ -1189,51 +1184,28 @@ in the cache!
\begin{code}
------------------
touchablesOfWC :: WantedConstraints -> TcTyVarSet
-- See Note [Extra Tcs Untouchables] to see why we carry a Untouchables
-- instead of just using the Untouchable range have in our hands.
touchablesOfWC
= go noUntouchables
where
go :: Untouchables -> WantedConstraints -> TcTyVarSet
go untch (WC { wc_flat = flats, wc_impl = impls })
= filterVarSet is_touchable flat_tvs `unionVarSet`
foldrBag (unionVarSet . go_impl) emptyVarSet impls
where
is_touchable = isTouchableMetaTyVar untch
flat_tvs = tyVarsOfCts flats
go_impl implic = go (ic_untch implic) (ic_wanted implic)
applyTyVarDefaulting :: WantedConstraints -> TcM Cts
applyTyVarDefaulting wc = runTcS do_dflt >>= (return . fst)
where
do_dflt = do { tv_cts <- mapM defaultTyVar $
varSetElems (touchablesOfWC wc)
; return (unionManyBags tv_cts) }
applyTyVarDefaulting wc
= do { tv_cts <- mapM defaultTyVar $
varSetElems (tyVarsOfWC wc)
; return (unionManyBags tv_cts) }
defaultTyVar :: TcTyVar -> TcS Cts
defaultTyVar :: TcTyVar -> TcM Cts
-- Precondition: a touchable meta-variable
defaultTyVar the_tv
| not (k `eqKind` default_k)
-- Why tryTcS? See Note [tryTcS in defaulting]
= tryTcS $
do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
; ty_k <- instFlexiTcSHelperTcS (tyVarName the_tv) default_k
; let derived_pred = mkTcEqPred (mkTyVarTy the_tv) ty_k
= do { tv' <- TcMType.cloneMetaTyVar the_tv
; let rhs_ty = mkTyVarTy (setTyVarKind tv' default_k)
loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
derived_pred = mkTcEqPred (mkTyVarTy the_tv) rhs_ty
-- Why not directly derived_pred = mkTcEqPred k default_k?
-- See Note [DefaultTyVar]
derived_cts = unitBag $ mkNonCanonical $
derived_cts = mkNonCanonical $
Derived { ctev_wloc = loc
, ctev_pred = derived_pred }
; implics_from_defaulting <- solveInteract derived_cts
; MASSERT (isEmptyBag implics_from_defaulting)
; all_solved <- checkAllSolved
; if all_solved then return derived_cts
else return emptyBag }
; return (unitBag derived_cts) }
| otherwise = return emptyBag -- The common case
where
k = tyVarKind the_tv
......
......@@ -38,9 +38,10 @@ module TcType (
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
isAmbiguousTyVar, metaTvRef,
isAmbiguousTyVar, metaTvRef, metaTyVarInfo,
isFlexi, isIndirect, isRuntimeUnkSkol,
isTypeVar, isKindVar,
isTypeVar, isKindVar,
metaTyVarUntouchables, setMetaTyVarUntouchables,
isTouchableMetaTyVar, isFloatedTouchableMetaTyVar,
--------------------------------
......@@ -767,6 +768,27 @@ isMetaTyVarTy :: TcType -> Bool
isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
isMetaTyVarTy _ = False
metaTyVarInfo :: TcTyVar -> MetaInfo
metaTyVarInfo tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_info = info } -> info
_ -> pprPanic "metaTyVarInfo" (ppr tv)
metaTyVarUntouchables :: TcTyVar -> Untouchables
metaTyVarUntouchables tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv { mtv_untch = untch } -> untch
_ -> pprPanic "metaTyVarUntouchables" (ppr tv)
setMetaTyVarUntouchables :: TcTyVar -> Untouchables -> TcTyVar
setMetaTyVarUntouchables tv untch
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_untch = untch })
_ -> pprPanic "metaTyVarUntouchables" (ppr tv)
isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
......
......@@ -875,7 +875,7 @@ Make PredTypes
-- | Creates a type equality predicate
mkEqPred :: Type -> Type -> PredType
mkEqPred ty1 ty2
= WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 )
= WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 $$ ppr k $$ ppr (typeKind ty2) )
TyConApp eqTyCon [k, ty1, ty2]
where
k = typeKind ty1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment