diff options
Diffstat (limited to 'compiler/deSugar/DsMonad.hs')
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 39 |
1 files changed, 10 insertions, 29 deletions
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index eac17bfea0..045647f27c 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -32,8 +32,8 @@ module DsMonad ( -- Getting and setting pattern match oracle states getPmDelta, updPmDelta, - -- Iterations for pm checking - incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches, + -- Get COMPLETE sets of a TyCon + dsGetCompleteMatches, -- Warnings and errors DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr, @@ -190,8 +190,7 @@ mkDsEnvsFromTcGbl :: MonadIO m => HscEnv -> IORef Messages -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env - = do { pm_iter_var <- liftIO $ newIORef 0 - ; cc_st_var <- liftIO $ newIORef newCostCentreState + = do { cc_st_var <- liftIO $ newIORef newCostCentreState ; let dflags = hsc_dflags hsc_env this_mod = tcg_mod tcg_env type_env = tcg_type_env tcg_env @@ -200,7 +199,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env complete_matches = hptCompleteSigs hsc_env ++ tcg_complete_matches tcg_env ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env - msg_var pm_iter_var cc_st_var complete_matches + msg_var cc_st_var complete_matches } runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a) @@ -219,8 +218,7 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside -- | Run a 'DsM' action in the context of an existing 'ModGuts' initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a) initDsWithModGuts hsc_env guts thing_inside - = do { pm_iter_var <- newIORef 0 - ; cc_st_var <- newIORef newCostCentreState + = do { cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages ; let dflags = hsc_dflags hsc_env type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) @@ -235,8 +233,8 @@ initDsWithModGuts hsc_env guts thing_inside ids = concatMap bindsToIds (mg_binds guts) envs = mkDsEnvs dflags this_mod rdr_env type_env - fam_inst_env msg_var pm_iter_var - cc_st_var complete_matches + fam_inst_env msg_var cc_st_var + complete_matches ; runDs hsc_env envs thing_inside } @@ -264,9 +262,9 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef Int -> IORef CostCentreState - -> [CompleteMatch] -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var + -> IORef Messages -> IORef CostCentreState -> [CompleteMatch] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } @@ -285,7 +283,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span , dsl_delta = initDelta - , dsl_pm_iter = pmvar } in (gbl_env, lcl_env) @@ -393,22 +390,6 @@ getPmDelta = do { env <- getLclEnv; return (dsl_delta env) } updPmDelta :: Delta -> DsM a -> DsM a updPmDelta delta = updLclEnv (\env -> env { dsl_delta = delta }) --- | Increase the counter for elapsed pattern match check iterations. --- If the current counter is already over the limit, fail -incrCheckPmIterDs :: DsM Int -incrCheckPmIterDs = do - env <- getLclEnv - cnt <- readTcRef (dsl_pm_iter env) - max_iters <- maxPmCheckIterations <$> getDynFlags - if cnt >= max_iters - then failM - else updTcRef (dsl_pm_iter env) (+1) - return cnt - --- | Reset the counter for pattern match check iterations to zero -resetPmIterDs :: DsM () -resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 } - getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv ; return (RealSrcSpan (dsl_loc env)) } |