| ... |
... |
@@ -767,93 +767,21 @@ tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w }) |
|
767
|
767
|
-- Enabled by the -fsolve-constant-dicts flag
|
|
768
|
768
|
|
|
769
|
769
|
-> tryTcS $ -- tryTcS tries to completely solve some contraints
|
|
770
|
|
- do { updInertSet zapInertSet -- Remove all Givens, solved dicts etc
|
|
|
770
|
+ do { updInertSet zap_cans
|
|
771
|
771
|
; solveSimpleWanteds (unitBag (CDictCan dict_w)) }
|
|
772
|
772
|
|
|
773
|
773
|
| otherwise
|
|
774
|
774
|
-> return False }
|
|
775
|
775
|
|
|
776
|
|
-{-
|
|
777
|
|
- = do { ev_binds_var <- getTcEvBindsVar
|
|
778
|
|
- ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
|
|
779
|
|
- getTcEvBindsMap ev_binds_var
|
|
780
|
|
- ; solved_dicts <- getSolvedDicts
|
|
781
|
|
-
|
|
782
|
|
- ; mb_stuff <- runMaybeT $
|
|
783
|
|
- try_solve_from_instance (ev_binds, solved_dicts) wanted
|
|
784
|
|
-
|
|
785
|
|
- ; case mb_stuff of
|
|
786
|
|
- Nothing -> return False
|
|
787
|
|
- Just (ev_binds', solved_dicts')
|
|
788
|
|
- -> do { setTcEvBindsMap ev_binds_var ev_binds'
|
|
789
|
|
- ; setSolvedDicts solved_dicts'
|
|
790
|
|
- ; return True } }
|
|
791
|
|
-
|
|
792
|
|
- | otherwise
|
|
793
|
|
- = return False
|
|
794
|
776
|
where
|
|
795
|
|
- -- This `CtLoc` is used only to check the well-staged condition of any
|
|
796
|
|
- -- candidate DFun. Our subgoals all have the same stage as our root
|
|
797
|
|
- -- [W] constraint so it is safe to use this while solving them.
|
|
798
|
|
- loc_w = ctEvLoc ev_w
|
|
799
|
|
-
|
|
800
|
|
- try_solve_from_instance -- See Note [Shortcut try_solve_from_instance]
|
|
801
|
|
- :: (EvBindMap, DictMap DictCt) -> WantedCtEvidence
|
|
802
|
|
- -> MaybeT TcS (EvBindMap, DictMap DictCt)
|
|
803
|
|
- try_solve_from_instance (ev_binds, solved_dicts) wtd@(WantedCt { ctev_loc = loc, ctev_pred = pred })
|
|
804
|
|
- | ClassPred cls tys <- classifyPredType pred
|
|
805
|
|
- = do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
|
|
806
|
|
- ; lift $ warn_custom_warn_instance inst_res loc_w
|
|
807
|
|
- -- See Note [Implementation of deprecated instances]
|
|
808
|
|
- ; case inst_res of
|
|
809
|
|
- OneInst { cir_new_theta = preds
|
|
810
|
|
- , cir_mk_ev = mk_ev
|
|
811
|
|
- , cir_canonical = canonical
|
|
812
|
|
- , cir_what = what }
|
|
813
|
|
- | safeOverlap what
|
|
814
|
|
- , all isTyFamFree preds -- Note [Shortcut solving: type families]
|
|
815
|
|
- -> do { let dict_ct = DictCt { di_ev = CtWanted wtd, di_cls = cls
|
|
816
|
|
- , di_tys = tys, di_pend_sc = doNotExpand }
|
|
817
|
|
- solved_dicts' = addSolvedDict dict_ct solved_dicts
|
|
818
|
|
- -- solved_dicts': it is important that we add our goal
|
|
819
|
|
- -- to the cache before we solve! Otherwise we may end
|
|
820
|
|
- -- up in a loop while solving recursive dictionaries.
|
|
821
|
|
-
|
|
822
|
|
- ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
|
|
823
|
|
- ; loc' <- lift $ checkInstanceOK loc what pred
|
|
824
|
|
- ; lift $ checkReductionDepth loc' pred
|
|
825
|
|
-
|
|
826
|
|
-
|
|
827
|
|
- ; evc_vs <- mapM (new_wanted_cached wtd loc' solved_dicts') preds
|
|
828
|
|
- -- Emit work for subgoals but use our local cache
|
|
829
|
|
- -- so we can solve recursive dictionaries.
|
|
830
|
|
-
|
|
831
|
|
- ; let ev_tm = mk_ev (map getEvExpr evc_vs)
|
|
832
|
|
- ev_binds' = extendEvBinds ev_binds $
|
|
833
|
|
- mkWantedEvBind (wantedCtEvEvId wtd) canonical ev_tm
|
|
834
|
|
-
|
|
835
|
|
- ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $
|
|
836
|
|
- freshGoals evc_vs }
|
|
837
|
|
-
|
|
838
|
|
- _ -> mzero }
|
|
|
777
|
+ zap_cans :: InertSet -> InertSet
|
|
|
778
|
+ -- Zap the inert Givens (so we don't try to use them for solving)
|
|
|
779
|
+ -- and any inert Wanteds (no harm but not much benefit either.
|
|
|
780
|
+ -- But preserve the current solved_dicts, so that one invocation of
|
|
|
781
|
+ -- tryShortCutSolver can benefit from the work of earlier invocations
|
|
|
782
|
+ zap_cans inerts@(IS { inert_cans = cans })
|
|
|
783
|
+ = inerts { inert_cans = emptyInertCans (inert_given_eq_lvl cans) }
|
|
839
|
784
|
|
|
840
|
|
- | otherwise
|
|
841
|
|
- = mzero
|
|
842
|
|
-
|
|
843
|
|
-
|
|
844
|
|
- -- Use a local cache of solved dicts while emitting EvVars for new work
|
|
845
|
|
- -- We bail out of the entire computation if we need to emit an EvVar for
|
|
846
|
|
- -- a subgoal that isn't a ClassPred.
|
|
847
|
|
- new_wanted_cached :: WantedCtEvidence -> CtLoc
|
|
848
|
|
- -> DictMap DictCt -> TcPredType -> MaybeT TcS MaybeNew
|
|
849
|
|
- new_wanted_cached (WantedCt { ctev_rewriters = rws }) loc cache pty
|
|
850
|
|
- | ClassPred cls tys <- classifyPredType pty
|
|
851
|
|
- = lift $ case findDict cache loc_w cls tys of
|
|
852
|
|
- Just dict_ct -> return $ Cached (ctEvExpr (dictCtEvidence dict_ct))
|
|
853
|
|
- Nothing -> Fresh <$> newWantedNC loc rws pty
|
|
854
|
|
- | otherwise = mzero
|
|
855
|
|
-
|
|
856
|
|
--}
|
|
857
|
785
|
|
|
858
|
786
|
{- *******************************************************************
|
|
859
|
787
|
* *
|