[Git][ghc/ghc][wip/spj-unf-size] Value args only in ExprTrees
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Oct 23 16:34:39 UTC 2023
Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC
Commits:
5dd14df7 by Simon Peyton Jones at 2023-10-23T17:34:18+01:00
Value args only in ExprTrees
- - - - -
4 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1388,9 +1388,9 @@ data UnfoldingGuidance
}
| UnfIfGoodArgs { -- Arose from a normal Id
- ug_args :: [Var], -- Arguments
+ ug_args :: [Id], -- Value arguments only
ug_tree :: ExprTree -- Abstraction of the body
- -- Invariant: free vars of ug_tree are the ug_args, plus variables
+ -- Invariant: free Ids of ug_tree are the ug_args, plus Ids
-- in scope at the binding site of the function definition
}
@@ -1411,7 +1411,9 @@ data CaseTree
-- nothing relies on non-empty-ness
| ScrutOf Id Int -- If this Id is bound to a value, apply this discount
-data AltTree = AltTree AltCon [Var] ExprTree
+data AltTree = AltTree AltCon
+ [Id] -- Term variables only
+ ExprTree
{- Note [UnfoldingCache]
~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -267,10 +267,11 @@ tryUnfolding logger env fn cont unf_template unf_cache guidance
, text "case depth =" <+> int case_depth
, text "final_size =" <+> ppr final_size ]
where
- (lone_variable, arg_infos, call_cont) = contArgs cont
- cont_info = interestingCallContext env call_cont
- case_depth = seCaseDepth env
- opts = seUnfoldingOpts env
+ (arg_infos, call_cont) = contArgs cont
+ lone_variable = loneVariable cont
+ cont_info = interestingCallContext env call_cont
+ case_depth = seCaseDepth env
+ opts = seUnfoldingOpts env
-- Unpack the UnfoldingCache lazily because it may not be needed, and all
-- its fields are strict; so evaluating unf_cache at all forces all the
@@ -551,24 +552,24 @@ rule for (*) (df d) can fire. To do this
-}
-------------------
-contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
--- Summarises value args, discards type args and coercions
+contArgs :: SimplCont -> ( [ArgSummary] -- One for each value argument
+ , SimplCont ) -- The rest
+-- Summarises value args, discards type args and casts.
-- The returned continuation of the call is only used to
-- answer questions like "are you interesting?"
-contArgs cont
- | lone cont = (True, [], cont)
- | otherwise = go [] cont
+contArgs cont = go [] cont
where
- lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold
- lone (ApplyToVal {}) = False -- NB: even a type application or cast
- lone (CastIt {}) = False -- stops it being "lone"
- lone _ = True
-
go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
= go (exprSummary se arg : args) k
go args (ApplyToTy { sc_cont = k }) = go args k
go args (CastIt _ k) = go args k
- go args k = (False, reverse args, k)
+ go args k = (reverse args, k)
+
+loneVariable :: SimplCont -> Bool
+loneVariable (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold
+loneVariable (ApplyToVal {}) = False -- NB: even a type application or cast
+loneVariable (CastIt {}) = False -- stops it being "lone"
+loneVariable _ = True
------------------------------
exprSummary :: SimplEnv -> CoreExpr -> ArgSummary
@@ -583,10 +584,13 @@ exprSummary :: SimplEnv -> CoreExpr -> ArgSummary
-- We want to see that x is (a,b) at the call site of f
exprSummary env e = go env e []
where
- go :: SimplEnv -> CoreExpr -> [CoreExpr] -> ArgSummary
+ go :: SimplEnv -> CoreExpr
+ -> [CoreExpr] -- Value arg only
+ -> ArgSummary
go env (Cast e _) as = go env e as
go env (Tick _ e) as = go env e as
- go env (App f a) as = go env f (a:as)
+ go env (App f a) as | isValArg a = go env f (a:as)
+ | otherwise = go env f as
go env (Let b e) as = go env' e as
where
env' = env `addNewInScopeIds` bindersOf b
@@ -613,17 +617,20 @@ exprSummary env e = go env e []
go _ _ _ = ArgNoInfo
- go_var env f args
+ go_var :: SimplEnv -> Id
+ -> [CoreExpr] -- Value args only
+ -> ArgSummary
+ go_var env f val_args
| Just con <- isDataConWorkId_maybe f
- = ArgIsCon (DataAlt con) (map (exprSummary env) args)
+ = ArgIsCon (DataAlt con) (map (exprSummary env) val_args)
| OtherCon cs <- unfolding
= ArgIsNot cs
| Just rhs <- expandUnfolding_maybe unfolding
- = go (zapSubstEnv env) rhs args
+ = go (zapSubstEnv env) rhs val_args
- | idArity f > valArgCount args
+ | idArity f > length val_args
= ArgIsLam
| otherwise
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -41,8 +41,9 @@ import GHC.Core.Unfold
import GHC.Core.FVs
import GHC.Core.Seq
import GHC.Core.Utils
-import GHC.Core.Type -- Subst comes from here
-import GHC.Core.Coercion( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr )
+import GHC.Core.TyCo.Subst -- Subst comes from here
+import GHC.Core.Type( mkTyVarTy, noFreeVarsOfType, tyCoFVsOfType, tyCoVarsOfType )
+import GHC.Core.Coercion( tyCoFVsOfCo, mkCoVarCo )
import GHC.Types.Var.Set
import GHC.Types.Var.Env as InScopeSet
@@ -341,14 +342,14 @@ preserve occ info in rules.
-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning
-- the result and an updated 'Subst' that should be used by subsequent substitutions.
-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
-substBndr :: Subst -> Var -> (Subst, Var)
+substBndr :: HasDebugCallStack => Subst -> Var -> (Subst, Var)
substBndr subst bndr
| isTyVar bndr = substTyVarBndr subst bndr
| isCoVar bndr = substCoVarBndr subst bndr
| otherwise = substIdBndr (text "var-bndr") subst subst bndr
-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
-substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var)
+substBndrs :: (HasDebugCallStack, Traversable f) => Subst -> f Var -> (Subst, f Var)
substBndrs = mapAccumL substBndr
{-# INLINE substBndrs #-}
@@ -531,17 +532,18 @@ substGuidance subst guidance
UnfNever -> guidance
UnfWhen {} -> guidance
UnfIfGoodArgs { ug_args = args, ug_tree = et }
- -> UnfIfGoodArgs { ug_args = args', ug_tree = substExprTree subst' et }
+ -> UnfIfGoodArgs { ug_args = args, ug_tree = substExprTree id_env et }
where
- (subst', args') = substBndrs subst args
+ id_env = getIdSubstEnv subst `delVarEnvList` args
-------------------------
-substExprTree :: Subst -> ExprTree -> ExprTree
--- ExprTrees have free variables, and so must be substituted
+substExprTree :: IdSubstEnv -> ExprTree -> ExprTree
+-- ExprTrees have free Ids, and so must be substituted
+-- But Ids /only/ not tyvars, so substitution is very simple
substExprTree _ TooBig = TooBig
-substExprTree subst (SizeIs { et_size = size
- , et_cases = cases
- , et_ret = ret_discount })
+substExprTree id_env (SizeIs { et_size = size
+ , et_cases = cases
+ , et_ret = ret_discount })
= case extra_size of
STooBig -> TooBig
SSize extra -> SizeIs { et_size = size + extra
@@ -552,23 +554,23 @@ substExprTree subst (SizeIs { et_size = size
subst_ct :: CaseTree -> (Size, Bag CaseTree) -> (Size, Bag CaseTree)
subst_ct (ScrutOf v d) (n, cts)
- = case lookupIdSubst subst v of
- Var v' -> (n, ScrutOf v' d `consBag` cts)
+ = case lookupVarEnv id_env v of
+ Just (Var v') -> (n, ScrutOf v' d `consBag` cts)
_ -> (n, cts)
subst_ct (CaseOf v case_bndr alts) (n, cts)
- = case lookupIdSubst subst v of
- Var v' -> (n, CaseOf v' case_bndr' alts' `consBag` cts)
+ = case lookupVarEnv id_env v of
+ Just (Var v') -> (n, CaseOf v' case_bndr alts' `consBag` cts)
_ -> (n `addSize` extra, cts)
where
- (subst', case_bndr') = substBndr subst case_bndr
- alts' = map (subst_alt subst') alts
+ id_env' = id_env `delVarEnv` case_bndr
+ alts' = map (subst_alt id_env') alts
extra = keptCaseSize boringInlineContext case_bndr alts
- subst_alt subst (AltTree con bs rhs)
- = AltTree con bs' (substExprTree subst' rhs)
+ subst_alt id_env (AltTree con bs rhs)
+ = AltTree con bs (substExprTree id_env' rhs)
where
- (subst', bs') = substBndrs subst bs
+ id_env' = id_env `delVarEnvList` bs
boringInlineContext :: InlineContext
boringInlineContext = IC { ic_free = \_ -> ArgNoInfo
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -1033,7 +1033,7 @@ data InlineContext
}
data ArgSummary = ArgNoInfo
- | ArgIsCon AltCon [ArgSummary] -- Includes type args
+ | ArgIsCon AltCon [ArgSummary] -- Value args only
| ArgIsNot [AltCon]
| ArgIsLam
@@ -1096,14 +1096,17 @@ caseTreeSize ic (CaseOf scrut_var case_bndr alts)
ArgNoInfo -> keptCaseSize ic case_bndr alts
ArgIsLam -> keptCaseSize ic case_bndr alts
ArgIsNot cons -> keptCaseSize ic case_bndr (trim_alts cons alts)
+
arg_summ@(ArgIsCon con args)
- | Just (AltTree _ bndrs rhs) <- find_alt con alts
- , let new_summaries :: [(Var,ArgSummary)]
+ | Just at@(AltTree alt_con bndrs rhs) <- find_alt con alts
+ , let new_summaries :: [(Id,ArgSummary)]
new_summaries = (case_bndr,arg_summ) : bndrs `zip` args
-- Don't forget to add a summary for the case binder!
ic' = ic { ic_bound = ic_bound ic `extendVarEnvList` new_summaries }
-- In DEFAULT case, bs is empty, so extending is a no-op
- -> exprTreeSize ic' rhs
+ -> assertPpr ((alt_con == DEFAULT) || (bndrs `equalLength` args)) (ppr arg_summ $$ ppr at) $
+ exprTreeSize ic' rhs
+
| otherwise -- Happens for empty alternatives
-> keptCaseSize ic case_bndr alts
@@ -1132,7 +1135,8 @@ keptCaseSize ic case_bndr alts
-- If there are no alternatives (case e of {}), we get just the size of the scrutinee
where
size_alt :: AltTree -> Size
- size_alt (AltTree _ bndrs rhs) = exprTreeSize ic' rhs
+ size_alt (AltTree _ bndrs rhs)
+ = exprTreeSize ic' rhs
-- Cost for the alternative is already in `rhs`
where
-- Must extend ic_bound, lest a captured variable is
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5dd14df786b897eb976a8bd2cf8d257cba56bc76
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5dd14df786b897eb976a8bd2cf8d257cba56bc76
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231023/eeeaac1d/attachment-0001.html>
More information about the ghc-commits
mailing list