[Git][ghc/ghc][wip/T22404] Wibble
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Jul 13 15:06:31 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
8afd4872 by Simon Peyton Jones at 2023-07-13T16:06:18+01:00
Wibble
- - - - -
1 changed file:
- compiler/GHC/Core/Opt/OccurAnal.hs
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -998,7 +998,8 @@ occAnalNonRecBody env lvl bndr thing_inside
occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
-> WithUsageDetails [CoreBind]
occAnalNonRecRhs !env imp_rule_edges tagged_bndr rhs
- = WUD rhs_usage [NonRec final_bndr final_rhs]
+ = WUD (adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds)
+ [NonRec final_bndr final_rhs]
where
-- Get the join info from the *new* decision
-- See Note [Join points and unfoldings/rules]
@@ -1020,7 +1021,6 @@ occAnalNonRecRhs !env imp_rule_edges tagged_bndr rhs
-- hence adjust the UDs from the RHS
WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join_arity $
occAnalLamTail rhs_env rhs
- rhs_usage = adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds
final_bndr = tagged_bndr `setIdSpecialisation` mkRuleInfo rules'
`setIdUnfolding` unf2
@@ -3369,10 +3369,13 @@ info then simply means setting the corresponding zapped set to the whole
type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's
-- free variables to their usage
-data LocalOcc = OneOccL { lo_n_br :: {-# UNPACK #-} !Int
- , lo_tail :: {-# UNPACK #-} !TailCallInfo
- , lo_int_cxt :: !InterestingCxt }
- | ManyOccL
+data LocalOcc
+ = OneOccL { lo_n_br :: {-# UNPACK #-} !Int
+ , lo_tail :: {-# UNPACK #-} !TailCallInfo
+ -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)
+ -- gives NoTailCallInfo
+ , lo_int_cxt :: !InterestingCxt }
+ | ManyOccL
type ZappedSet = OccInfoEnv -- Values are ignored
@@ -3546,22 +3549,23 @@ mkOccInfoByUnique (UD { ud_z_many = z_many
uniq occ
= case occ of
OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt
- , lo_tail = occ_tail }
- | not (uniq `elemVarEnvByKey`z_many)
+ , lo_tail = tail_info }
+ | uniq `elemVarEnvByKey`z_many
+ -> ManyOccs { occ_tail = tail_info' } -- Hack alert
+ | otherwise
-> OneOcc { occ_in_lam = in_lam
, occ_n_br = n_br
, occ_int_cxt = int_cxt
- , occ_tail = tail }
+ , occ_tail = tail_info' }
where
- tail | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo
- | otherwise = occ_tail
+ tail_info' | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo
+ | otherwise = tail_info
in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam
| otherwise = NotInsideLam
- _other -- ManyOccL and zapped OneOccL
- -> ManyOccs { occ_tail = NoTailCallInfo }
- -- I think this is redundant; remove from ManyOccs
+ ManyOccL -> ManyOccs { occ_tail = NoTailCallInfo }
+ -- I think this is redundant; remove from ManyOccs
-------------------
-- See Note [Adjusting right-hand sides]
@@ -3655,7 +3659,7 @@ tagNonRecBinder :: TopLevelFlag -- At top level?
tagNonRecBinder lvl usage binder
= setBinderOcc occ' binder
where
- occ = lookupDetails usage binder
+ occ = lookupDetails usage binder
will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
occ' | will_be_join = -- Must already be marked AlwaysTailCalled, unless
-- it was a join point before but is now dead
@@ -3757,7 +3761,21 @@ decideJoinPointHood NotTopLevel usage bndrs
= all_ok
where
bndr1 = NE.head bndrs
- lost_join_point = not (isDeadOcc (lookupDetails usage bndr1)) && not all_ok
+ lost_join_point
+ | isDeadOcc (lookupDetails usage bndr1) = False
+ | all_ok = False
+ | otherwise
+ = pprTrace "djph"
+ (let arity = case (tailCallInfo (lookupDetails usage bndr1)) of
+ AlwaysTailCalled ar -> ar
+ NoTailCallInfo -> 0
+ in vcat [ text "bndr1:" <+> ppr bndr1
+ , 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)) ]) $
+ True
-- See Note [Invariants on join points]; invariants cited by number below.
-- Invariant 2 is always satisfiable by the simplifier by eta expansion.
@@ -3848,6 +3866,15 @@ markNonTail occ = occ { occ_tail = NoTailCallInfo }
andOccInfo, orOccInfo :: LocalOcc -> LocalOcc -> LocalOcc
+andOccInfo (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = ar1 })
+ (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = ar2 })
+ | AlwaysTailCalled n1 <- ar1
+ , AlwaysTailCalled n2 <- ar2
+ , n1 == n2
+ = -- Hack alert
+ OneOccL { lo_n_br = nbr1 + nbr2
+ , lo_int_cxt = int_cxt1 `mappend` int_cxt2
+ , lo_tail = AlwaysTailCalled n1 }
andOccInfo _ _ = ManyOccL
-- (orOccInfo orig new) is used
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8afd4872c001bf0e55018934461f0cf7f7501be4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8afd4872c001bf0e55018934461f0cf7f7501be4
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/20230713/865d605c/attachment-0001.html>
More information about the ghc-commits
mailing list