Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Modest refactoring (put bumpStepCounter into traceFireTcS, and other …

…simple things)
  • Loading branch information...
commit b3f2f732c9a6e82cb2a7fc990055d669aa4d7e02 1 parent 453e0ce
@simonpj simonpj authored
Showing with 37 additions and 47 deletions.
  1. +28 −36 compiler/typecheck/TcInteract.lhs
  2. +9 −11 compiler/typecheck/TcSMonad.lhs
View
64 compiler/typecheck/TcInteract.lhs
@@ -296,11 +296,10 @@ spontaneousSolveStage workItem
SPSolved new_tv
-- Post: tv ~ xi is now in TyBinds, no need to put in inerts as well
-- see Note [Spontaneously solved in TyBinds]
- -> do { bumpStepCountTcS
- ; traceFireTcS workItem $
- ptext (sLit "Spontaneously solved:") <+> ppr workItem
- ; kickOutRewritable Given new_tv
- ; return Stop } }
+ -> do { traceFireTcS workItem $
+ ptext (sLit "Spontaneously solved:") <+> ppr workItem
+ ; kickOutRewritable Given new_tv
+ ; return Stop } }
\end{code}
Note [Spontaneously solved in TyBinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -649,19 +648,16 @@ interactWithInertsStage wi
, ptext (sLit "WorkItem =") <+> ppr wi ]
; case ir of
IRWorkItemConsumed { ir_fire = rule }
- -> do { bumpStepCountTcS
- ; traceFireTcS wi (mk_msg rule (text "WorkItemConsumed"))
+ -> do { traceFireTcS wi (mk_msg rule (text "WorkItemConsumed"))
; insertInertItemTcS atomic_inert
; return Stop }
IRReplace { ir_fire = rule }
- -> do { bumpStepCountTcS
- ; traceFireTcS atomic_inert
+ -> do { traceFireTcS atomic_inert
(mk_msg rule (text "InertReplace"))
; insertInertItemTcS wi
; return Stop }
IRInertConsumed { ir_fire = rule }
- -> do { bumpStepCountTcS
- ; traceFireTcS atomic_inert
+ -> do { traceFireTcS atomic_inert
(mk_msg rule (text "InertItemConsumed"))
; return (ContinueWith wi) }
IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now.
@@ -726,8 +722,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
, cc_tyargs = args1, cc_rhs = xi1, cc_loc = d1 })
wi@(CFunEqCan { cc_ev = ev2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2, cc_loc = d2 })
- | fl1 `canSolve` fl2 && lhss_match
- = do { traceTcS "interact with inerts: FunEq/FunEq" $
+ | fl1 `canSolve` fl2
+ = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
+ do { traceTcS "interact with inerts: FunEq/FunEq" $
vcat [ text "workItem =" <+> ppr wi
, text "inertItem=" <+> ppr ii ]
@@ -744,8 +741,9 @@ doInteractWithInert ii@(CFunEqCan { cc_ev = ev1, cc_fun = tc1
; emitWorkNC d2 ctevs
; return (IRWorkItemConsumed "FunEq/FunEq") }
- | fl2 `canSolve` fl1 && lhss_match
- = do { traceTcS "interact with inerts: FunEq/FunEq" $
+ | fl2 `canSolve` fl1
+ = ASSERT( lhss_match ) -- extractRelevantInerts ensures this
+ do { traceTcS "interact with inerts: FunEq/FunEq" $
vcat [ text "workItem =" <+> ppr wi
, text "inertItem=" <+> ppr ii ]
@@ -1027,7 +1025,7 @@ So our problem is this
We may add the given in the inert set, along with its superclasses
[assuming we don't fail because there is a matching instance, see
- tryTopReact, given case ]
+ topReactionsStage, given case ]
Inert:
d0 :_g Foo t
WorkList
@@ -1339,20 +1337,14 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
*********************************************************************************
\begin{code}
-topReactionsStage :: SimplifierStage
-topReactionsStage workItem
- = tryTopReact workItem
-
-
-tryTopReact :: WorkItem -> TcS StopOrContinue
-tryTopReact wi
+topReactionsStage :: WorkItem -> TcS StopOrContinue
+topReactionsStage wi
= do { inerts <- getTcSInerts
; tir <- doTopReact inerts wi
; case tir of
NoTopInt -> return (ContinueWith wi)
SomeTopInt rule what_next
- -> do { bumpStepCountTcS
- ; traceFireTcS wi $
+ -> do { traceFireTcS wi $
vcat [ ptext (sLit "Top react:") <+> text rule
, text "WorkItem =" <+> ppr wi ]
; return what_next } }
@@ -1440,18 +1432,18 @@ doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi
-> CtLoc -> TcS TopInteractResult
doTopReactFunEq ct fl fun_tc args xi loc
= ASSERT (isSynFamilyTyCon fun_tc) -- No associated data families have
- -- reached that far
-
- -- First look in the cache of solved funeqs
+ -- reached this far
+ -- Look in the cache of solved funeqs
do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
; case lookupFamHead fun_eq_cache fam_ty of {
- Just (CFunEqCan { cc_ev = ctev, cc_rhs = rhs_ty })
- -> ASSERT( not (isDerived ctev) )
- succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ;
- Just {} -> pprPanic "doTopReactFunEq" (ppr ct) ;
- Nothing ->
-
- -- No cached solved, so look up in top-level instances
+ Just (CFunEqCan { cc_ev = ctev, cc_rhs = rhs_ty })
+ | ctEvFlavour ctev `canRewrite` ctEvFlavour fl
+ -> ASSERT( not (isDerived ctev) )
+ succeed_with "Fun/Cache" (evTermCoercion (ctEvTerm ctev)) rhs_ty ;
+ Just ct' -> pprPanic "doTopReactFunEq" (ppr ct') ;
+ Nothing ->
+
+ -- Look up in top-level instances
do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of {
Nothing -> return NoTopInt ;
@@ -1462,7 +1454,7 @@ doTopReactFunEq ct fl fun_tc args xi loc
unless (isDerived fl) (addSolvedFunEq ct fam_ty)
; let coe_ax = famInstAxiom famInst
- ; succeed_with "Fun/Top"(mkTcAxInstCo coe_ax rep_tys)
+ ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax rep_tys)
(mkAxInstRHS coe_ax rep_tys) } } } } }
where
fam_ty = mkTyConApp fun_tc args
View
20 compiler/typecheck/TcSMonad.lhs
@@ -32,7 +32,7 @@ module TcSMonad (
mkGivenLoc,
TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
- traceFireTcS, bumpStepCountTcS,
+ traceFireTcS,
tryTcS, nestTcS, nestImplicTcS, recoverTcS,
wrapErrTcS, wrapWarnTcS,
@@ -168,8 +168,8 @@ mkKindErrorCtxtTcS ty1 ki1 ty2 ki2
%* *
%************************************************************************
-Note [WorkList]
-~~~~~~~~~~~~~~~
+Note [WorkList priorities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
A WorkList contains canonical and non-canonical items (of all flavors).
Notice that each Ct now has a simplification depth. We may
consider using this depth for prioritization as well in the future.
@@ -180,6 +180,7 @@ so that it's easier to deal with them first, but the separation
is not strictly necessary. Notice that non-canonical constraints
are also parts of the worklist.
+
Note [NonCanonical Semantics]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that canonical constraints involve a CNonCanonical constructor. In the worklist
@@ -220,7 +221,7 @@ extractDeque (DQ [] bs) = case reverse bs of
(a:as) -> Just (DQ as [], a)
[] -> panic "extractDeque"
--- See Note [WorkList]
+-- See Note [WorkList priorities]
data WorkList = WorkList { wl_eqs :: [Ct]
, wl_funeqs :: Deque Ct
, wl_rest :: [Ct]
@@ -959,17 +960,14 @@ traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
instance HasDynFlags TcS where
getDynFlags = wrapTcS getDynFlags
-bumpStepCountTcS :: TcS ()
-bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
- ; n <- TcM.readTcRef ref
- ; TcM.writeTcRef ref (n+1) }
-
traceFireTcS :: Ct -> SDoc -> TcS ()
--- Dump a rule-firing trace
+-- Dump a rule-firing trace, and bumpt the counter
traceFireTcS ct doc
= TcS $ \env ->
TcM.ifDOptM Opt_D_dump_cs_trace $
- do { n <- TcM.readTcRef (tcs_count env)
+ do { let count_ref = tcs_count env
+ ; n <- TcM.readTcRef count_ref
+ ; TcM.writeTcRef count_ref (n+1)
; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct))) <+> doc
; TcM.dumpTcRn msg }
Please sign in to comment.
Something went wrong with that request. Please try again.