[commit: ghc] wip/T8503: Add -ftype-function-stack to set type function stack depth (2dfbb80)
git at git.haskell.org
git at git.haskell.org
Wed Nov 20 10:24:53 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T8503
Link : http://ghc.haskell.org/trac/ghc/changeset/2dfbb800eb22f28322a6cd3e3bbeb371b0c123c5/ghc
>---------------------------------------------------------------
commit 2dfbb800eb22f28322a6cd3e3bbeb371b0c123c5
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Nov 20 10:24:52 2013 +0000
Add -ftype-function-stack to set type function stack depth
>---------------------------------------------------------------
2dfbb800eb22f28322a6cd3e3bbeb371b0c123c5
compiler/main/Constants.lhs | 7 +++++--
compiler/main/DynFlags.hs | 3 +++
compiler/typecheck/TcErrors.lhs | 11 ++++++++---
compiler/typecheck/TcInteract.lhs | 4 ++--
compiler/typecheck/TcRnTypes.lhs | 16 +++++++++-------
docs/users_guide/flags.xml | 6 ++++++
6 files changed, 33 insertions(+), 14 deletions(-)
diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs
index 497bae5..a891336 100644
--- a/compiler/main/Constants.lhs
+++ b/compiler/main/Constants.lhs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 53e5297..f153d1f 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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-stack" (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 }))
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 627bc3e..a92cff0 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -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-stack=N to increase stack size to N") ]
\end{code}
%************************************************************************
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index ad34940..4ff56df 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -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
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index df62412..7b616d5 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -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,
@@ -1497,6 +1497,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
@@ -1506,11 +1508,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}
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index d5f4b8b..2ef9d24 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -723,6 +723,12 @@
<entry></entry>
</row>
<row>
+ <entry><option>-ftype-function-stack=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>,
and the type inference engine to infer them.
More information about the ghc-commits
mailing list