Separate SubGoalDepthCounters (constraints and typ fun applications)
authorJoachim Breitner <mail@joachim-breitner.de>
Wed, 20 Nov 2013 10:04:15 +0000 (10:04 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Fri, 22 Nov 2013 17:51:11 +0000 (17:51 +0000)
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcRnTypes.lhs

index e348401..627bc3e 100644 (file)
@@ -1396,8 +1396,8 @@ are created by in RtClosureInspect.zonkRTTIType.
 %************************************************************************
 
 \begin{code}
-solverDepthErrorTcS :: Ct -> TcM a
-solverDepthErrorTcS ct
+solverDepthErrorTcS :: SubGoalCounter -> Ct -> TcM a
+solverDepthErrorTcS cnt ct
   = setCtLoc loc $
     do { pred <- zonkTcType (ctPred ct)
        ; env0 <- tcInitTidyEnv
@@ -1407,7 +1407,7 @@ solverDepthErrorTcS ct
   where
     loc   = cc_loc ct
     depth = ctLocDepth loc
-    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> ppr depth
+    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int (subGoalCounterValue cnt depth)
                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 \end{code}
 
index f0e90dd..82ffebf 100644 (file)
@@ -124,8 +124,8 @@ solveInteract cts
            ; case sel of
               NoWorkRemaining     -- Done, successfuly (modulo frozen)
                 -> return ()
-              MaxDepthExceeded ct -- Failure, depth exceeded
-                -> wrapErrTcS $ solverDepthErrorTcS ct
+              MaxDepthExceeded cnt ct -- Failure, depth exceeded
+                -> wrapErrTcS $ solverDepthErrorTcS cnt ct
               NextWorkItem ct     -- More work, loop around!
                 -> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
 
@@ -134,8 +134,10 @@ type SimplifierStage = WorkItem -> TcS StopOrContinue
 
 data SelectWorkItem
        = NoWorkRemaining      -- No more work left (effectively we're done!)
-       | MaxDepthExceeded Ct  -- More work left to do but this constraint has exceeded
-                              -- the max subgoal depth and we must stop
+       | MaxDepthExceeded SubGoalCounter Ct
+                              -- More work left to do but this constraint has exceeded
+                              -- the maximum depth for one of the subgoal counters and we
+                              -- must stop
        | NextWorkItem Ct      -- More work left, here's the next item to look at
 
 selectNextWorkItem :: Int -- Max depth allowed
@@ -149,8 +151,8 @@ selectNextWorkItem max_depth
           (Nothing,_)
               -> (NoWorkRemaining,wl)           -- No more work
           (Just ct, new_wl)
-              | subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
-              -> (MaxDepthExceeded ct,new_wl)
+              | Just cnt <- subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
+              -> (MaxDepthExceeded cnt ct,new_wl)
           (Just ct, new_wl)
               -> (NextWorkItem ct, new_wl)      -- New workitem and worklist
 
@@ -1437,8 +1439,9 @@ doTopReact inerts workItem
 --------------------
 doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi]
                -> CtLoc -> TcS TopInteractResult
+-- Try to use type-class instance declarations to simplify the constraint
 doTopReactDict inerts fl cls xis loc
-  | not (isWanted fl)
+  | not (isWanted fl)   -- Never use instances for Given or Derived constraints
   = try_fundeps_and_return
 
   | Just ev <- lookupSolvedDict inerts pred   -- Cached
@@ -1473,7 +1476,7 @@ doTopReactDict inerts fl cls xis loc
              ; setEvBind dict_id ev_term
              ; let mk_new_wanted ev
                        = CNonCanonical { cc_ev  = ev
-                                       , cc_loc = bumpCtLocDepth loc }
+                                       , cc_loc = bumpCtLocDepth CountConstraints loc }
              ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs))
              ; return $
                SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
