[Git][ghc/ghc][wip/T24466] 2 commits: Make use of occurrence analysis
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri May 10 11:44:54 UTC 2024
Simon Peyton Jones pushed to branch wip/T24466 at Glasgow Haskell Compiler / GHC
Commits:
f351858f by Simon Peyton Jones at 2024-05-10T12:39:17+01:00
Make use of occurrence analysis
let x = e in
let $j y = ...x...
in case z of
A -> $j y1
B -> x
C -> x
here we may want to float in. Example in spectal/para, the stepr function.
- - - - -
170b26f9 by Simon Peyton Jones at 2024-05-10T12:44:31+01:00
Unused binder
- - - - -
2 changed files:
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
Changes:
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -25,14 +25,16 @@ import GHC.Core
import GHC.Core.Unfold( ExprSize(..), sizeExpr,
UnfoldingOpts(..), defaultUnfoldingOpts )
import GHC.Core.Opt.Arity( isOneShotBndr )
+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )
-- import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline )
import GHC.Core.Make hiding ( wrapFloats )
import GHC.Core.Utils
import GHC.Core.FVs
import GHC.Core.Type
-import GHC.Types.Basic ( RecFlag(..), isRec )
-import GHC.Types.Id ( idType, isJoinId, idJoinPointHood )
+import GHC.Types.Basic ( RecFlag(..), isRec, isOneOcc )
+import GHC.Types.Id ( idType, isJoinId, idJoinPointHood, idDemandInfo, idOccInfo )
+import GHC.Types.Demand ( isStrUsedDmd )
import GHC.Types.Tickish
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -53,10 +55,11 @@ floatInwards :: Platform -> CoreProgram -> CoreProgram
floatInwards platform binds = map (fi_top_bind platform) binds
where
fi_top_bind platform (NonRec binder rhs)
- = NonRec binder (fiExpr platform [] (freeVars rhs))
+ = NonRec binder (fiExpr platform [] (preprocess rhs))
fi_top_bind platform (Rec pairs)
- = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]
+ = Rec [ (b, fiExpr platform [] (preprocess rhs)) | (b, rhs) <- pairs ]
+ preprocess rhs = freeVars (occurAnalyseExpr rhs)
{-
************************************************************************
@@ -687,7 +690,9 @@ noFloatIntoArg expr
-- See Note [noFloatInto considerations] wrinkle 2
| otherwise -- See Note [noFloatInto considerations] wrinkle 2
- = exprIsTrivial deann_expr || exprIsHNF deann_expr
+ = exprIsTrivial deann_expr -- || exprIsHNF deann_expr
+ -- let x = e in Just (Just (x+1))
+ -- here we want to float in!
where
deann_expr = deAnnotate' expr
@@ -802,11 +807,30 @@ sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs
= (dropBoxFloats here_box, map dropBoxFloats fork_boxes)
go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes
- | drop_here = go binds (insert here_box) fork_boxes
- | otherwise = go binds here_box new_fork_boxes
+ | push_it_in = go binds here_box new_fork_boxes
+ | otherwise = go binds (insert here_box) fork_boxes
where
- drop_here = used_here || cant_push
+ push_it_in = not used_here && can_push && (n_used_alts == 1 || some_benefit)
-- "here" means the group of bindings dropped at the top of the fork
+ -- Otherwise always float in if there is just one arm; or if there is
+ -- some benefit to doing so
+
+ -- can_push: see Note [Floating primops]
+ can_push | is_case = True
+ | otherwise = not (floatIsCase bind)
+
+ -- some_benefit is used only if (n_used_alts > 1) and (not used_here)
+ -- So some duplication is going to occur
+ some_benefit = small_enough &&
+ no_work_duplication &&
+ (saves_alloc || not not_thunky)
+
+ saves_alloc = n_used_alts < n_alts
+ small_enough = floatIsDupable platform bind
+ no_work_duplication = is_case || case bind of
+ FloatCase {} -> True -- Always a primop
+ FloatLet (NonRec b _) -> isOneOcc (idOccInfo b)
+ FloatLet (Rec {}) -> False -- One will be a loop breaker
used_here = bndrs `usedInDropBox` here_box
used_in_flags = case fork_boxes of
@@ -821,9 +845,11 @@ sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs
not_thunky = case bind of
FloatCase{} -> True
- FloatLet (NonRec _ r) -> exprIsHNF r
+ FloatLet (NonRec b r) -> isStrUsedDmd (idDemandInfo b)
+ || exprIsHNF r
FloatLet (Rec prs) -> all (exprIsHNF . snd) prs
+{-
cant_push
| is_case
= -- The alternatives of a case expresison
@@ -840,7 +866,7 @@ sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs
-- Don't float in if used in all alternatives and not a thunk
(n_used_alts > 1 && not (floatIsDupable platform bind))
-- Nor if used in multiple alts and not small
-
+-}
new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
fork_boxes used_in_flags
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1608,10 +1608,11 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs
-- in GHC.Core.Opt.Simplify.Iteration
| otherwise
= case occ_info of
- OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }
+ OneOcc { occ_in_lam = in_lam, occ_n_br = n_br }
| n_br == 1, NotInsideLam <- in_lam -- One syntactic occurrence
-> True -- See Note [Post-inline for single-use things]
{-
+ OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }
-- See Note [Inline small things to avoid creating a thunk]
| n_br >= 100 -> False -- See #23627
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf9e9ff282cbae740bab6807d1014004fa05b7f0...170b26f96a716a78a269376e410585792f46cbf1
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bf9e9ff282cbae740bab6807d1014004fa05b7f0...170b26f96a716a78a269376e410585792f46cbf1
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/20240510/9dc4a5e4/attachment-0001.html>
More information about the ghc-commits
mailing list