summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2021-07-22 23:50:43 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-07-28 13:19:06 -0400
commit05f54bb4f2fd0d8d4e0029ed795bfe1a534ce304 (patch)
treee0c3db057fc36bd4cfc42e7d54f1945d6a152f44
parenta67e681496ed662bfaabeccb8c584adcb8a97971 (diff)
downloadhaskell-05f54bb4f2fd0d8d4e0029ed795bfe1a534ce304.tar.gz
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
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs60
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