diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-08-17 14:38:02 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-08-17 14:38:52 +0100 |
commit | 58e7316e919abac55bf3ea0213bc92521ec94081 (patch) | |
tree | 88d5d8fc9fa63c0ec6e2c96ebc85b90971d18fa8 | |
parent | f352e5cd7bb629fe0ca3b913bfbe7bee43d62f3a (diff) | |
download | haskell-58e7316e919abac55bf3ea0213bc92521ec94081.tar.gz |
Refactor nestImplicTcS
Simpler code, and simpler to understand.
No change in behaviour.
-rw-r--r-- | compiler/typecheck/TcSMonad.hs | 62 |
1 files changed, 32 insertions, 30 deletions
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 29837a9d69..687168bfa1 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -2380,8 +2380,11 @@ bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env -- | Mark variables as used filling a coercion hole useVars :: TyCoVarSet -> TcS () -useVars vars = TcS $ \env -> do { let ref = tcs_used_tcvs env - ; TcM.updTcRef ref (`unionVarSet` vars) } +useVars vars = TcS $ \env -> useVarsTcM (tcs_used_tcvs env) vars + +-- | Like 'useVars' but in the TcM monad +useVarsTcM :: IORef TyCoVarSet -> TyCoVarSet -> TcM () +useVarsTcM ref vars = TcM.updTcRef ref (`unionVarSet` vars) csTraceTcS :: SDoc -> TcS () csTraceTcS doc @@ -2497,45 +2500,44 @@ nestImplicTcS :: Maybe EvBindsVar -> TyCoVarSet -- bound in this implication -- coercion holes (for redundant-constraint -- tracking) nestImplicTcS m_ref bound_tcvs inner_tclvl (TcS thing_inside) - = do { (res, used_tcvs) <- - TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - , tcs_need_deriveds = solve_deriveds - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs } + = TcS $ \ TcSEnv { tcs_unified = unified_var + , tcs_inerts = old_inert_var + , tcs_count = count + , tcs_used_tcvs = used_var + , tcs_need_deriveds = solve_deriveds + } -> + do { inerts <- TcM.readTcRef old_inert_var + ; let nest_inert = inerts { inert_flat_cache = emptyExactFunEqs } -- See Note [Do not inherit the flat cache] - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; new_used_var <- TcM.newTcRef emptyVarSet - ; let nest_env = TcSEnv { tcs_ev_binds = m_ref - , tcs_unified = unified_var - , tcs_count = count - , tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var - , tcs_used_tcvs = new_used_var - , tcs_need_deriveds = solve_deriveds } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_used_var <- TcM.newTcRef emptyVarSet + ; let nest_env = TcSEnv { tcs_ev_binds = m_ref + , tcs_unified = unified_var + , tcs_count = count + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var + , tcs_used_tcvs = new_used_var + , tcs_need_deriveds = solve_deriveds } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env #ifdef DEBUG - -- Perform a check that the thing_inside did not cause cycles - ; whenIsJust m_ref $ \ ref -> - do { ev_binds <- TcM.getTcEvBinds ref - ; checkForCyclicBinds ev_binds } + -- Perform a check that the thing_inside did not cause cycles + ; whenIsJust m_ref $ \ ref -> + do { ev_binds <- TcM.getTcEvBinds ref + ; checkForCyclicBinds ev_binds } #endif - ; used_tcvs <- TcM.readTcRef new_used_var - ; return (res, used_tcvs) } + ; used_tcvs <- TcM.readTcRef new_used_var ; local_ev_vars <- case m_ref of Nothing -> return emptyVarSet - Just ref -> do { binds <- wrapTcS $ TcM.getTcEvBinds ref + Just ref -> do { binds <- TcM.getTcEvBinds ref ; return $ mkVarSet $ map evBindVar $ bagToList binds } ; let all_locals = bound_tcvs `unionVarSet` local_ev_vars (inner_used_tcvs, outer_used_tcvs) = partitionVarSet (`elemVarSet` all_locals) used_tcvs - ; useVars outer_used_tcvs + ; useVarsTcM used_var outer_used_tcvs ; return (res, inner_used_tcvs) } |