Commit f84ea58e authored by dimitris's avatar dimitris
Browse files

Deleting A LOT of commented out code!

parent 3f420118
......@@ -96,55 +96,6 @@ solveInteractCts cts
= do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ])
; updWorkListTcS (appendWorkListCt cts) >> solveInteract }
{- DELETEME
= do { evvar_cache <- getTcSEvVarCacheMap
; (cts_thinner, new_evvar_cache) <- add_cts_in_cache evvar_cache cts
; traceTcS "solveInteractCts" (vcat [ text "cts_original =" <+> ppr cts,
text "cts_thinner =" <+> ppr cts_thinner
])
; setTcSEvVarCacheMap new_evvar_cache
; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract }
where
add_cts_in_cache evvar_cache cts
= do { ctxt <- getTcSContext
; foldM (solve_or_cache (simplEqsOnly ctxt)) ([],evvar_cache) cts }
solve_or_cache :: Bool -- Solve equalities only, not classes etc
-> ([Ct],TypeMap (EvVar,CtFlavor))
-> Ct
-> TcS ([Ct],TypeMap (EvVar,CtFlavor))
solve_or_cache eqs_only (acc_cts,acc_cache) ct
| dont_cache eqs_only (classifyPredType pred_ty)
= return (ct:acc_cts,acc_cache)
| Just (ev',fl') <- lookupTM pred_ty acc_cache
, fl' `canSolve` fl
, isWanted fl
= do { _ <- setEvBind ev (EvId ev') fl
; return (acc_cts,acc_cache) }
| otherwise -- If it's a given keep it in the work list, even if it exists in the cache!
= return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache)
where fl = cc_flavor ct
ev = cc_id ct
pred_ty = ctPred ct
dont_cache :: Bool -> PredTree -> Bool
-- Do not use the cache, not update it, if this is true
dont_cache _ (IPPred {}) = True -- IPPreds have subtle shadowing
dont_cache _ (EqPred ty1 ty2) -- Report Int ~ Bool errors separately
| Just tc1 <- tyConAppTyCon_maybe ty1
, Just tc2 <- tyConAppTyCon_maybe ty2
, tc1 /= tc2
= isDecomposableTyCon tc1 && isDecomposableTyCon tc2
| otherwise = False
dont_cache eqs_only _ = eqs_only
-- If we are simplifying equalities only,
-- do not cache non-equalities
-- See Note [Simplifying RULE lhs constraints] in TcSimplify
-}
solveInteractGiven :: GivenLoc -> [EvVar] -> TcS ()
solveInteractGiven gloc evs
= solveInteractCts (map mk_noncan evs)
......@@ -420,28 +371,7 @@ rewriteInertEqsFromInertEq (subst_tv, subst_co, subst_fl) ieqs
vcat [ text "original ="<+>ppr ct
, text "new eqpred ="<+>ppr new_eq_pred ]
}
{- DELETEME
= do { let rhs' = pSnd (tcCoercionKind co)
; delCachedEvVar ev fl
; evc <- newEqVar fl (mkTyVarTy tv) rhs'
; let ev' = evc_the_evvar evc
; let evco' = mkTcCoVarCo ev'
; fl' <- if isNewEvVar evc then
do { case fl of
Wanted {}
-> setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl
Given {}
-> setEqBind ev' (mkTcCoVarCo ev `mkTcTransCo` co) fl
Derived {}
-> return fl }
else
if isWanted fl then
setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl
else return fl
; let ct' = ct { cc_id = ev', cc_flavor = fl', cc_rhs = rhs' }
; return (ct',evco') }
ev = cc_id ct
-}
kick_out_rewritable :: Ct
-> InertSet
......@@ -916,45 +846,6 @@ doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
| Derived wl _ <- ifl = wl
| otherwise = panic "Solve IP: no WantedLoc!"
{-- DELETEME
; when (isWanted wfl) $
do { setEvBind (flav_evar wfl) (mkEvCast (flav_evar ifl)
; mb_new_fl <- rewriteCtFlavor wfl
(mkTyConApp (ipTyCon nm1) [ty1]) -- IP x ty1
(mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo cv])
-- IP x ty1 ~ IP x ty2
; case mb_new_fl of
Nothing -> pprPanic "Unexpected cached IP constraint!" empty
Just new_fl -> irWorkItemConsumed "IP/IP (solved by rewriting)" }
where new_wloc
| Wanted wl _ <- wfl = wl
| Derived wl _ <- wfl = wl
| Wanted wl _ <- ifl = wl
| Derived wl _ <- ifl = wl
| otherwise = panic "Solve IP: no WantedLoc!"
eqv <- newWantedEvVar (mkEqPred ty2 ty1)
-- See Note [Efficient Orientation]
;
let flav = Wanted (combineCtLoc ifl wfl)
; eqv <- newEqVar flav ty2 ty1 -- See Note [Efficient Orientation]
; when (isNewEvVar eqv) $
(let ct = CNonCanonical { cc_id = evc_the_evvar eqv
, cc_flavor = flav
, cc_depth = cc_depth workItem }
in updWorkListTcS (extendWorkListEq ct))
; case wfl of
Given {} -> pprPanic "Unexpected given IP" (ppr workItem)
Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
Wanted {} ->
do { _ <- setEvBind (cc_id workItem)
(mkEvCast id1 (mkTcSymCo (mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo (evc_the_evvar eqv)]))) wfl
; irWorkItemConsumed "IP/IP (solved by rewriting)" } }
-}
doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1
, cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 })
......@@ -1050,55 +941,6 @@ solving.
\begin{code}
{- DELETE
rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,SubGoalDepth,CtFlavor,Xi) -> TcS ()
-- Used to ineract two equalities of the following form:
-- First Equality: co1: (XXX ~ xi1)
-- Second Equality: cv2: (XXX ~ xi2)
-- Where the cv1 `canRewrite` cv2 equality
-- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1),
-- See Note [Efficient Orientation] for that
rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2)
= do { delCachedEvVar eqv2 gw -- Similarly to canonicalization!
; evc <- newEqVar gw xi2 xi1
; let eqv2' = evc_the_evvar evc
; gw' <- case gw of
Wanted {}
-> setEqBind eqv2
(mkTcCoVarCo eqv1 `mkTcTransCo` mkTcSymCo (mkTcCoVarCo eqv2')) gw
Given {}
-> setEqBind eqv2'
(mkTcSymCo (mkTcCoVarCo eqv2) `mkTcTransCo` mkTcCoVarCo eqv1) gw
Derived {}
-> return gw
; when (isNewEvVar evc) $
updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2'
, cc_flavor = gw'
, cc_depth = d } ) ) }
rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2)
= do { delCachedEvVar eqv2 gw -- Similarly to canonicalization!
; evc <- newEqVar gw xi1 xi2
; let eqv2' = evc_the_evvar evc
; gw' <- case gw of
Wanted {}
-> setEqBind eqv2
(mkTcCoVarCo eqv1 `mkTcTransCo` mkTcCoVarCo eqv2') gw
Given {}
-> setEqBind eqv2'
(mkTcSymCo (mkTcCoVarCo eqv1) `mkTcTransCo` mkTcCoVarCo eqv2) gw
Derived {}
-> return gw
; when (isNewEvVar evc) $
updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2'
, cc_flavor = gw'
, cc_depth = d } ) ) }
-}
solveOneFromTheOther :: String -- Info
-> CtFlavor -- Inert
-> Ct -- WorkItem
......@@ -1537,17 +1379,6 @@ instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
push_ctx :: WantedLoc -> WantedLoc
push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
{- DELETEME
eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds
; let wl' = push_ctx wl
; if isNewEvVar eqv then
return $ (i,(evc_the_evvar eqv,wl')):ievs
else -- We are eventually going to emit FD work back in the work list so
-- it is important that we only return the /freshly created/ and not
-- some existing equality!
return ievs }
-}
mkEqnMsg :: (TcPredType, SDoc)
-> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc)
......@@ -1830,55 +1661,6 @@ updFunEqCache fun_eq@(CFunEqCan { cc_fun = tc, cc_tyargs = xis })
key = mkTyConApp tc xis
updFunEqCache other = pprPanic "updFunEqCache:Non family equation" $ ppr other
{- DELETEME
; case fl of
Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version
; let eqv' = evc_the_evvar evc
; let coercion = coe `mkTcTransCo` mkTcCoVarCo eqv'
; _ <- setEqBind eqv coercion fl
; when (isNewEvVar evc) $
(let ct = CNonCanonical { cc_id = eqv'
, cc_flavor = fl
, cc_depth = cc_depth workItem + 1}
in updWorkListTcS (extendWorkListEq ct))
; let _solved = workItem { cc_flavor = solved_fl }
solved_fl = mkSolvedFlavor fl UnkSkol (EvCoercion coercion)
; updateFlatCache eqv solved_fl tc args xi WhenSolved
; return $
SomeTopInt { tir_rule = "Fun/Top (solved, more work)"
, tir_new_item = Stop } }
-- , tir_new_item = ContinueWith solved } }
-- Cache in inerts the Solved item
Given {} -> do { (fl',eqv') <- newGivenEqVar fl xi rhs_ty $
mkTcSymCo (mkTcCoVarCo eqv) `mkTcTransCo` coe
; let ct = CNonCanonical { cc_id = eqv'
, cc_flavor = fl'
, cc_depth = cc_depth workItem + 1}
; updWorkListTcS (extendWorkListEq ct)
; return $
SomeTopInt { tir_rule = "Fun/Top (given)"
, tir_new_item = ContinueWith workItem } }
Derived {} -> do { evc <- newEvVar fl (mkTcEqPred xi rhs_ty)
; let eqv' = evc_the_evvar evc
; when (isNewEvVar evc) $
(let ct = CNonCanonical { cc_id = eqv'
, cc_flavor = fl
, cc_depth = cc_depth workItem + 1 }
in updWorkListTcS (extendWorkListEq ct))
; return $
SomeTopInt { tir_rule = "Fun/Top (derived)"
, tir_new_item = Stop } }
}
}
-}
\end{code}
......
......@@ -1325,29 +1325,6 @@ canRewrite :: CtFlavor -> CtFlavor -> Bool
-- The equality constraint ct1 can be used to rewrite inside ct2
canRewrite = canSolve
{- DELETEME
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
combineCtLoc (Wanted loc) _ = loc
combineCtLoc _ (Wanted loc) = loc
combineCtLoc (Derived loc ) _ = loc
combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor
-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl
-}
-- combineWantedLoc :: Maybe WantedLoc -> Maybe WantedLoc -> WantedLoc
-- -- Precondition: at least one is Just
-- combineWantedLoc (Just wl) _ = wl
-- combineWantedLoc _ (Just wl) = wl
-- combineWantedLoc _ _ = panic "combineCtLoc: both given!"
mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc
mkGivenLoc wl sk = setCtLocOrigin wl sk
......@@ -1355,18 +1332,6 @@ mkGivenLoc wl sk = setCtLocOrigin wl sk
mkSolvedLoc :: WantedLoc -> SkolemInfo -> GivenLoc
mkSolvedLoc wl sk = setCtLocOrigin wl sk
{- DELETEME
mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
-}
\end{code}
%************************************************************************
......
......@@ -52,23 +52,12 @@ module TcSMonad (
xCtFlavor_cache, rewriteCtFlavor_cache,
-- Creation of evidence variables
{- DELETEME newEvVar, forceNewEvVar, delCachedEvVar, updateFlatCache, flushFlatCache,
newGivenEqVar,
newEqVar, newKindConstraint,
EvVarCreated (..), isNewEvVar, FlatEqOrigin ( .. ), origin_matches,
-- Setting evidence variables
setEqBind,
setEvBind,
-}
setWantedTyBind,
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
{- DELETEME
getTcSEvVarCacheMap, getTcSEvVarFlatCache, setTcSEvVarCacheMap, pprEvVarCache,
-}
newFlattenSkolemTy, -- Flatten skolems
......@@ -445,12 +434,6 @@ The InertCans represents a collection of constraints with the following properti
9 Given family or dictionary constraints don't mention touchable unification variables
\begin{code}
{- DV Notes: 23/03/2012
1) stage: if exact predicate exists then discard immediately else go on
2) stage: canonicalization (with the newEvVarCache) and the flatCache stuff
3) stage: whatever we do no but at the interact-top we share previously solved
family head equations
-}
-- The Inert Set
data InertSet
......@@ -469,7 +452,7 @@ data InertSet
-- Always canonical CTyFunEqs (Given or Wanted only!)
-- Key is by family head. We used this field during flattening only
, inert_solved_funeqs :: CtFamHeadMap
-- Memoized *Solved* family equations co :: F xis ~ xi
-- Memoized Solved family equations co :: F xis ~ xi
-- Stored not necessarily as fully rewritten; we'll do that lazily
-- when we lookup
}
......@@ -769,30 +752,6 @@ data TcSEnv
}
{- DELETEME
data EvVarCache
= EvVarCache { evc_cache :: TypeMap (EvVar,CtFlavor)
-- Map from PredTys to Evidence variables
-- used to avoid creating new goals
, evc_flat_cache :: TypeMap (TcCoercion,(Xi,CtFlavor,FlatEqOrigin))
-- Map from family-free heads (F xi) to family-free types.
-- Useful during flattening to share flatten skolem generation
-- The boolean flag:
-- True <-> This equation was generated originally during flattening
-- False <-> This equation was generated by having solved a goal
}
data FlatEqOrigin = WhileFlattening -- Was it generated during flattening?
| WhenSolved -- Was it generated when a family equation was solved?
| Any
origin_matches :: FlatEqOrigin -> FlatEqOrigin -> Bool
origin_matches Any _ = True
origin_matches WhenSolved WhenSolved = True
origin_matches WhileFlattening WhileFlattening = True
origin_matches _ _ = False
-}
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables,
-- but records extra TcsTv variables generated during simplification
......@@ -1055,32 +1014,6 @@ updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $
ppr other_ct
{- DELETEME
flushFlatCache :: TcS ()
flushFlatCache
= do { cache_var <- getTcSEvVarCache
; the_cache <- wrapTcS $ TcM.readTcRef cache_var
; wrapTcS $ TcM.writeTcRef cache_var (the_cache { evc_flat_cache = emptyTM }) }
getTcSEvVarCacheMap :: TcS (TypeMap (EvVar,CtFlavor))
getTcSEvVarCacheMap = do { cache_var <- getTcSEvVarCache
; the_cache <- wrapTcS $ TcM.readTcRef cache_var
; return (evc_cache the_cache) }
getTcSEvVarFlatCache :: TcS (TypeMap (TcCoercion,(Type,CtFlavor,FlatEqOrigin)))
getTcSEvVarFlatCache = do { cache_var <- getTcSEvVarCache
; the_cache <- wrapTcS $ TcM.readTcRef cache_var
; return (evc_flat_cache the_cache) }
setTcSEvVarCacheMap :: TypeMap (EvVar,CtFlavor) -> TcS ()
setTcSEvVarCacheMap cache = do { cache_var <- getTcSEvVarCache
; orig_cache <- wrapTcS $ TcM.readTcRef cache_var
; let new_cache = orig_cache { evc_cache = cache }
; wrapTcS $ TcM.writeTcRef cache_var new_cache }
-}
getUntouchables :: TcS TcsUntouchables
getUntouchables = TcS (return . tcs_untch)
......@@ -1457,291 +1390,6 @@ rewriteCtFlavor_cache cache fl pty co
cont [fl] = return $ Just fl
cont _ = panic "At most one constraint can be subgoal of coercion!"
{- REFACTOR -- HERE HERE HERE
rewriteCtFlavor :: Ct -- Original ct
-> PredType -- New predicate
-> TcCoercion -- ctPred ct ~ new_predicate
-> TcS (Maybe CtFlavor) -- Nothing if we already have a constraint
-- like this in the solved or in the inert set
rewriteCtFlavor orig_ct pty co
| isReflCo co
-- If the coercion is just reflexivity then you may re-use the same variable
= return (Just $ case cc_flavor orig_ct of
Derived wl pty_orig -> Derived wl pty
Given gl ev -> Given gl (setVarType ev pty)
Wanted wl ev -> Wanted wl (setVarType ev pty)
Solved gl ev -> Solved gl (setVarType ev pty))
| otherwise
= new_ct_flav orig_ct (cc_flavor orig_ct) pty co
where
-- Given
new_ct_flav _orig_ct (Given { flav_gloc = gl, flav_evar = ev }) pty co
= do { new_ev <- wrapTcS $ TcM.newEvVar pty -- 1) Create new variable
; setEvBind new_ev (mkEvCast ev co) -- 2) Set evidence
; return $ Just (Given { flav_gloc = gl, flav_evar = new_ev }) }
-- 3) Return new given
-- Wanted
new_ct_flav orig_ct (Wanted { flav_wloc = wl, flav_evar = ev }) pty co
= do { is <- getTcSInerts
; case lookupInInerts is pty of
Just ct | not (isDerived ct) -> -- Cached (and has a ctId)
do { setEvBind ev (mkCast (ctId ct) (mkSymCo co))
; return Nothing }
_ -> -- Not Cached!
do { new_ev <- wrapTcS $ TcM.newEvVar pty -- 1) Create new variable
; setEvBind ev (mkCast new_ev (mkSymCo co)) -- 2) Solve old from new
; let gl = mkSolvedLoc wl UnkSkol
; addToSolved (orig_ct { cc_flavor = Solved gl ev })
-- 3) Add old as solved
; return (Just (Wanted { flav_wloc = wl -- 4) Return new wanted
, flav_evar = new_ev })) } }
-- Derived
new_ct_flav _orig_ct (Derived { flav_wloc = wl, flav_der_pty = _pty }) pty _co
= do { is <- getTcSInerts
; case lookupInInerts is pty of
Just ct -> return Nothing -- Some other constraint already there
_ -> return $
Just (Derived {flav_wloc = wl, flav_der_pty = pty }) }
-- Solved
new_ct_flav _orig_ct (Solved { flav_gloc = gl, flav_evar = ev }) pty co
= do { new_ev <- wrapTcS $ TcM.newEvVar pty -- 1) Create new variable
; setEvBind new_ev (mkEvCast ev co) -- 2) Set new evidence
; let new_fl = Solved gl new_ev
; return $ Just new_fl } -- 3) Return. NB: no need to addToSolved here
newGivenFlavor :: GivenLoc -> TcPredType -> TcS CtFlavor
newGivenFlavor gl pty
= do { new_ev <- wrapTcS $ TcM.newEvVar pty
; return (Given gl pty) }
newWantedFlavor :: WantedLoc
-> TcPredType
-> TcS (Either CtFlavor Ct)
-- Returns either a new flavor or a cached constraint
newWantedFlavor wl pty
= do { is <- getTcSInerts
; case lookupInInerts is pty of
Just ct | not (isDerived ct) -> return (Right ct)
_ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
; return $ Left (Wanted wl new_ev) } }
newDerivedFlavor :: WantedLoc
-> TcPredType -> TcS CtFlavor
newDerivedFlavor wl pty = return (Derived wl pty)
newCtFlavor :: CtFlavor -> TcPredType -> TcS CtFlavor
-- CtFlavor might not necessarily be fresh if constraint is cached
newCtFlavor (Wanted { flav_wloc = wl }) pty
= do { lr <- newWantedFlavor wl pty
; case lr of Left fl -> return fl
Right ct -> return (cc_flavor ct) }
newCtFlavor (Given { flav_gloc = gl }) pty
= newGivenFlavor gl pty
newCtFlavor (Derived { flav_wloc = wl }) pty
= newDerivedFlavor wl pty
-}
{- DELETEME
data EvVarCreated
= EvVarCreated { evc_is_new :: Bool -- True iff the variable was just created
, evc_the_evvar :: EvVar } -- The actual evidence variable could be cached or new
instance Outputable EvVarCreated where
ppr (EvVarCreated { evc_is_new = is_new, evc_the_evvar = ev })
= ppr ev <> parens (if is_new then ptext (sLit "new") else ptext (sLit "old"))
newKindConstraint :: TcTyVar -> Kind -> CtFlavor -> TcS EvVarCreated
-- Create new wanted CoVar that constrains the type to have the specified kind.
newKindConstraint tv knd fl
= do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd
; let ty_k = mkTyVarTy tv_k
; eqv <- newEqVar fl (mkTyVarTy tv) ty_k
; return eqv }
setEqBind :: EqVar -> TcCoercion -> CtFlavor -> TcS CtFlavor
setEqBind eqv co fl = setEvBind eqv (EvCoercion co) fl
setEvBind :: EvVar -> EvTerm -> CtFlavor -> TcS CtFlavor
-- If the flavor is Solved, we cache the new evidence term inside the returned flavor
-- see Note [Optimizing Spontaneously Solved Coercions]
setEvBind ev t fl
= do { tc_evbinds <- getTcEvBinds
; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
#ifdef DEBUG
; binds <- getTcEvBindsMap
; let cycle = any (reaches binds) (evVarsOfTerm t)
; when cycle (fail_if_co_loop binds)
#endif
; return $
case fl of
Given gl (GivenSolved _)
-> Given gl (GivenSolved (Just t))
_ -> fl
}
#ifdef DEBUG
where fail_if_co_loop binds
= pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev
, ppr (evBindMapBinds binds) ]) $
when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!"))
reaches :: EvBindMap -> Var -> Bool
-- Does this evvar reach ev?
reaches ebm ev0 = go ev0
where go ev0
| ev0 == ev = True
| Just (EvBind _ evtrm) <- lookupEvBind ebm ev0
= any go (evVarsOfTerm evtrm)
| otherwise = False
#endif
isNewEvVar :: EvVarCreated -> Bool
isNewEvVar = evc_is_new
newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated
-- Post: If Given then evc_is_new is True
-- Hence it is safe to do a setEvBind right after a newEvVar with a Given flavor
-- NB: newEvVar may temporarily break the TcSEnv invariant but it is expected in
-- the call sites for this invariant to be quickly restored.
newEvVar fl pty
| isGivenOrSolved fl -- Create new variable and update the cache
= do {
{- We lose a lot of time if we enable this check:
eref <- getTcSEvVarCache
; ecache <- wrapTcS (TcM.readTcRef eref)
; case lookupTM pty (evc_cache ecache) of
Just (_,cached_fl)
| cached_fl `canSolve` fl
-> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $
return ()
_ -> return ()
-}
new <- forceNewEvVar fl pty
; return (EvVarCreated True new) }
| otherwise -- Otherwise lookup first
= {-# SCC "newEvVarWanted" #-}
do { eref <- getTcSEvVarCache
; ecache <- wrapTcS (TcM.readTcRef eref)
; case lookupTM pty (evc_cache ecache) of
Just (cached_evvar, cached_flavor)
| cached_flavor `canSolve` fl -- NB:
-- We want to use the cache /only/ if he can solve
-- the workitem. If cached_flavor is Derived
-- but we have a real Wanted, we want to create
-- new evidence, otherwise we are in danger to
-- have unsolved goals in the end.
-- (Remember: Derived's are just unification hints
-- but they don't come with guarantees
-- that they can be solved and we don't
-- quantify over them.
-> do { traceTcS "newEvVar: already cached, doing nothing"
(ppr (evc_cache ecache))
; return (EvVarCreated False cached_evvar) }
_ -- Not cached or cached with worse flavor
-> do { new <- force_new_ev_var eref ecache fl pty
; return (EvVarCreated True new) } }
forceNewEvVar :: CtFlavor -> TcPredType -> TcS EvVar
-- Create a new EvVar, regardless of whether or not the
-- cache already contains one like it, and update the cache
forceNewEvVar fl pty
= do { eref <- getTcSEvVarCache
; ecache <- wrapTcS (TcM.readTcRef eref)
; force_new_ev_var eref ecache fl pty }
force_new_ev_var :: IORef EvVarCache -> EvVarCache -> CtFlavor -> TcPredType -> TcS EvVar
-- Create a new EvVar, and update the cache with it
force_new_ev_var eref ecache fl pty
= wrapTcS $
do { TcM.traceTc "newEvVar" $ text "updating cache"
; new_evvar <-TcM.newEvVar pty
-- This is THE PLACE where we finally call TcM.newEvVar
; let new_cache = updateCache ecache (new_evvar,fl,pty)
; TcM.writeTcRef eref new_cache
; return new_evvar }