<div dir="ltr"><div><div><div>Hi Simon,<br></div>No problem, I'll commit the extra notes tomorrow.<br></div>I put the test case in simplCore/should_compile/T5550.hs. Does that seem like a reasonable place? I couldn't see any directory specifically for sanity-checking optimisations or specialise.<br>
<br></div>Amos<br></div><div class="gmail_extra"><br><br><div class="gmail_quote">On Tue, Apr 2, 2013 at 9:37 PM, Simon Peyton-Jones <span dir="ltr"><<a href="mailto:simonpj@microsoft.com" target="_blank">simonpj@microsoft.com</a>></span> wrote:<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">Amos<br>
<br>
Thanks for doing this.<br>
<br>
Could you pls add a<br>
Note [Limit recursive specialisation]<br>
in SpecConstr, that explains (a) the problem, with an example, and (b) the solution. Plus, mention the relevant Trac tickets.<br>
<br>
It'll take you a few minutes to write, but it's worth it. That way in five years time, when your successor is staring at your code, he or she will have an insight into your thinking.<br>
<br>
Also is there a test case you can give, in the testsuite, which sends GHC into a loop without it, but works fine with it?<br>
<br>
Thanks<br>
<br>
Simon<br>
<div class="im"><br>
| -----Original Message-----<br>
| From: <a href="mailto:ghc-commits-bounces@haskell.org">ghc-commits-bounces@haskell.org</a> [mailto:<a href="mailto:ghc-commits-">ghc-commits-</a><br>
| <a href="mailto:bounces@haskell.org">bounces@haskell.org</a>] On Behalf Of Amos Robinson<br>
| Sent: 28 March 2013 04:25<br>
| To: <a href="mailto:ghc-commits@haskell.org">ghc-commits@haskell.org</a><br>
| Subject: [commit: ghc] master: Fix non-termination of SpecConstr (see<br>
| #5550). ForceSpecConstr will now only specialise recursive types a<br>
| finite number of times. There is a new option -fspec-constr-recursive,<br>
</div><div><div class="h5">| with a default value of 3. (81d55a9)<br>
|<br>
| Repository : <a href="http://darcs.haskell.org/ghc.git/" target="_blank">http://darcs.haskell.org/ghc.git/</a><br>
|<br>
| On branch : master<br>
|<br>
| <a href="https://github.com/ghc/ghc/commit/81d55a9ec28d9d7c8b1492516ebd58c5ff90c0" target="_blank">https://github.com/ghc/ghc/commit/81d55a9ec28d9d7c8b1492516ebd58c5ff90c0</a><br>
| e8<br>
|<br>
| >---------------------------------------------------------------<br>
|<br>
| commit 81d55a9ec28d9d7c8b1492516ebd58c5ff90c0e8<br>
| Author: Amos Robinson <<a href="mailto:amos.robinson@gmail.com">amos.robinson@gmail.com</a>><br>
| Date: Thu Mar 28 12:37:42 2013 +1100<br>
|<br>
| Fix non-termination of SpecConstr (see #5550).<br>
| ForceSpecConstr will now only specialise recursive types a finite<br>
| number of times.<br>
| There is a new option -fspec-constr-recursive, with a default value<br>
| of 3.<br>
|<br>
| >---------------------------------------------------------------<br>
|<br>
| compiler/main/DynFlags.hs | 4 +++<br>
| compiler/specialise/SpecConstr.lhs | 64 +++++++++++++++++++++++++++----<br>
| -------<br>
| 2 files changed, 50 insertions(+), 18 deletions(-)<br>
|<br>
| diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index<br>
| 3c82fd0..2f76c35 100644<br>
| --- a/compiler/main/DynFlags.hs<br>
| +++ b/compiler/main/DynFlags.hs<br>
| @@ -569,6 +569,8 @@ data DynFlags = DynFlags {<br>
| simplTickFactor :: Int, -- ^ Multiplier for simplifier<br>
| ticks<br>
| specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr<br>
| specConstrCount :: Maybe Int, -- ^ Max number of<br>
| specialisations for any one function<br>
| + specConstrRecursive :: Int, -- ^ Max number of<br>
| specialisations for recursive types<br>
| + -- Not optional; otherwise<br>
| ForceSpecConstr can diverge.<br>
| liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase<br>
| floatLamArgs :: Maybe Int, -- ^ Arg count for lambda<br>
| floating<br>
| -- See<br>
| CoreMonad.FloatOutSwitches<br>
| @@ -1217,6 +1219,7 @@ defaultDynFlags mySettings =<br>
| simplTickFactor = 100,<br>
| specConstrThreshold = Just 2000,<br>
| specConstrCount = Just 3,<br>
| + specConstrRecursive = 3,<br>
| liberateCaseThreshold = Just 2000,<br>
| floatLamArgs = Just 0, -- Default: float only if no<br>
| fvs<br>
| historySize = 20,<br>
| @@ -2227,6 +2230,7 @@ dynamic_flags = [<br>
| , Flag "fno-spec-constr-threshold" (noArg (\d -> d{<br>
| specConstrThreshold = Nothing }))<br>
| , Flag "fspec-constr-count" (intSuffix (\n d -> d{<br>
| specConstrCount = Just n }))<br>
| , Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount<br>
| = Nothing }))<br>
| + , Flag "fspec-constr-recursive" (intSuffix (\n d -> d{<br>
| specConstrRecursive = n }))<br>
| , Flag "fliberate-case-threshold" (intSuffix (\n d -> d{<br>
| liberateCaseThreshold = Just n }))<br>
| , Flag "fno-liberate-case-threshold" (noArg (\d -> d{<br>
| liberateCaseThreshold = Nothing }))<br>
| , Flag "frule-check" (sepArg (\s d -> d{ ruleCheck =<br>
| Just s }))<br>
| diff --git a/compiler/specialise/SpecConstr.lhs<br>
| b/compiler/specialise/SpecConstr.lhs<br>
| index c02b34a..d03baf0 100644<br>
| --- a/compiler/specialise/SpecConstr.lhs<br>
| +++ b/compiler/specialise/SpecConstr.lhs<br>
| @@ -31,6 +31,7 @@ import DataCon<br>
| import Coercion hiding( substTy, substCo )<br>
| import Rules<br>
| import Type hiding ( substTy )<br>
| +import TyCon ( isRecursiveTyCon )<br>
| import Id<br>
| import MkCore ( mkImpossibleExpr )<br>
| import Var<br>
| @@ -457,6 +458,8 @@ sc_force to True when calling specLoop. This flag<br>
| does three things:<br>
| (see specialise)<br>
| * Specialise even for arguments that are not scrutinised in the loop<br>
| (see argToPat; Trac #4488)<br>
| + * Only specialise on recursive types a finite number of times<br>
| + (see is_too_recursive; Trac #5550)<br>
|<br>
| This flag is inherited for nested non-recursive bindings (which are<br>
| likely to be join points and hence should be fully specialised) but<br>
| reset for nested @@ -619,21 +622,25 @@ specConstrProgram guts<br>
|<br>
| %***********************************************************************<br>
| *<br>
|<br>
| \begin{code}<br>
| -data ScEnv = SCE { sc_dflags :: DynFlags,<br>
| - sc_size :: Maybe Int, -- Size threshold<br>
| - sc_count :: Maybe Int, -- Max # of<br>
| specialisations for any one fn<br>
| +data ScEnv = SCE { sc_dflags :: DynFlags,<br>
| + sc_size :: Maybe Int, -- Size threshold<br>
| + sc_count :: Maybe Int, -- Max # of<br>
| specialisations for any one fn<br>
| -- See Note [Avoiding<br>
| exponential blowup]<br>
| - sc_force :: Bool, -- Force<br>
| specialisation?<br>
| +<br>
| + sc_recursive :: Int, -- Max # of<br>
| specialisations over recursive type.<br>
| + -- Stops<br>
| ForceSpecConstr from diverging.<br>
| +<br>
| + sc_force :: Bool, -- Force<br>
| specialisation?<br>
| -- See Note [Forcing<br>
| specialisation]<br>
|<br>
| - sc_subst :: Subst, -- Current substitution<br>
| + sc_subst :: Subst, -- Current substitution<br>
| -- Maps InIds to<br>
| OutExprs<br>
|<br>
| sc_how_bound :: HowBoundEnv,<br>
| -- Binds interesting non-top-level variables<br>
| -- Domain is OutVars (*after* applying the<br>
| substitution)<br>
|<br>
| - sc_vals :: ValueEnv,<br>
| + sc_vals :: ValueEnv,<br>
| -- Domain is OutIds (*after* applying the<br>
| substitution)<br>
| -- Used even for top-level bindings (but not<br>
| imported ones)<br>
|<br>
| @@ -665,13 +672,14 @@ instance Outputable Value where<br>
| ---------------------<br>
| initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv<br>
| initScEnv dflags anns<br>
| - = SCE { sc_dflags = dflags,<br>
| - sc_size = specConstrThreshold dflags,<br>
| - sc_count = specConstrCount dflags,<br>
| - sc_force = False,<br>
| - sc_subst = emptySubst,<br>
| - sc_how_bound = emptyVarEnv,<br>
| - sc_vals = emptyVarEnv,<br>
| + = SCE { sc_dflags = dflags,<br>
| + sc_size = specConstrThreshold dflags,<br>
| + sc_count = specConstrCount dflags,<br>
| + sc_recursive = specConstrRecursive dflags,<br>
| + sc_force = False,<br>
| + sc_subst = emptySubst,<br>
| + sc_how_bound = emptyVarEnv,<br>
| + sc_vals = emptyVarEnv,<br>
| sc_annotations = anns }<br>
|<br>
| data HowBound = RecFun -- These are the recursive functions for which<br>
| @@ -1518,15 +1526,35 @@ callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -><br>
| [Call] -> UniqSM (Bool, [CallPa callsToPats env done_specs bndr_occs<br>
| calls<br>
| = do { mb_pats <- mapM (callToPats env bndr_occs) calls<br>
|<br>
| - ; let good_pats :: [CallPat]<br>
| + ; let good_pats :: [(CallPat, ValueEnv)]<br>
| good_pats = catMaybes mb_pats<br>
| done_pats = [p | OS p _ _ _ <- done_specs]<br>
| is_done p = any (samePat p) done_pats<br>
| + no_recursive = map fst (filterOut (is_too_recursive env)<br>
| + good_pats)<br>
|<br>
| ; return (any isNothing mb_pats,<br>
| - filterOut is_done (nubBy samePat good_pats)) }<br>
| + filterOut is_done (nubBy samePat no_recursive)) }<br>
| +<br>
| +is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool<br>
| + -- Count the number of recursive constructors in a call pattern,<br>
| + -- filter out if there are more than the maximum.<br>
| + -- This is only necessary if ForceSpecConstr is in effect:<br>
| + -- otherwise specConstrCount will cause specialisation to<br>
| terminate.<br>
</div></div>| +is_too_recursive env ((_,exprs), val_env) = sc_force env && maximum<br>
| +(map go exprs) > sc_recursive env where<br>
<div class="im">| + go e<br>
| + | Just (ConVal (DataAlt dc) args) <- isValue val_env e<br>
| + , isRecursiveTyCon (dataConTyCon dc)<br>
| + = 1 + sum (map go args)<br>
| +<br>
| + |App f a <- e<br>
| + = go f + go a<br>
| +<br>
| + | otherwise<br>
| + = 0<br>
|<br>
| -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)<br>
| +callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe (CallPat,<br>
</div>| +ValueEnv))<br>
<div class="HOEnZb"><div class="h5">| -- The [Var] is the variables to quantify over in the rule<br>
| -- Type variables come first, since they may scope<br>
| -- over the following term variables<br>
| @@ -1553,9 +1581,9 @@ callToPats env bndr_occs (con_env, args)<br>
| sanitise id = id `setIdType` expandTypeSynonyms (idType<br>
| id)<br>
| -- See Note [Free type variables of the qvar types]<br>
|<br>
| - ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr<br>
| bndr_occs) $<br>
| + ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $<br>
| if interesting<br>
| - then return (Just (qvars', pats))<br>
| + then return (Just ((qvars', pats), con_env))<br>
| else return Nothing }<br>
|<br>
| -- argToPat takes an actual argument, and returns an abstracted<br>
|<br>
|<br>
|<br>
| _______________________________________________<br>
| ghc-commits mailing list<br>
| <a href="mailto:ghc-commits@haskell.org">ghc-commits@haskell.org</a><br>
| <a href="http://www.haskell.org/mailman/listinfo/ghc-commits" target="_blank">http://www.haskell.org/mailman/listinfo/ghc-commits</a><br>
</div></div></blockquote></div><br></div>