@@ -1537,7 +1540,7 @@ doTopReactFunEq _ct fl fun_tc args xi loc
            ; case ctevs of
                [ctev] -> updWorkListTcS $ extendWorkListEq $
                          CNonCanonical { cc_ev = ctev
-                                       , cc_loc  = bumpCtLocDepth loc }
+                                       , cc_loc  = bumpCtLocDepth CountTyFunApps loc }
                ctevs -> -- No subgoal (because it's cached)
                         ASSERT( null ctevs) return ()
            ; return $ SomeTopInt { tir_rule = str
index 7699b22..0e5ea89 100644 (file)
@@ -55,8 +55,9 @@ module TcRnTypes(
         andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
 
         Implication(..),
+        SubGoalCounter(..),
         SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth,
-        subGoalDepthExceeded,
+        subGoalCounterValue, subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
         ctLocDepth, bumpCtLocDepth,
         setCtLocOrigin, setCtLocEnv,
@@ -1473,6 +1474,78 @@ NB:  either (a `canRewrite` b) or (b `canRewrite` a)
 canRewriteOrSame is similar but returns True for Wanted/Wanted.
 See the call sites for explanations.
 
+%************************************************************************
+%*                                                                      *
+            SubGoalDepth
+%*                                                                      *
+%************************************************************************
+
+Note [SubGoalDepth]
+~~~~~~~~~~~~~~~~~~~
+The 'SubGoalCounter' takes care of stopping the constraint solver from looping.
+Because of the different use-cases of regular constaints and type function
+applications, there are two independent counters. Therefore, this datatype is
+abstract. See Note [WorkList]
+
+Each counter starts at zero and increases.
+
+* The "dictionary constraint counter" counts the depth of type class
+  instance declarations.  Example:
+     [W] d{7} : Eq [Int]
+  That is d's dictionary-constraint depth is 7.  If we use the instance
+     $dfEqList :: Eq a => Eq [a]
+  to simplify it, we get
+     d{7} = $dfEqList d'{8}
+  where d'{8} : Eq Int, and d' has dictionary-constraint depth 8.
+
+  For civilised (decidable) instance declarations, each increase of
+  depth removes a type constructor from the type, so the depth never
+  gets big; i.e. is bounded by the structural depth of the type.
+
+  The flag -fcontext-stack=n (not very well named!) fixes the maximium
+  level.
+
+* The "type function reduction counter" does the same thing when resolving
+* qualities involving type functions. Example:
+  Assume we have a wanted at depth 7:
+    [W] d{7} : F () ~ a
+  If thre is an type function equation "F () = Int", this would be rewritten to
+    [W] d{8} : Int ~ a
+  and remembered as having depth 8.
+
+\begin{code}
+data SubGoalCounter = CountConstraints | CountTyFunApps
+
+data SubGoalDepth  -- See Note [SubGoalDepth]
+   = SubGoalDepth
+         {-# UNPACK #-} !Int      -- Dictionary constraints
+         {-# UNPACK #-} !Int      -- Type function reductions
+  deriving (Eq, Ord)
+
+instance Outputable SubGoalDepth where
+ ppr (SubGoalDepth c f) =  angleBrackets $
+        char 'C' <> colon <> int c <> comma <>
+        char 'F' <> colon <> int f
+
+initialSubGoalDepth :: SubGoalDepth
+initialSubGoalDepth = SubGoalDepth 0 0
+
+
+bumpSubGoalDepth :: SubGoalCounter -> SubGoalDepth -> SubGoalDepth
+bumpSubGoalDepth CountConstraints (SubGoalDepth c f) = SubGoalDepth (c+1) f
+bumpSubGoalDepth CountTyFunApps   (SubGoalDepth c f) = SubGoalDepth c (f+1)
+
+subGoalCounterValue :: SubGoalCounter -> SubGoalDepth -> Int
+subGoalCounterValue CountConstraints (SubGoalDepth c _) = c
+subGoalCounterValue CountTyFunApps   (SubGoalDepth _ f) = f
+
+subGoalDepthExceeded :: Int -> SubGoalDepth -> Maybe SubGoalCounter
+subGoalDepthExceeded max_depth (SubGoalDepth c f)
+        | c > max_depth = Just CountConstraints
+        | f > max_depth = Just CountTyFunApps
+        | otherwise     = Nothing
+\end{code}
+
 
 %************************************************************************
 %*                                                                      *
@@ -1487,31 +1560,13 @@ type will evolve...
 
 \begin{code}
 data CtLoc = CtLoc { ctl_origin :: CtOrigin
-                   , ctl_env ::  TcLclEnv
-                   , ctl_depth :: SubGoalDepth }
+                   , ctl_env    :: TcLclEnv
+                   , ctl_depth  :: !SubGoalDepth }
   -- The TcLclEnv includes particularly
   --    source location:  tcl_loc   :: SrcSpan
   --    context:          tcl_ctxt  :: [ErrCtxt]
   --    binder stack:     tcl_bndrs :: [TcIdBinders]
 
-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
@@ -1529,8 +1584,8 @@ ctLocOrigin = ctl_origin
 ctLocSpan :: CtLoc -> SrcSpan
 ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl
 
-bumpCtLocDepth :: CtLoc -> CtLoc
-bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }
+bumpCtLocDepth :: SubGoalCounter -> CtLoc -> CtLoc
+bumpCtLocDepth cnt loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth cnt d }
 
 setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
 setCtLocOrigin ctl orig = ctl { ctl_origin = orig }