[Git][ghc/ghc][wip/spj-unf-size] More wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Oct 23 15:38:17 UTC 2023
Simon Peyton Jones pushed to branch wip/spj-unf-size at Glasgow Haskell Compiler / GHC
Commits:
358f3509 by Simon Peyton Jones at 2023-10-23T16:37:54+01:00
More wibbles
In particular, respect OtherCon
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Unfold.hs
Changes:
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -617,11 +617,19 @@ exprSummary env e = go env e []
| Just con <- isDataConWorkId_maybe f
= ArgIsCon (DataAlt con) (map (exprSummary env) args)
- | Just rhs <- expandUnfolding_maybe (idUnfolding f)
- = go (zapSubstEnv env) rhs args
+ | OtherCon cs <- unfolding
+ = ArgIsNot cs
- | idArity f > valArgCount args
+ | Just rhs <- expandUnfolding_maybe unfolding
+ = pprTrace "exprSummary:expanded" (ppr f <+> text "==>" <+> ppr rhs) $
+ go (zapSubstEnv env) rhs args
+
+ | pprTrace "exprSummary:no-expand" (ppr f <+> text "unf" <+> ppr (idUnfolding f)) $
+ idArity f > valArgCount args
= ArgIsLam
| otherwise
= ArgNoInfo
+ where
+ unfolding = idUnfolding f
+
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -7,7 +7,7 @@
module GHC.Core.Seq (
-- * Utilities for forcing Core structures
seqExpr, seqExprs, seqUnfolding, seqRules,
- megaSeqIdInfo, seqRuleInfo, seqBinds,
+ megaSeqIdInfo, seqRuleInfo, seqBinds, seqGuidance
) where
import GHC.Prelude
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -37,6 +37,7 @@ module GHC.Core.Subst (
import GHC.Prelude
import GHC.Core
+import GHC.Core.Unfold
import GHC.Core.FVs
import GHC.Core.Seq
import GHC.Core.Utils
@@ -54,6 +55,7 @@ import GHC.Types.Unique.Supply
import GHC.Builtin.Names
import GHC.Data.Maybe
+import GHC.Data.Bag
import GHC.Utils.Misc
import GHC.Utils.Outputable
@@ -509,18 +511,70 @@ substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
(subst',bndrs') = substBndrs subst bndrs
args' = map (substExpr subst') args
-substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
+substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src
+ , uf_guidance = guidance })
-- Retain stable unfoldings
| not (isStableSource src) -- Zap an unstable unfolding, to save substitution work
= NoUnfolding
| otherwise -- But keep a stable one!
- = seqExpr new_tmpl `seq`
- unf { uf_tmpl = new_tmpl }
+ = seqExpr new_tmpl `seq` seqGuidance new_guidance `seq`
+ unf { uf_tmpl = new_tmpl, uf_guidance = new_guidance }
where
- new_tmpl = substExpr subst tmpl
+ new_tmpl = substExpr subst tmpl
+ new_guidance = substGuidance subst guidance
substUnfolding _ unf = unf -- NoUnfolding, OtherCon
+substGuidance :: Subst -> UnfoldingGuidance -> UnfoldingGuidance
+substGuidance subst guidance
+ = case guidance of
+ UnfNever -> guidance
+ UnfWhen {} -> guidance
+ UnfIfGoodArgs { ug_args = args, ug_tree = et }
+ -> UnfIfGoodArgs { ug_args = args', ug_tree = substExprTree subst' et }
+ where
+ (subst', args') = substBndrs subst args
+
+-------------------------
+substExprTree :: Subst -> ExprTree -> ExprTree
+-- ExprTrees have free variables, and so must be substituted
+substExprTree _ TooBig = TooBig
+substExprTree subst (SizeIs { et_size = size
+ , et_cases = cases
+ , et_ret = ret_discount })
+ = case extra_size of
+ STooBig -> TooBig
+ SSize extra -> SizeIs { et_size = size + extra
+ , et_cases = cases'
+ , et_ret = ret_discount }
+ where
+ (extra_size, cases') = foldr subst_ct (sizeZero, emptyBag) cases
+
+ 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)
+ _ -> (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)
+ _ -> (n `addSize` extra, cts)
+ where
+ (subst', case_bndr') = substBndr subst case_bndr
+ alts' = map (subst_alt subst') alts
+ extra = keptCaseSize boringInlineContext case_bndr alts
+
+ subst_alt subst (AltTree con bs rhs)
+ = AltTree con bs' (substExprTree subst' rhs)
+ where
+ (subst', bs') = substBndrs subst bs
+
+boringInlineContext :: InlineContext
+boringInlineContext = IC { ic_free = \_ -> ArgNoInfo
+ , ic_bound = emptyVarEnv
+ , ic_want_res = False }
+
------------------
substIdOcc :: Subst -> Id -> Id
-- These Ids should not be substituted to non-Ids
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -20,10 +20,11 @@ find, unsurprisingly, a Core expression.
module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance, -- Abstract types
- ExprTree, exprTree, exprTreeSize,
+ ExprTree, exprTree, exprTreeSize, keptCaseSize,
exprTreeWillInline, couldBeSmallEnoughToInline,
ArgSummary(..), hasArgInfo,
- Size, leqSize, addSizeN, adjustSize,
+
+ Size(..), leqSize, addSizeN, addSize, adjustSize, sizeZero,
InlineContext(..),
UnfoldingOpts (..), defaultUnfoldingOpts,
@@ -1001,6 +1002,9 @@ instance Outputable Size where
ppr STooBig = text "STooBig"
ppr (SSize n) = int n
+sizeZero :: Size
+sizeZero = SSize 0
+
sizeN :: Int -> Size
sizeN n = SSize n
@@ -1142,3 +1146,5 @@ lookupBndr (IC { ic_bound = bound_env, ic_free = lookup_free }) var
| Just info <- assertPpr (isId var) (ppr var) $
lookupVarEnv bound_env var = info
| otherwise = lookup_free var
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/358f3509bf6d496e65586f804191e57d4f350d68
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/358f3509bf6d496e65586f804191e57d4f350d68
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/813bf3d3/attachment-0001.html>
More information about the ghc-commits
mailing list