Commit e42ddfe1 authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Make SubGoalDepth a type of its own

In preparation of counting type function applications and constraint
resolving separately.
parent ea49c015
......@@ -1407,7 +1407,7 @@ solverDepthErrorTcS ct
where
loc = cc_loc ct
depth = ctLocDepth loc
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> ppr depth
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
\end{code}
......
......@@ -138,7 +138,7 @@ data SelectWorkItem
-- the max subgoal depth and we must stop
| NextWorkItem Ct -- More work left, here's the next item to look at
selectNextWorkItem :: SubGoalDepth -- Max depth allowed
selectNextWorkItem :: Int -- Max depth allowed
-> TcS SelectWorkItem
selectNextWorkItem max_depth
= updWorkListTcS_return pick_next
......@@ -149,7 +149,7 @@ selectNextWorkItem max_depth
(Nothing,_)
-> (NoWorkRemaining,wl) -- No more work
(Just ct, new_wl)
| ctLocDepth (cc_loc ct) > max_depth -- Depth exceeded
| subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
-> (MaxDepthExceeded ct,new_wl)
(Just ct, new_wl)
-> (NextWorkItem ct, new_wl) -- New workitem and worklist
......
......@@ -880,7 +880,9 @@ popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
getCtLoc :: CtOrigin -> TcM CtLoc
getCtLoc origin
= do { env <- getLclEnv
; return (CtLoc { ctl_origin = origin, ctl_env = env, ctl_depth = 0 }) }
; return (CtLoc { ctl_origin = origin
, ctl_env = env
, ctl_depth = initialSubGoalDepth }) }
setCtLoc :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
......
......@@ -48,14 +48,15 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt,
ctEvidence,
SubGoalDepth, mkNonCanonical, mkNonCanonicalCt,
ctEvidence, mkNonCanonical, mkNonCanonicalCt,
ctPred, ctEvPred, ctEvTerm, ctEvId,
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
Implication(..),
SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth,
subGoalDepthExceeded,
CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
ctLocDepth, bumpCtLocDepth,
setCtLocOrigin, setCtLocEnv,
......@@ -1493,14 +1494,28 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
-- context: tcl_ctxt :: [ErrCtxt]
-- binder stack: tcl_bndrs :: [TcIdBinders]
type SubGoalDepth = Int -- An ever increasing number used to restrict
-- simplifier iterations. Bounded by -fcontext-stack.
-- See Note [WorkList]
newtype SubGoalDepth = SubGoalDepth Int
-- An ever increasing number used to restrict
-- simplifier iterations. Bounded by -fcontext-stack.
-- See Note [WorkList]
instance Outputable SubGoalDepth where
ppr (SubGoalDepth n) = int n
initialSubGoalDepth :: SubGoalDepth
initialSubGoalDepth = SubGoalDepth 0
bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth
bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n+1)
subGoalDepthExceeded :: Int -> SubGoalDepth -> Bool
subGoalDepthExceeded max_depth (SubGoalDepth d) = d > max_depth
mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc
mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info
, ctl_env = env
, ctl_depth = 0 }
, ctl_depth = initialSubGoalDepth }
ctLocEnv :: CtLoc -> TcLclEnv
ctLocEnv = ctl_env
......@@ -1515,7 +1530,7 @@ ctLocSpan :: CtLoc -> SrcSpan
ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl
bumpCtLocDepth :: CtLoc -> CtLoc
bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 }
bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }
setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
......
......@@ -1034,7 +1034,7 @@ traceFireTcS ct doc
do { dflags <- getDynFlags
; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $
do { n <- TcM.readTcRef (tcs_count env)
; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct)))
; let msg = int n <> brackets (ppr (ctLocDepth (cc_loc ct)))
<+> ppr (ctEvidence ct) <> colon <+> doc
; TcM.debugDumpTcRn msg } }
......
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