diff options
author | Joachim Breitner <mail@joachim-breitner.de> | 2013-11-20 09:24:27 +0000 |
---|---|---|
committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-11-22 17:51:11 +0000 |
commit | e42ddfe17c92d4c4e446b9b88a4ab440370a0749 (patch) | |
tree | 616ae05e9d4571d456c133248785af4f260618be | |
parent | ea49c01540c0f363048f6b04ba106d7893578574 (diff) | |
download | haskell-e42ddfe17c92d4c4e446b9b88a4ab440370a0749.tar.gz |
Make SubGoalDepth a type of its own
In preparation of counting type function applications and constraint
resolving separately.
-rw-r--r-- | compiler/typecheck/TcErrors.lhs | 2 | ||||
-rw-r--r-- | compiler/typecheck/TcInteract.lhs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcRnMonad.lhs | 4 | ||||
-rw-r--r-- | compiler/typecheck/TcRnTypes.lhs | 29 | ||||
-rw-r--r-- | compiler/typecheck/TcSMonad.lhs | 2 |
5 files changed, 29 insertions, 12 deletions
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 3bf76b004c..e3484014c4 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -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} diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 3e434ab176..f0e90dd9a8 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -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 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index e35464cc97..cf8298f63b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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 diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index d71c30030b..7699b22ce7 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -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 } diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index d4e737d04e..d2b9ea3edf 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -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 } } |