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

Add -ftype-function-stack to set type function stack depth

parent 01b12ca9
......@@ -18,8 +18,11 @@ mAX_TUPLE_SIZE = 62 -- Should really match the number
-- of decls in Data.Tuple
mAX_CONTEXT_REDUCTION_DEPTH :: Int
mAX_CONTEXT_REDUCTION_DEPTH = 200
-- Increase to 200; see Trac #5395
mAX_CONTEXT_REDUCTION_DEPTH = 20
mAX_TYPE_FUNCTION_REDUCTION_DEPTH :: Int
mAX_TYPE_FUNCTION_REDUCTION_DEPTH = 200
-- Needs to be much higher than mAX_CONTEXT_REDUCTION_DEPTH; see Trac #5395
wORD64_SIZE :: Int
wORD64_SIZE = 8
......
......@@ -623,6 +623,7 @@ data DynFlags = DynFlags {
mainModIs :: Module,
mainFunIs :: Maybe String,
ctxtStkDepth :: Int, -- ^ Typechecker context stack depth
tyFunStkDepth :: Int, -- ^ Typechecker type function stack depth
thisPackage :: PackageId, -- ^ name of package currently being compiled
......@@ -1326,6 +1327,7 @@ defaultDynFlags mySettings =
mainModIs = mAIN,
mainFunIs = Nothing,
ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH,
tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH,
thisPackage = mainPackageId,
......@@ -2397,6 +2399,7 @@ dynamic_flags = [
, Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing }))
, Flag "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s }))
, Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n }))
, Flag "ftype-function-depth" (intSuffix (\n d -> d{ tyFunStkDepth = n }))
, Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
, Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n }))
, Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing }))
......
......@@ -1403,12 +1403,17 @@ solverDepthErrorTcS cnt ct
; env0 <- tcInitTidyEnv
; let tidy_env = tidyFreeTyVars env0 (tyVarsOfType pred)
tidy_pred = tidyType tidy_env pred
; failWithTcM (tidy_env, hang msg 2 (ppr tidy_pred)) }
; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
where
loc = cc_loc ct
depth = ctLocDepth loc
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") ]
value = subGoalCounterValue cnt depth
msg CountConstraints =
vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int value
, ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
msg CountTyFunApps =
vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value
, ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ]
\end{code}
%************************************************************************
......
......@@ -116,7 +116,7 @@ solveInteract cts
= {-# SCC "solveInteract" #-}
withWorkList cts $
do { dyn_flags <- getDynFlags
; solve_loop (ctxtStkDepth dyn_flags) }
; solve_loop (maxSubGoalDepth dyn_flags) }
where
solve_loop max_depth
= {-# SCC "solve_loop" #-}
......@@ -140,7 +140,7 @@ data SelectWorkItem
-- must stop
| NextWorkItem Ct -- More work left, here's the next item to look at
selectNextWorkItem :: Int -- Max depth allowed
selectNextWorkItem :: SubGoalDepth -- Max depth allowed
-> TcS SelectWorkItem
selectNextWorkItem max_depth
= updWorkListTcS_return pick_next
......
......@@ -56,8 +56,8 @@ module TcRnTypes(
Implication(..),
SubGoalCounter(..),
SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth,
subGoalCounterValue, subGoalDepthExceeded,
SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded,
CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
ctLocDepth, bumpCtLocDepth,
setCtLocOrigin, setCtLocEnv,
......@@ -1513,6 +1513,13 @@ Each counter starts at zero and increases.
[W] d{8} : Int ~ a
and remembered as having depth 8.
Again, without UndecidableInstances, this counter is bounded, but without it
can resolve things ad infinitum. Hence there is a maximum level. But we use a
different maximum, as we expect possibly many more type function reductions
in sensible programs than type class constraints.
The flag -ftype-function-depth=n fixes the maximium level.
\begin{code}
data SubGoalCounter = CountConstraints | CountTyFunApps
......@@ -1530,6 +1537,8 @@ instance Outputable SubGoalDepth where
initialSubGoalDepth :: SubGoalDepth
initialSubGoalDepth = SubGoalDepth 0 0
maxSubGoalDepth :: DynFlags -> SubGoalDepth
maxSubGoalDepth dflags = SubGoalDepth (ctxtStkDepth dflags) (tyFunStkDepth dflags)
bumpSubGoalDepth :: SubGoalCounter -> SubGoalDepth -> SubGoalDepth
bumpSubGoalDepth CountConstraints (SubGoalDepth c f) = SubGoalDepth (c+1) f
......@@ -1539,11 +1548,11 @@ 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
subGoalDepthExceeded :: SubGoalDepth -> SubGoalDepth -> Maybe SubGoalCounter
subGoalDepthExceeded (SubGoalDepth mc mf) (SubGoalDepth c f)
| c > mc = Just CountConstraints
| f > mf = Just CountTyFunApps
| otherwise = Nothing
\end{code}
......
......@@ -722,6 +722,12 @@
<entry>dynamic</entry>
<entry></entry>
</row>
<row>
<entry><option>-ftype-function-depth=N</option><replaceable>n</replaceable></entry>
<entry>set the <link linkend="type-families">limit for type function reductions</link>. Default is 200.</entry>
<entry>dynamic</entry>
<entry></entry>
</row>
<row>
<entry><option>-XAllowAmbiguousTypes</option></entry>
<entry>Allow the user to write <link linkend="ambiguity">ambiguous types</link>,
......
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