Make Call Arity aggressive only in the second runwip/T10918

not that I believe that this is a viable solution, but it should be a
way to work around
https://ghc.haskell.org/trac/ghc/ticket/10918#comment:10
and hopefully tell me whether the whole thing is actually useful.

4 files changed, 61 insertions, 59 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index da08c21fca..20c70e2dc1 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -224,7 +224,7 @@ coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
 coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
 coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
 coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
-coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
+coreDumpFlag (CoreDoCallArity {})     = Just Opt_D_dump_call_arity
 coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
 coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index 9a59c225ac..e25c0b449c 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -399,31 +399,32 @@ the case for Core!
 
 -- Main entry point
 
-callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
-callArityAnalProgram _dflags binds = binds'
+callArityAnalProgram :: Bool -> DynFlags -> CoreProgram -> CoreProgram
+callArityAnalProgram late _dflags binds = binds'
   where
-    (_, binds') = callArityTopLvl [] emptyVarSet binds
+    (_, binds') = callArityTopLvl late [] emptyVarSet binds
 
 -- See Note [Analysing top-level-binds]
-callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
-callArityTopLvl exported _ []
+callArityTopLvl :: Bool -> [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
+callArityTopLvl _ exported _ []
     = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
       , [] )
-callArityTopLvl exported int1 (b:bs)
+callArityTopLvl late exported int1 (b:bs)
     = (ae2, b':bs')
   where
     int2 = bindersOf b
     exported' = filter isExportedId int2 ++ exported
-    int' = int1 `addInterestingBinds` b
-    (ae1, bs') = callArityTopLvl exported' int' bs
-    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b
+    int' = addInterestingBinds late int1 b
+    (ae1, bs') = callArityTopLvl late exported' int' bs
+    (ae2, b')  = callArityBind late (boringBinds late b) ae1 int1 b
 
 
-callArityRHS :: CoreExpr -> CoreExpr
-callArityRHS = snd . callArityAnal 0 emptyVarSet
+callArityRHS :: Bool -> CoreExpr -> CoreExpr
+callArityRHS late = snd . callArityAnal late 0 emptyVarSet
 
 -- The main analysis function. See Note [Analysis type signature]
 callArityAnal ::
+    Bool ->    -- Is this a late, more aggressive run?
     Arity ->  -- The arity this expression is called with
     VarSet -> -- The set of interesting variables
     CoreExpr ->  -- The expression to analyse
@@ -432,51 +433,51 @@ callArityAnal ::
         -- and the expression with IdInfo updated
 
 -- The trivial base cases
-callArityAnal _     _   e@(Lit _)
+callArityAnal _ _     _   e@(Lit _)
     = (emptyArityRes, e)
-callArityAnal _     _   e@(Type _)
+callArityAnal _ _     _   e@(Type _)
     = (emptyArityRes, e)
-callArityAnal _     _   e@(Coercion _)
+callArityAnal _ _     _   e@(Coercion _)
     = (emptyArityRes, e)
 -- The transparent cases
-callArityAnal arity int (Tick t e)
-    = second (Tick t) $ callArityAnal arity int e
-callArityAnal arity int (Cast e co)
-    = second (\e -> Cast e co) $ callArityAnal arity int e
+callArityAnal late arity int (Tick t e)
+    = second (Tick t) $ callArityAnal late arity int e
+callArityAnal late arity int (Cast e co)
+    = second (\e -> Cast e co) $ callArityAnal late arity int e
 
 -- The interesting case: Variables, Lambdas, Lets, Applications, Cases
-callArityAnal arity int e@(Var v)
+callArityAnal _ arity int e@(Var v)
     | v `elemVarSet` int
     = (unitArityRes v arity, e)
     | otherwise
     = (emptyArityRes, e)
 
 -- Non-value lambdas are ignored
-callArityAnal arity int (Lam v e) | not (isId v)
-    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
+callArityAnal late arity int (Lam v e) | not (isId v)
+    = second (Lam v) $ callArityAnal late arity (int `delVarSet` v) e
 
 -- We have a lambda that may be called multiple times, so its free variables
 -- can all be co-called.
-callArityAnal 0     int (Lam v e)
+callArityAnal late 0     int (Lam v e)
     = (ae', Lam v e')
   where
-    (ae, e') = callArityAnal 0 (int `delVarSet` v) e
+    (ae, e') = callArityAnal late 0 (int `delVarSet` v) e
     ae' = calledMultipleTimes ae
 -- We have a lambda that we are calling. decrease arity.
-callArityAnal arity int (Lam v e)
+callArityAnal late arity int (Lam v e)
     = (ae, Lam v e')
   where
-    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
+    (ae, e') = callArityAnal late (arity - 1) (int `delVarSet` v) e
 
 -- Application. Increase arity for the called expresion, nothing to know about
 -- the second
-callArityAnal arity int (App e (Type t))
-    = second (\e -> App e (Type t)) $ callArityAnal arity int e
-callArityAnal arity int (App e1 e2)
+callArityAnal late arity int (App e (Type t))
+    = second (\e -> App e (Type t)) $ callArityAnal late arity int e
+callArityAnal late arity int (App e1 e2)
     = (final_ae, App e1' e2')
   where
-    (ae1, e1') = callArityAnal (arity + 1) int e1
-    (ae2, e2') = callArityAnal 0           int e2
+    (ae1, e1') = callArityAnal late (arity + 1) int e1
+    (ae2, e2') = callArityAnal late 0           int e2
     -- If the argument is trivial (e.g. a variable), then it will _not_ be
     -- let-bound in the Core to STG transformation (CorePrep actually),
     -- so no sharing will happen here, and we have to assume many calls.
@@ -485,49 +486,50 @@ callArityAnal arity int (App e1 e2)
     final_ae = ae1 `both` ae2'
 
 -- Case expression.
-callArityAnal arity int (Case scrut bndr ty alts)
+callArityAnal late arity int (Case scrut bndr ty alts)
     = -- pprTrace "callArityAnal:Case"
       --          (vcat [ppr scrut, ppr final_ae])
       (final_ae, Case scrut' bndr ty alts')
   where
     (alt_aes, alts') = unzip $ map go alts
-    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
+    go (dc, bndrs, e) = let (ae, e') = callArityAnal late arity int e
                         in  (ae, (dc, bndrs, e'))
     alt_ae = lubRess alt_aes
-    (scrut_ae, scrut') = callArityAnal 0 int scrut
+    (scrut_ae, scrut') = callArityAnal late 0 int scrut
     final_ae = scrut_ae `both` alt_ae
 
 -- For lets, use callArityBind
-callArityAnal arity int (Let bind e)
+callArityAnal late arity int (Let bind e)
   = -- pprTrace "callArityAnal:Let"
     --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
     (final_ae, Let bind' e')
   where
-    int_body = int `addInterestingBinds` bind
-    (ae_body, e') = callArityAnal arity int_body e
-    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind
+    int_body = addInterestingBinds late int bind
+    (ae_body, e') = callArityAnal late arity int_body e
+    (final_ae, bind') = callArityBind late (boringBinds late bind) ae_body int bind
 
 -- Which bindings should we look at?
 -- See Note [Which variables are interesting]
-isInteresting :: Var -> Bool
-isInteresting v = True -- 0 < length (typeArity (idType v))
+isInteresting :: Bool -> Var -> Bool
+isInteresting True  _ = True
+isInteresting False v = 0 < length (typeArity (idType v))
 
-interestingBinds :: CoreBind -> [Var]
-interestingBinds = filter isInteresting . bindersOf
+interestingBinds :: Bool -> CoreBind -> [Var]
+interestingBinds late = filter (isInteresting late) . bindersOf
 
-boringBinds :: CoreBind -> VarSet
-boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf
+boringBinds :: Bool -> CoreBind -> VarSet
+boringBinds late = mkVarSet . filter (not . isInteresting late) . bindersOf
 
-addInterestingBinds :: VarSet -> CoreBind -> VarSet
-addInterestingBinds int bind
+addInterestingBinds :: Bool -> VarSet -> CoreBind -> VarSet
+addInterestingBinds late int bind
     = int `delVarSetList`    bindersOf bind -- Possible shadowing
-          `extendVarSetList` interestingBinds bind
+          `extendVarSetList` interestingBinds late bind
 
 -- Used for both local and top-level binds
 -- Second argument is the demand from the body
-callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
+callArityBind :: Bool -> VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
 -- Non-recursive let
-callArityBind boring_vars ae_body int (NonRec v rhs)
+callArityBind late boring_vars ae_body int (NonRec v rhs)
   | otherwise
   = -- pprTrace "callArityBind:NonRec"
     --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
@@ -547,7 +549,7 @@ callArityBind boring_vars ae_body int (NonRec v rhs)
     -- See Note [Trimming arity]
     trimmed_arity = trimArity v safe_arity
 
-    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
+    (ae_rhs, rhs') = callArityAnal late trimmed_arity int rhs
 
 
     ae_rhs'| called_once     = ae_rhs
@@ -567,7 +569,7 @@ callArityBind boring_vars ae_body int (NonRec v rhs)
 
 
 -- Recursive let. See Note [Recursion and fixpointing]
-callArityBind boring_vars ae_body int b@(Rec binds)
+callArityBind late boring_vars ae_body int b@(Rec binds)
   = -- (if length binds > 300 then
     -- pprTrace "callArityBind:Rec"
     --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $
@@ -576,7 +578,7 @@ callArityBind boring_vars ae_body int b@(Rec binds)
     -- See Note [Taking boring variables into account]
     any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]
 
-    int_body = int `addInterestingBinds` b
+    int_body = addInterestingBinds late int b
     (ae_rhs, binds') = fix initial_binds
     final_ae = bindersOf b `resDelList` ae_rhs
 
@@ -614,7 +616,7 @@ callArityBind boring_vars ae_body int b@(Rec binds)
                   -- See Note [Trimming arity]
                   trimmed_arity = trimArity i safe_arity
 
-                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
+                  (ae_rhs, rhs') = callArityAnal late trimmed_arity int_body rhs
 
                   ae_rhs' | called_once     = ae_rhs
                           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index ce5286d08a..7ab1861819 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -129,7 +129,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreLiberateCase
   | CoreDoPrintCore
   | CoreDoStaticArgs
-  | CoreDoCallArity
+  | CoreDoCallArity Bool
   | CoreDoStrictness
   | CoreDoWorkerWrapper
   | CoreDoSpecialising
@@ -155,7 +155,7 @@ instance Outputable CoreToDo where
   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
   ppr CoreLiberateCase         = ptext (sLit "Liberate case")
   ppr CoreDoStaticArgs         = ptext (sLit "Static argument")
-  ppr CoreDoCallArity          = ptext (sLit "Called arity analysis")
+  ppr (CoreDoCallArity _)      = ptext (sLit "Called arity analysis")
   ppr CoreDoStrictness         = ptext (sLit "Demand analysis")
   ppr CoreDoWorkerWrapper      = ptext (sLit "Worker Wrapper binds")
   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index efe3bafc23..ae4032fd9d 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -271,7 +271,7 @@ getCoreToDo dflags
             -- Csg.calc, where an arg of timesDouble thereby becomes strict.
 
         runWhen call_arity $ CoreDoPasses
-            [ CoreDoCallArity
+            [ CoreDoCallArity False
             , simpl_phase 0 ["post-call-arity"] max_iter
             ],
 
@@ -299,7 +299,7 @@ getCoreToDo dflags
         maybe_rule_check (Phase 0),
 
         runWhen call_arity $ CoreDoPasses
-            [ CoreDoCallArity
+            [ CoreDoCallArity True
             , simpl_phase 0 ["post-late-call-arity"] max_iter
             ],
 
@@ -380,8 +380,8 @@ doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                        doPassU doStaticArgs
 
-doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
-                                       doPassD callArityAnalProgram
+doCorePass (CoreDoCallArity l)       = {-# SCC "CallArity" #-}
+                                       doPassD (callArityAnalProgram l)
 
 doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                        doPassDFM dmdAnalProgram