Make the occurrence analyser a bit stricter

occAnalArgs and occAnalApp are very heavily used functions, so it pays
to make them rather strict: fewer thunks constructed.  All these
thunks are ultimately evaluated anyway.

This patch gives a welcome reduction compile time allocation of around
0.5% across the board. For T9961 it's a 2.2% reduction.

Metric Decrease:
    T9961

1 files changed, 31 insertions, 29 deletions

diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index eb4c2ef6b6..7df9ead69f 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -2062,21 +2062,20 @@ occAnal env (Let bind body)
                                                     noImpRuleEdges bind body_usage
     in WithUsageDetails final_usage (mkLets new_binds body')
 
-occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> WithUsageDetails [CoreExpr]
-occAnalArgs !_ [] !_
-  = WithUsageDetails emptyDetails []
-
-occAnalArgs env (arg:args) one_shots
-  | isTypeArg arg
-  = let (WithUsageDetails uds args') = occAnalArgs env args one_shots
-    in WithUsageDetails uds (arg:args')
-
-  | otherwise
-  = let
-      !(arg_env, one_shots') = argCtxt env one_shots
-      (WithUsageDetails uds1 arg') = occAnal arg_env arg
-      (WithUsageDetails uds2 args') = occAnalArgs env args one_shots'
-    in WithUsageDetails (uds1 `andUDs` uds2) (arg':args')
+occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr
+-- The `fun` argument is just an accumulating parameter,
+-- the base for building the application we return
+occAnalArgs !env fun args !one_shots
+  = go emptyDetails fun args one_shots
+  where
+    go uds fun [] _ = WithUsageDetails uds fun
+    go uds fun (arg:args) one_shots
+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'
+      where
+        !(WithUsageDetails arg_uds arg') = occAnal arg_env arg
+        !(arg_env, one_shots')
+            | isTypeArg arg = (env, one_shots)
+            | otherwise     = valArgCtxt env one_shots
 
 {-
 Applications are dealt with specially because we want
@@ -2114,9 +2113,13 @@ occAnalApp !env (Var fun, args, ticks)
   = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
 
 occAnalApp env (Var fun_id, args, ticks)
-  = WithUsageDetails all_uds (mkTicks ticks $ mkApps fun' args')
+  = WithUsageDetails all_uds (mkTicks ticks app')
   where
-    (fun', fun_id') = lookupBndrSwap env fun_id
+    -- Lots of banged bindings: this is a very heavily bit of code,
+    -- so it pays not to make lots of thunks here, all of which
+    -- will ultimately be forced.
+    !(fun', fun_id')  = lookupBndrSwap env fun_id
+    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots
 
     fun_uds = mkOneOcc fun_id' int_cxt n_args
        -- NB: fun_uds is computed for fun_id', not fun_id
@@ -2124,8 +2127,7 @@ occAnalApp env (Var fun_id, args, ticks)
 
     all_uds = fun_uds `andUDs` final_args_uds
 
-    (WithUsageDetails args_uds args') = occAnalArgs env args one_shots
-    !final_args_uds = markAllNonTail                        $
+    !final_args_uds = markAllNonTail                              $
                       markAllInsideLamIf (isRhsEnv env && is_exp) $
                       args_uds
        -- We mark the free vars of the argument of a constructor or PAP
@@ -2138,14 +2140,14 @@ occAnalApp env (Var fun_id, args, ticks)
        -- This is the *whole point* of the isRhsEnv predicate
        -- See Note [Arguments of let-bound constructors]
 
-    n_val_args = valArgCount args
-    n_args     = length args
-    int_cxt    = case occ_encl env of
+    !n_val_args = valArgCount args
+    !n_args     = length args
+    !int_cxt    = case occ_encl env of
                    OccScrut -> IsInteresting
                    _other   | n_val_args > 0 -> IsInteresting
                             | otherwise      -> NotInteresting
 
-    is_exp     = isExpandableApp fun_id n_val_args
+    !is_exp     = isExpandableApp fun_id n_val_args
         -- See Note [CONLIKE pragma] in GHC.Types.Basic
         -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs
 
@@ -2156,16 +2158,16 @@ occAnalApp env (Var fun_id, args, ticks)
 
 occAnalApp env (fun, args, ticks)
   = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))
-                     (mkTicks ticks $ mkApps fun' args')
+                     (mkTicks ticks app')
   where
-    (WithUsageDetails fun_uds fun') = occAnal (addAppCtxt env args) fun
+    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []
+    !(WithUsageDetails fun_uds fun')  = occAnal (addAppCtxt env args) fun
         -- The addAppCtxt is a bit cunning.  One iteration of the simplifier
         -- often leaves behind beta redexs like
         --      (\x y -> e) a1 a2
         -- Here we would like to mark x,y as one-shot, and treat the whole
         -- thing much like a let.  We do this by pushing some OneShotLam items
         -- onto the context stack.
-    (WithUsageDetails args_uds args') = occAnalArgs env args []
 
 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
 addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args
@@ -2393,10 +2395,10 @@ scrutCtxt !env alts
 rhsCtxt :: OccEnv -> OccEnv
 rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] }
 
-argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
-argCtxt !env []
+valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
+valArgCtxt !env []
   = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
-argCtxt env (one_shots:one_shots_s)
+valArgCtxt env (one_shots:one_shots_s)
   = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
 
 isRhsEnv :: OccEnv -> Bool