Commit e0653697 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor try_solve_fromInstance in shortCutSolver

This patch just removes the CtLoc parameter from trySolveFromInstance,
since it can just as easily (and more uniformly) be gotten from the
CtEvidence it is trying to solve.
parent 32eb4199
...@@ -563,7 +563,7 @@ solveOneFromTheOther ev_i ev_w ...@@ -563,7 +563,7 @@ solveOneFromTheOther ev_i ev_w
; return (same_level_strategy binds) } ; return (same_level_strategy binds) }
| otherwise -- Both are Given, levels differ | otherwise -- Both are Given, levels differ
= return (different_level_strategy) = return different_level_strategy
where where
pred = ctEvPred ev_i pred = ctEvPred ev_i
loc_i = ctEvLoc ev_i loc_i = ctEvLoc ev_i
...@@ -573,12 +573,12 @@ solveOneFromTheOther ev_i ev_w ...@@ -573,12 +573,12 @@ solveOneFromTheOther ev_i ev_w
ev_id_i = ctEvEvId ev_i ev_id_i = ctEvEvId ev_i
ev_id_w = ctEvEvId ev_w ev_id_w = ctEvEvId ev_w
different_level_strategy different_level_strategy -- Both Given
| isIPPred pred, lvl_w > lvl_i = KeepWork | isIPPred pred, lvl_w > lvl_i = KeepWork
| lvl_w < lvl_i = KeepWork | lvl_w < lvl_i = KeepWork
| otherwise = KeepInert | otherwise = KeepInert
same_level_strategy binds -- Both Given same_level_strategy binds -- Both Given
| GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
= case ctLocOrigin loc_w of = case ctLocOrigin loc_w of
GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork
...@@ -1012,8 +1012,7 @@ IncoherentInstances is `1`. If we were to do the optimization, the output of ...@@ -1012,8 +1012,7 @@ IncoherentInstances is `1`. If we were to do the optimization, the output of
Note [Shortcut try_solve_from_instance] Note [Shortcut try_solve_from_instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The workhorse of the short-cut solver is The workhorse of the short-cut solver is
try_solve_from_instance :: CtLoc try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
-> (EvBindMap, DictMap CtEvidence)
-> CtEvidence -- Solve this -> CtEvidence -- Solve this
-> MaybeT TcS (EvBindMap, DictMap CtEvidence) -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
Note that: Note that:
...@@ -1103,7 +1102,7 @@ shortCutSolver dflags ev_w ev_i ...@@ -1103,7 +1102,7 @@ shortCutSolver dflags ev_w ev_i
getTcEvBindsMap ev_binds_var getTcEvBindsMap ev_binds_var
; solved_dicts <- getSolvedDicts ; solved_dicts <- getSolvedDicts
; mb_stuff <- runMaybeT $ try_solve_from_instance loc_w ; mb_stuff <- runMaybeT $ try_solve_from_instance
(ev_binds, solved_dicts) ev_w (ev_binds, solved_dicts) ev_w
; case mb_stuff of ; case mb_stuff of
...@@ -1122,12 +1121,13 @@ shortCutSolver dflags ev_w ev_i ...@@ -1122,12 +1121,13 @@ shortCutSolver dflags ev_w ev_i
loc_w = ctEvLoc ev_w loc_w = ctEvLoc ev_w
try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] try_solve_from_instance -- See Note [Shortcut try_solve_from_instance]
:: CtLoc -> (EvBindMap, DictMap CtEvidence) -> CtEvidence :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
-> MaybeT TcS (EvBindMap, DictMap CtEvidence) -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
try_solve_from_instance loc (ev_binds, solved_dicts) ev try_solve_from_instance (ev_binds, solved_dicts) ev
| let pred = ctEvPred ev | let pred = ctEvPred ev
loc = ctEvLoc ev
, ClassPred cls tys <- classifyPredType pred , ClassPred cls tys <- classifyPredType pred
= do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w = do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc
; case inst_res of ; case inst_res of
OneInst { lir_new_theta = preds OneInst { lir_new_theta = preds
, lir_mk_ev = mk_ev , lir_mk_ev = mk_ev
...@@ -1141,9 +1141,9 @@ shortCutSolver dflags ev_w ev_i ...@@ -1141,9 +1141,9 @@ shortCutSolver dflags ev_w ev_i
-- up in a loop while solving recursive dictionaries. -- up in a loop while solving recursive dictionaries.
; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
; lift $ checkReductionDepth loc' pred ; lift $ checkReductionDepth loc pred
; evc_vs <- mapM (new_wanted_cached solved_dicts') preds ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
-- Emit work for subgoals but use our local cache -- Emit work for subgoals but use our local cache
-- so we can solve recursive dictionaries. -- so we can solve recursive dictionaries.
...@@ -1151,7 +1151,7 @@ shortCutSolver dflags ev_w ev_i ...@@ -1151,7 +1151,7 @@ shortCutSolver dflags ev_w ev_i
ev_binds' = extendEvBinds ev_binds $ ev_binds' = extendEvBinds ev_binds $
mkWantedEvBind (ctEvEvId ev) ev_tm mkWantedEvBind (ctEvEvId ev) ev_tm
; foldlM (try_solve_from_instance loc') ; foldlM try_solve_from_instance
(ev_binds', solved_dicts') (ev_binds', solved_dicts')
(freshGoals evc_vs) } (freshGoals evc_vs) }
...@@ -1162,12 +1162,12 @@ shortCutSolver dflags ev_w ev_i ...@@ -1162,12 +1162,12 @@ shortCutSolver dflags ev_w ev_i
-- Use a local cache of solved dicts while emitting EvVars for new work -- Use a local cache of solved dicts while emitting EvVars for new work
-- We bail out of the entire computation if we need to emit an EvVar for -- We bail out of the entire computation if we need to emit an EvVar for
-- a subgoal that isn't a ClassPred. -- a subgoal that isn't a ClassPred.
new_wanted_cached :: DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
new_wanted_cached cache pty new_wanted_cached loc cache pty
| ClassPred cls tys <- classifyPredType pty | ClassPred cls tys <- classifyPredType pty
= lift $ case findDict cache loc_w cls tys of = lift $ case findDict cache loc_w cls tys of
Just ctev -> return $ Cached (ctEvExpr ctev) Just ctev -> return $ Cached (ctEvExpr ctev)
Nothing -> Fresh <$> newWantedNC loc_w pty Nothing -> Fresh <$> newWantedNC loc pty
| otherwise = mzero | otherwise = mzero
addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
......
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