Simon Peyton Jones pushed to branch wip/T26425 at Glasgow Haskell Compiler / GHC Commits: abc9be83 by Simon Peyton Jones at 2025-11-14T00:10:55+00:00 Experimental orUDs for RHSs - - - - - 1 changed file: - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -66,7 +66,6 @@ import GHC.Builtin.Names( runRWKey ) import GHC.Unit.Module( Module ) import Data.List (mapAccumL) -import Data.List.NonEmpty (NonEmpty (..)) {- ************************************************************************ @@ -1040,10 +1039,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine | mb_join@(JoinPoint {}) <- idJoinPointHood bndr = -- Analyse the RHS and /then/ the body let -- Analyse the rhs first, generating rhs_uds - !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs - rhs_uds = foldl1' (combineJoinPointUDs env) - rhs_uds_s -- NB: combineJoinPointUDs. See (W4) of - -- Note [Occurrence analysis for join points] + !(rhs_uds, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs -- Now analyse the body, adding the join point -- into the environment with addJoinPoint @@ -1053,9 +1049,9 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine in if isDeadOcc occ -- Drop dead code; see Note [Dead code] then WUD body_uds body - else -- pprTrace "occAnal-nonrec" (vcat [ ppr bndr <+> ppr occ - -- , text "rhs_uds" <+> ppr rhs_uds - -- , text "body_uds" <+> ppr body_uds ]) $ + else pprTrace "occAnal-nonrec" (vcat [ ppr bndr <+> ppr occ + , text "rhs_uds" <+> ppr rhs_uds + , text "body_uds" <+> ppr body_uds ]) $ WUD (combineJoinPointUDs env rhs_uds body_uds) -- Note `orUDs` (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs'] body) @@ -1072,8 +1068,8 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine -- => join arity O of Note [Join arity prediction based on joinRhsArity] (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr - !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs - in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs` + !(rhs_uds, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs + in WUD (rhs_uds `andUDs` body_uds) -- Note `andUDs` (combine [NonRec final_bndr rhs'] body) ----------------- @@ -1088,15 +1084,21 @@ occAnalNonRecBody env bndr thing_inside ----------------- occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges - -> JoinPointHood -> Id -> CoreExpr - -> (NonEmpty UsageDetails, Id, CoreExpr) + -> JoinPointHood -> Id -> CoreExpr + -> (UsageDetails, Id, CoreExpr) occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs | null rules, null imp_rule_infos = -- Fast path for common case of no rules. This is only worth -- 0.1% perf on average, but it's also only a line or two of code - ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs ) + ( adj_rhs_uds `orUDs` adj_unf_uds + , final_bndr_no_rules, final_rhs ) + | otherwise - = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs ) + = ( foldl' orUDs (adj_rhs_uds `orUDs` adj_unf_uds) adj_rule_uds + , final_bndr_with_rules, final_rhs ) + + -- orUDs: Combine the RHS, (stable) unfolding, and RULES with orUDs + -- See (W4) of Note [Occurrence analysis for join points] where --------- Right hand side --------- -- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/abc9be8328b3edeac5f770ab5f541759... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/abc9be8328b3edeac5f770ab5f541759... You're receiving this email because of your account on gitlab.haskell.org.