Fix non-termination of SpecConstr (see #5550).
authorAmos Robinson <amos.robinson@gmail.com>
Thu, 28 Mar 2013 01:37:42 +0000 (12:37 +1100)
committerAmos Robinson <amos.robinson@gmail.com>
Thu, 28 Mar 2013 01:46:32 +0000 (12:46 +1100)
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
compiler/specialise/SpecConstr.lhs

index 3c82fd0..2f76c35 100644 (file)
@@ -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 }))
index c02b34a..d03baf0 100644 (file)
@@ -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