[commit: ghc] master: Fix non-termination of SpecConstr (see #5550). ForceSpecConstr will now only specialise recursive types a finite number of times. There is a new option -fspec-constr-recursive, with a default value of 3. (81d55a9)
Amos Robinson
amos.robinson at gmail.com
Thu Mar 28 05:24:46 CET 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : master
https://github.com/ghc/ghc/commit/81d55a9ec28d9d7c8b1492516ebd58c5ff90c0e8
>---------------------------------------------------------------
commit 81d55a9ec28d9d7c8b1492516ebd58c5ff90c0e8
Author: Amos Robinson <amos.robinson at gmail.com>
Date: Thu Mar 28 12:37:42 2013 +1100
Fix non-termination of SpecConstr (see #5550).
ForceSpecConstr will now only specialise recursive types a finite number of times.
There is a new option -fspec-constr-recursive, with a default value of 3.
>---------------------------------------------------------------
compiler/main/DynFlags.hs | 4 +++
compiler/specialise/SpecConstr.lhs | 64 +++++++++++++++++++++++++++-----------
2 files changed, 50 insertions(+), 18 deletions(-)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3c82fd0..2f76c35 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -569,6 +569,8 @@ data DynFlags = DynFlags {
simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks
specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr
specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function
+ specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types
+ -- Not optional; otherwise ForceSpecConstr can diverge.
liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
@@ -1217,6 +1219,7 @@ defaultDynFlags mySettings =
simplTickFactor = 100,
specConstrThreshold = Just 2000,
specConstrCount = Just 3,
+ specConstrRecursive = 3,
liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
historySize = 20,
@@ -2227,6 +2230,7 @@ dynamic_flags = [
, Flag "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing }))
, Flag "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n }))
, Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing }))
+ , Flag "fspec-constr-recursive" (intSuffix (\n d -> d{ specConstrRecursive = n }))
, Flag "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n }))
, Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing }))
, Flag "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s }))
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index c02b34a..d03baf0 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -31,6 +31,7 @@ import DataCon
import Coercion hiding( substTy, substCo )
import Rules
import Type hiding ( substTy )
+import TyCon ( isRecursiveTyCon )
import Id
import MkCore ( mkImpossibleExpr )
import Var
@@ -457,6 +458,8 @@ sc_force to True when calling specLoop. This flag does three things:
(see specialise)
* Specialise even for arguments that are not scrutinised in the loop
(see argToPat; Trac #4488)
+ * Only specialise on recursive types a finite number of times
+ (see is_too_recursive; Trac #5550)
This flag is inherited for nested non-recursive bindings (which are likely to
be join points and hence should be fully specialised) but reset for nested
@@ -619,21 +622,25 @@ specConstrProgram guts
%************************************************************************
\begin{code}
-data ScEnv = SCE { sc_dflags :: DynFlags,
- sc_size :: Maybe Int, -- Size threshold
- sc_count :: Maybe Int, -- Max # of specialisations for any one fn
+data ScEnv = SCE { sc_dflags :: DynFlags,
+ sc_size :: Maybe Int, -- Size threshold
+ sc_count :: Maybe Int, -- Max # of specialisations for any one fn
-- See Note [Avoiding exponential blowup]
- sc_force :: Bool, -- Force specialisation?
+
+ sc_recursive :: Int, -- Max # of specialisations over recursive type.
+ -- Stops ForceSpecConstr from diverging.
+
+ sc_force :: Bool, -- Force specialisation?
-- See Note [Forcing specialisation]
- sc_subst :: Subst, -- Current substitution
+ sc_subst :: Subst, -- Current substitution
-- Maps InIds to OutExprs
sc_how_bound :: HowBoundEnv,
-- Binds interesting non-top-level variables
-- Domain is OutVars (*after* applying the substitution)
- sc_vals :: ValueEnv,
+ sc_vals :: ValueEnv,
-- Domain is OutIds (*after* applying the substitution)
-- Used even for top-level bindings (but not imported ones)
@@ -665,13 +672,14 @@ instance Outputable Value where
---------------------
initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv dflags anns
- = SCE { sc_dflags = dflags,
- sc_size = specConstrThreshold dflags,
- sc_count = specConstrCount dflags,
- sc_force = False,
- sc_subst = emptySubst,
- sc_how_bound = emptyVarEnv,
- sc_vals = emptyVarEnv,
+ = SCE { sc_dflags = dflags,
+ sc_size = specConstrThreshold dflags,
+ sc_count = specConstrCount dflags,
+ sc_recursive = specConstrRecursive dflags,
+ sc_force = False,
+ sc_subst = emptySubst,
+ sc_how_bound = emptyVarEnv,
+ sc_vals = emptyVarEnv,
sc_annotations = anns }
data HowBound = RecFun -- These are the recursive functions for which
@@ -1518,15 +1526,35 @@ callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPa
callsToPats env done_specs bndr_occs calls
= do { mb_pats <- mapM (callToPats env bndr_occs) calls
- ; let good_pats :: [CallPat]
+ ; let good_pats :: [(CallPat, ValueEnv)]
good_pats = catMaybes mb_pats
done_pats = [p | OS p _ _ _ <- done_specs]
is_done p = any (samePat p) done_pats
+ no_recursive = map fst (filterOut (is_too_recursive env) good_pats)
; return (any isNothing mb_pats,
- filterOut is_done (nubBy samePat good_pats)) }
+ filterOut is_done (nubBy samePat no_recursive)) }
+
+is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool
+ -- Count the number of recursive constructors in a call pattern,
+ -- filter out if there are more than the maximum.
+ -- This is only necessary if ForceSpecConstr is in effect:
+ -- otherwise specConstrCount will cause specialisation to terminate.
+is_too_recursive env ((_,exprs), val_env)
+ = sc_force env && maximum (map go exprs) > sc_recursive env
+ where
+ go e
+ | Just (ConVal (DataAlt dc) args) <- isValue val_env e
+ , isRecursiveTyCon (dataConTyCon dc)
+ = 1 + sum (map go args)
+
+ |App f a <- e
+ = go f + go a
+
+ | otherwise
+ = 0
-callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
+callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe (CallPat, ValueEnv))
-- The [Var] is the variables to quantify over in the rule
-- Type variables come first, since they may scope
-- over the following term variables
@@ -1553,9 +1581,9 @@ callToPats env bndr_occs (con_env, args)
sanitise id = id `setIdType` expandTypeSynonyms (idType id)
-- See Note [Free type variables of the qvar types]
- ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $
+ ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $
if interesting
- then return (Just (qvars', pats))
+ then return (Just ((qvars', pats), con_env))
else return Nothing }
-- argToPat takes an actual argument, and returns an abstracted
More information about the ghc-commits
mailing list