[Git][ghc/ghc][wip/T22404] More performance tuning
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jul 21 15:57:38 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
92f05b6c by Simon Peyton Jones at 2023-07-21T16:57:14+01:00
More performance tuning
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates -fmax-worker-args=12 #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -34,7 +34,7 @@ import GHC.Core.Predicate ( isDictId )
import GHC.Core.Type
import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
-import GHC.Data.Maybe( isJust, isNothing, orElse )
+import GHC.Data.Maybe( isJust, orElse )
import GHC.Data.Graph.Directed ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
@@ -59,8 +59,6 @@ import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
import Data.List (mapAccumL)
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
{-
************************************************************************
@@ -964,14 +962,14 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- Now analyse the body, adding the join point
-- into the environment with addJoinPoint
- !(WUD body_uds (tagged_bndr, body))
- = occAnalNonRecBody env NotTopLevel bndr' $ \env ->
- thing_inside (addJoinPoint env bndr' rhs_uds)
+ !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env ->
+ thing_inside (addJoinPoint env bndr' rhs_uds)
in
- if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ if isDeadOcc occ -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else WUD (rhs_uds `orUDs` body_uds) -- Note `orUDs`
- (combine [NonRec tagged_bndr rhs'] body)
+ (combine [NonRec (tagNonRecBinder lvl occ bndr') rhs']
+ body)
{-
-- Fast path for top level, non-recursive bindings, with no rules
@@ -983,7 +981,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- * No rules so no faffing with them
| TopLevel <- lvl
, not (idHasRules bndr || (bndr `elemVarEnv` ire))
- = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
+ = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env bndr thing_inside
in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else let
@@ -1003,14 +1001,15 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
-- The normal case, including newly-discovered join points
-- Analyse the body and /then/ the RHS
| otherwise
- = let !(WUD body_uds (tagged_bndr, body)) = occAnalNonRecBody env lvl bndr thing_inside
- in if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ = let !(WUD body_uds (occ,body)) = occAnalNonRecBody env bndr thing_inside
+ in if isDeadOcc occ -- Drop dead code; see Note [Dead code]
then WUD body_uds body
else let
-- Get the join info from the *new* decision; NB: bndr is not already a JoinId
-- See Note [Join points and unfoldings/rules]
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
- mb_join = case tailCallInfo (idOccInfo tagged_bndr) of
+ tagged_bndr = tagNonRecBinder lvl occ bndr
+ mb_join = case tailCallInfo occ of
AlwaysTailCalled arity -> Just arity
_ -> Nothing
@@ -1019,16 +1018,14 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
(combine [NonRec final_bndr rhs'] body)
-----------------
-occAnalNonRecBody :: OccEnv -> TopLevelFlag -> Id
+occAnalNonRecBody :: OccEnv -> Id
-> (OccEnv -> WithUsageDetails r) -- Scope of the bind
- -> (WithUsageDetails (Id, r))
-{-# INLINE occAnalNonRecBody #-}
--- INLINE: it's small and higher order, just a macro really
-occAnalNonRecBody env lvl bndr thing_inside
+ -> (WithUsageDetails (OccInfo, r))
+occAnalNonRecBody env bndr thing_inside
= addInScope env [bndr] $ \env ->
let !(WUD inner_uds res) = thing_inside env
- tagged_bndr = tagNonRecBinder lvl inner_uds bndr
- in WUD inner_uds (tagged_bndr, res)
+ !occ = lookupLetDetails inner_uds bndr
+ in WUD inner_uds (occ, res)
-----------------
occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> Maybe JoinArity
@@ -1114,54 +1111,55 @@ occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage
= foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs
where
sccs :: [SCC NodeDetails]
- sccs = {-# SCC "occAnalBind.scc" #-}
- stronglyConnCompFromEdgedVerticesUniq nodes
+ sccs = stronglyConnCompFromEdgedVerticesUniq nodes
nodes :: [LetrecNode]
- nodes = {-# SCC "occAnalBind.assoc" #-}
- map (makeNode rhs_env imp_rule_edges bndr_set) pairs
+ nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs
bndrs = map fst pairs
bndr_set = mkVarSet bndrs
-bindersOfSCC :: SCC NodeDetails -> [Var]
-bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd]
-bindersOfSCC (CyclicSCC ds) = map nd_bndr ds
-
-----------------------------
occAnalRec :: OccEnv -> TopLevelFlag
-> SCC NodeDetails
-> WithUsageDetails [CoreBind]
-> WithUsageDetails [CoreBind]
--- Check for Note [Dead code]
--- NB: Only look at body_uds, ignoring uses in the SCC
-occAnalRec !_ _ scc (WUD body_uds binds)
- | not (any (`usedIn` body_uds) (bindersOfSCC scc))
- = WUD body_uds binds
-
-- The NonRec case is just like a Let (NonRec ...) above
occAnalRec !_ lvl
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
(WUD body_uds binds)
- = WUD (body_uds `andUDs` rhs_uds')
- (NonRec bndr' rhs' : binds)
+ | isDeadOcc occ -- Check for dead code: see Note [Dead code]
+ = WUD body_uds binds
+ | otherwise
+ = let tagged_bndr = tagNonRecBinder lvl occ bndr
+ mb_join_arity = willBeJoinId_maybe tagged_bndr
+ !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join_arity wtuds
+ !unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)
+ !bndr' = tagged_bndr `setIdUnfolding` unf'
+ in WUD (body_uds `andUDs` rhs_uds')
+ (NonRec bndr' rhs' : binds)
where
- tagged_bndr = tagNonRecBinder lvl body_uds bndr
- mb_join_arity = willBeJoinId_maybe tagged_bndr
- WUD rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds
- !unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)
- !bndr' = tagged_bndr `setIdUnfolding` unf'
+ occ = lookupLetDetails body_uds bndr
-- The Rec case is the interesting one
-- See Note [Recursive bindings: the grand plan]
-- See Note [Loop breaking]
occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)
- = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)
- WUD final_uds (Rec pairs : binds)
+ | not (any needed details_s)
+ = -- Check for dead code: see Note [Dead code]
+ -- NB: Only look at body_uds, ignoring uses in the SCC
+ WUD body_uds binds
+
+ | otherwise
+ = WUD final_uds (Rec pairs : binds)
where
all_simple = all nd_simple details_s
+ needed :: NodeDetails -> Bool
+ needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env
+ body_env = ud_env body_uds
+
------------------------------
-- Make the nodes for the loop-breaker analysis
-- See Note [Choosing loop breakers] for loop_breaker_nodes
@@ -2807,10 +2805,11 @@ data OccEnv
-- Usage details of the RHS of in-scope non-recursive join points
-- See Note [Occurrence analysis for join points]
- , occ_join_points :: !(IdEnv OccInfoEnv)
+ , occ_join_points :: !JoinPointInfo
-- Invariant: no Id maps to emptyDetails
}
+type JoinPointInfo = IdEnv OccInfoEnv
-----------------------------
-- OccEncl is used to control whether to inline into constructor arguments
@@ -2918,30 +2917,34 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a)
-> WithUsageDetails a
--- Needed for all Vars not just Ids; a TyVar might have a CoVars in its kind
-addInScope env@(OccEnv { occ_join_points = join_points })
- bndrs thing_inside
- | not bad_joins
- = -- No shadowing here; fast path for this common case
- del_bndrs_from_uds $
- thing_inside $
- drop_shadowed_swaps $
- env
-
- | otherwise -- Shadowing! Lots of things to do
- = add_bad_joins $
- del_bndrs_from_uds $
- thing_inside $
- drop_shadowed_swaps $
- drop_shadowed_joins $
- env
-
+{-# INLINE addInScope #-}
+-- This function is called a lot, so we want to inline the fast path
+addInScope env bndrs thing_inside
+ = WUD uds' res
where
- bndr_set :: UniqSet Var
- bndr_set = mkVarSet bndrs
+ bndr_set = mkVarSet bndrs
+ !(env', bad_joins) = preprocess_env env bndr_set
+ !(WUD uds res) = thing_inside env'
+ uds' = postprocess_uds bndr_set bad_joins uds
+
+preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)
+preprocess_env env@(OccEnv { occ_join_points = join_points
+ , occ_bs_rng = bs_rng_vars })
+ bndr_set
+ | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points)
+ | otherwise = (drop_shadowed_swaps env, emptyVarEnv)
+ where
+ drop_shadowed_swaps :: OccEnv -> OccEnv
+ -- See Note [The binder-swap substitution] (BS3)
+ drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })
+ | bs_rng_vars `intersectsVarSet` bndr_set
+ = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
+ | otherwise
+ = env { occ_bs_env = swap_env `minusUFM` bndr_fm }
- bndr_fm :: UniqFM Var Var
- bndr_fm = getUniqSet bndr_set
+ drop_shadowed_joins :: OccEnv -> OccEnv
+ -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)
+ drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }
-- bad_joins is true if it would be wrong to push occ_join_points inwards
-- (a) `bndrs` includes any of the occ_join_points
@@ -2949,48 +2952,35 @@ addInScope env@(OccEnv { occ_join_points = join_points })
bad_joins :: Bool
bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points
+ bndr_fm :: UniqFM Var Var
+ bndr_fm = getUniqSet bndr_set
+
is_bad :: Unique -> OccInfoEnv -> Bool -> Bool
is_bad uniq join_uds rest
= uniq `elemUniqSet_Directly` bndr_set ||
not (bndr_fm `disjointUFM` join_uds) ||
rest
- drop_shadowed_swaps :: OccEnv -> OccEnv
- -- See Note [The binder-swap substitution] (BS3)
- drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars })
- | bs_rng_vars `disjointUniqSets` bndr_set
- = env { occ_bs_env = swap_env `minusUFM` bndr_fm }
- | otherwise
- = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
-
- drop_shadowed_joins :: OccEnv -> OccEnv
- -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)
- drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }
-
- del_bndrs_from_uds :: WithUsageDetails a -> WithUsageDetails a
- -- Remove usage for bndrs
- -- Add usage info for CoVars used in the types of bndrs
- del_bndrs_from_uds (WUD uds res) = WUD (uds `delDetails` bndr_fm) res
-
- add_bad_joins :: WithUsageDetails a -> WithUsageDetails a
+postprocess_uds :: VarSet -> JoinPointInfo -> UsageDetails -> UsageDetails
+postprocess_uds bndr_set bad_joins uds
+ = add_bad_joins (delBndrsFromUDs bndr_set uds)
+ where
+ add_bad_joins :: UsageDetails -> UsageDetails
-- Add usage info for occ_join_points that we cannot push inwardsa
-- because of shadowing
-- See Note [Occurrence analysis for join points] wrinkle (W2)
- add_bad_joins wuds@(WUD body_uds res)
- | isEmptyVarEnv bad_joins = wuds -- Fast path for common case
- | otherwise = WUD (modifyUDEnv extend_with_bad_joins body_uds) res
- where
- bad_joins :: IdEnv OccInfoEnv
- bad_joins = join_points -- All of them, for simplicity
-
- extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv
- extend_with_bad_joins env
- = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins
-
- add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
- add_bad_join uniq join_env env
- | uniq `elemVarEnvByKey` env = env `plusVarEnv` join_env
- | otherwise = env
+ add_bad_joins uds
+ | isEmptyVarEnv bad_joins = uds
+ | otherwise = modifyUDEnv extend_with_bad_joins uds
+
+ extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv
+ extend_with_bad_joins env
+ = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins
+
+ add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
+ add_bad_join uniq join_env env
+ | uniq `elemVarEnvByKey` env = env `plusVarEnv` join_env
+ | otherwise = env
addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
addJoinPoint env bndr rhs_uds
@@ -3557,16 +3547,17 @@ emptyDetails = UD { ud_env = emptyVarEnv
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env
-delDetails :: UsageDetails -> UniqFM Var a -> UsageDetails
+delBndrsFromUDs :: VarSet -> UsageDetails -> UsageDetails
-- Delete these binders from the UsageDetails
-delDetails (UD { ud_env = env
- , ud_z_many = z_many
- , ud_z_in_lam = z_in_lam
- , ud_z_tail = z_tail }) bndr_fm
+delBndrsFromUDs bndr_set (UD { ud_env = env, ud_z_many = z_many
+ , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail })
= UD { ud_env = env `minusUFM` bndr_fm
, ud_z_many = z_many `minusUFM` bndr_fm
, ud_z_in_lam = z_in_lam `minusUFM` bndr_fm
, ud_z_tail = z_tail `minusUFM` bndr_fm }
+ where
+ bndr_fm :: UniqFM Var Var
+ bndr_fm = getUniqSet bndr_set
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
@@ -3583,9 +3574,6 @@ markAllInsideLamIf False ud = ud
markAllNonTailIf True ud = markAllNonTail ud
markAllNonTailIf False ud = ud
-lookupLocalDetails :: UsageDetails -> Id -> Maybe LocalOcc
-lookupLocalDetails (UD { ud_env = env }) id = lookupVarEnv env id
-
lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo
lookupTailCallInfo uds id
| UD { ud_z_tail = z_tail, ud_env = env } <- uds
@@ -3595,14 +3583,6 @@ lookupTailCallInfo uds id
| otherwise
= NoTailCallInfo
-lookupDetails :: UsageDetails -> Id -> OccInfo
-lookupDetails ud id = mkOccInfoByUnique ud (idUnique id)
-
-usedIn :: Id -> UsageDetails -> Bool
-v `usedIn` uds
- | isExportedId v = True
- | otherwise = v `elemVarEnv` ud_env uds
-
udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env
@@ -3627,6 +3607,18 @@ combineUsageDetailsWith plus_occ_info
, ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2
, ud_z_tail = plusVarEnv z_tail1 z_tail2 }
+lookupLetDetails :: UsageDetails -> Id -> OccInfo
+-- Don't use locally-generated occ_info for exported (visible-elsewhere)
+-- things. Instead just give noOccInfo.
+-- NB: setBinderOcc will (rightly) erase any LoopBreaker info;
+-- we are about to re-generate it and it shouldn't be "sticky"
+lookupLetDetails ud id
+ | isExportedId id = noOccInfo
+ | otherwise = mkOccInfoByUnique ud (idUnique id)
+
+lookupDetails :: UsageDetails -> Id -> OccInfo
+lookupDetails ud id = mkOccInfoByUnique ud (idUnique id)
+
mkOccInfoByUnique :: UsageDetails -> Unique -> OccInfo
mkOccInfoByUnique (UD { ud_env = env
, ud_z_many = z_many
@@ -3740,19 +3732,18 @@ tagLamBinder usage bndr
occ = lookupDetails usage bndr
tagNonRecBinder :: TopLevelFlag -- At top level?
- -> UsageDetails -- Of scope
+ -> OccInfo -- Of scope
-> CoreBndr -- Binder
-> IdWithOccInfo -- Tagged binder
-- No-op on TyVars
-
-tagNonRecBinder lvl usage binder
- = setBinderOcc occ' binder
+-- Precondition: OccInfo is not IAmDead
+tagNonRecBinder lvl occ bndr
+ = setBinderOcc occ' bndr
where
- occ = lookupDetails usage binder
- will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
+ will_be_join = okForJoinPoint lvl bndr (tailCallInfo occ)
occ' | will_be_join = -- Must already be marked AlwaysTailCalled, unless
-- it was a join point before but is now dead
- assert (isAlwaysTailCalled occ || isDeadOcc occ) occ
+ warnPprTrace (not (isAlwaysTailCalled occ)) "tagNonRecBinder" (ppr bndr <+> ppr occ) occ
| otherwise = markNonTail occ
tagRecBinders :: TopLevelFlag -- At top level?
@@ -3775,8 +3766,7 @@ tagRecBinders lvl body_uds details_s
test_manifest_arity ND{nd_rhs = WTUD tuds rhs}
= adjustTailArity (Just (joinRhsArity rhs)) tuds
- bndr_ne = expectNonEmpty "List of binders is never empty" bndrs
- will_be_joins = decideJoinPointHood lvl unadj_uds bndr_ne
+ will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs
mb_join_arity :: Id -> Maybe JoinArity
-- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]
@@ -3801,7 +3791,7 @@ tagRecBinders lvl body_uds details_s
adj_uds = foldr andUDs body_uds rhs_udss'
-- 4. Tag each binder with its adjusted details
- bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr
+ bndrs' = [ setBinderOcc (lookupLetDetails adj_uds bndr) bndr
| bndr <- bndrs ]
in
@@ -3809,18 +3799,9 @@ tagRecBinders lvl body_uds details_s
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
- | isTyVar bndr = bndr
- | isNoOccInfo occ_info = zap_it
- | isExportedId bndr = zap_it
- -- Don't use occ_info (locally-generated) for visible-elsewhere things
- -- BUT *do* erase any IAmALoopBreaker annotation, because we're
- -- about to re-generate it and it shouldn't be "sticky"
- | otherwise = setIdOccInfo bndr occ_info
-
- where
- bndr_info = idOccInfo bndr
- zap_it | isNoOccInfo bndr_info = bndr
- | otherwise = setIdOccInfo bndr noOccInfo
+ | isTyVar bndr = bndr
+ | occ_info == idOccInfo bndr = bndr
+ | otherwise = setIdOccInfo bndr occ_info
-- | Decide whether some bindings should be made into join points or not, based
-- on its occurrences. This is
@@ -3834,48 +3815,47 @@ setBinderOcc occ_info bndr
-- 'f' tail-calls 'g'.
--
-- See Note [Invariants on join points] in "GHC.Core".
-decideJoinPointHood :: TopLevelFlag -> UsageDetails
- -> NonEmpty CoreBndr
- -> Bool
-decideJoinPointHood TopLevel _ _
- = False
-
-decideJoinPointHood NotTopLevel usage bndrs
- | isJoinId bndr1
- = warnPprTrace lost_join_point
- "OccurAnal failed to rediscover join point(s)"
- lost_join_doc
- all_ok
--- = assertPpr (not lost_join_point) (ppr bndrs)
--- True
-
- | otherwise
- = all_ok
+decideRecJoinPointHood :: TopLevelFlag -> UsageDetails
+ -> [CoreBndr] -> Bool
+decideRecJoinPointHood lvl usage bndrs
+ = all ok bndrs -- Invariant 3: Either all are join points or none are
where
- bndr1 = NE.head bndrs
+ ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)
+okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool
-- See Note [Invariants on join points]; invariants cited by number below.
-- Invariant 2 is always satisfiable by the simplifier by eta expansion.
- all_ok = -- Invariant 3: Either all are join points or none are
- all ok bndrs
-
- ok bndr
- | -- Invariant 1: Only tail calls, all same join arity
- AlwaysTailCalled arity <- lookupTailCallInfo usage bndr
+okForJoinPoint lvl bndr tail_call_info
+ | isJoinId bndr -- A current join point should still be one!
+ = warnPprTrace lost_join "Lost join point" lost_join_doc $
+ True
+ | valid_join
+ = True
+ | otherwise
+ = False
+ where
+ valid_join | NotTopLevel <- lvl
+ , AlwaysTailCalled arity <- tail_call_info
- , -- Invariant 1 as applied to LHSes of rules
- all (ok_rule arity) (idCoreRules bndr)
+ , -- Invariant 1 as applied to LHSes of rules
+ all (ok_rule arity) (idCoreRules bndr)
- -- Invariant 2a: stable unfoldings
- -- See Note [Join points and INLINE pragmas]
- , ok_unfolding arity (realIdUnfolding bndr)
+ -- Invariant 2a: stable unfoldings
+ -- See Note [Join points and INLINE pragmas]
+ , ok_unfolding arity (realIdUnfolding bndr)
- -- Invariant 4: Satisfies polymorphism rule
- , isValidJoinPointType arity (idType bndr)
- = True
+ -- Invariant 4: Satisfies polymorphism rule
+ , isValidJoinPointType arity (idType bndr)
+ = True
+ | otherwise
+ = False
- | otherwise
- = False
+ lost_join | Just ja <- isJoinId_maybe bndr
+ = not valid_join ||
+ (case tail_call_info of -- Valid join but arity differs
+ AlwaysTailCalled ja' -> ja /= ja'
+ _ -> False)
+ | otherwise = False
ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans
ok_rule join_arity (Rule { ru_args = args })
@@ -3891,23 +3871,15 @@ decideJoinPointHood NotTopLevel usage bndrs
ok_unfolding _ _
= True
- lost_join_point :: Bool
- lost_join_point
- | isNothing (lookupLocalDetails usage bndr1) = False -- Dead
- | all_ok = False
- | otherwise = True
-
lost_join_doc
- = vcat [ text "bndrs:" <+> ppr bndrs
- , text "occ:" <+> ppr (lookupDetails usage bndr1)
- , text "arity:" <+> ppr arity
- , text "rules:" <+> ppr (idCoreRules bndr1)
- , text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr1))
- , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr1)) ]
- where
- arity = case lookupTailCallInfo usage bndr1 of
- AlwaysTailCalled ar -> ar
- NoTailCallInfo -> 0
+ = vcat [ text "bndr:" <+> ppr bndr
+ , text "tc:" <+> ppr tail_call_info
+ , text "rules:" <+> ppr (idCoreRules bndr)
+ , case tail_call_info of
+ AlwaysTailCalled arity ->
+ vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr))
+ , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]
+ _ -> empty ]
willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
willBeJoinId_maybe bndr
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/92f05b6c47300c1c9a30c517d187b4200849ee6f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/92f05b6c47300c1c9a30c517d187b4200849ee6f
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/20230721/b324374e/attachment-0001.html>
More information about the ghc-commits
mailing list