sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 0cf400ee by sheaf at 2026-01-28T14:57:56+01:00 reduce allocs in OccAnal - - - - - 2 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -327,16 +327,16 @@ Rationale for (ExitQuasi2): Suppose we have: - quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co + quasijoinrec j x = case x of { 0 -> 100; _ -> j (x-1) } in j 0 |> co If we float an exit out of 'j', we end up with - join exit = 100 in - quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co + join exit = 100 in + quasijoinrec j x = case x of { 0 -> exit ; _ -> j (x-1) } in j 0 |> co Now suppose we inline j and simplify; we end up with: - join exit = 100 in exit |> co + join exit = 100 in (exit |> co) We see now that 'exit' must be a quasi join point, due to the cast. ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -3714,31 +3714,21 @@ localTailCallInfo (OneOccL { lo_tail = tci }) = tci localTailCallInfo (ManyOccL tci) = tci type ZappedSet = OccInfoEnv -- Values are ignored - --- | Either zap a tail call or set it to a quasi tail call. --- --- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. -type ZapTailSet = IdEnv MarkNonTail - -data MarkNonTail - = MarkQuasi - | MarkNonTail - deriving stock ( Eq, Show ) -instance Outputable MarkNonTail where - ppr MarkQuasi = text "MarkQuasi" - ppr MarkNonTail = text "MarkNonTail" -instance Semigroup MarkNonTail where - MarkQuasi <> MarkQuasi = MarkQuasi - _ <> _ = MarkNonTail - data UsageDetails = UD { ud_env :: !OccInfoEnv , ud_z_many :: !ZappedSet -- ^ apply 'markMany' to these , ud_z_in_lam :: !ZappedSet -- ^ apply 'markInsideLam' to these - , ud_z_tail :: !ZapTailSet -- ^ zap tail-call info for these + , ud_z_tail :: !ZappedSet -- ^ zap tail-call info for these + , ud_z_quasi :: !ZappedSet -- ^ mark these as quasi tail-calls + -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration } -- INVARIANT: All three zapped sets are subsets of ud_env +-- Implementation remark: having two separate sets (ud_z_tail and ud_z_quasi) +-- is significantly more efficient than having a single 'IdEnv IsTrueJoinPoint', +-- as having to use 'strictPlusVarEnv_C' in 'combineUsageDetailsWith' +-- hugely regresses allocations in e.g. T24471. + instance Outputable UsageDetails where ppr ud@(UD { ud_env = env, ud_z_tail = z_tail }) = text "UD" <> (braces (vcat @@ -3852,19 +3842,25 @@ mkSimpleDetails :: OccInfoEnv -> UsageDetails mkSimpleDetails env = UD { ud_env = env , ud_z_many = emptyVarEnv , ud_z_in_lam = emptyVarEnv - , ud_z_tail = emptyVarEnv } + , ud_z_tail = emptyVarEnv + , ud_z_quasi = emptyVarEnv } modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env } delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails -- Delete these binders from the UsageDetails -delBndrsFromUDs bndrs (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 `delVarEnvList` bndrs - , ud_z_many = z_many `delVarEnvList` bndrs - , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs - , ud_z_tail = z_tail `delVarEnvList` bndrs } +delBndrsFromUDs bndrs + (UD { ud_env = env + , ud_z_many = z_many + , ud_z_in_lam = z_in_lam + , ud_z_tail = z_tail + , ud_z_quasi = z_quasi }) + = UD { ud_env = env `delVarEnvList` bndrs + , ud_z_many = z_many `delVarEnvList` bndrs + , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs + , ud_z_tail = z_tail `delVarEnvList` bndrs + , ud_z_quasi = z_quasi `delVarEnvList` bndrs } markAllMany, markAllInsideLam, markAllNonTail, markAllQuasiTail, markAllManyNonTail :: HasDebugCallStack => UsageDetails -> UsageDetails @@ -3872,13 +3868,8 @@ markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env } markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env } markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo -markAllNonTail ud@(UD { ud_env = env }) = - ud { ud_z_tail = fmap (const MarkNonTail) env } -markAllQuasiTail ud@(UD { ud_env = env, ud_z_tail = z_tail }) = - let quasis = fmap (const MarkQuasi) env - in ud { ud_z_tail = strictPlusVarEnv_C (Semi.<>) quasis z_tail } - -- NB: be careful not to override any MarkNonTail with MarkQuasi. - +markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env } +markAllQuasiTail ud@(UD { ud_env = env }) = ud { ud_z_quasi = env } markAllInsideLamIf, markAllNonTailIf :: HasDebugCallStack => Bool -> UsageDetails -> UsageDetails markAllInsideLamIf True ud = markAllInsideLam ud @@ -3888,24 +3879,28 @@ markAllNonTailIf True ud = markAllNonTail ud markAllNonTailIf False ud = ud lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo -lookupTailCallInfo (UD { ud_env = env, ud_z_tail = z_tail }) id = +lookupTailCallInfo (UD { ud_env = env, ud_z_tail = z_tail, ud_z_quasi = z_quasi }) id = case localTailCallInfo <$> lookupVarEnv env id of Nothing -> NoTailCallInfo - Just ti -> maybeZapTailCallInfo ti z_tail (idUnique id) - -maybeZapTailCallInfo :: TailCallInfo -> ZapTailSet -> Unique -> TailCallInfo -maybeZapTailCallInfo tail_info0 z_tail id_unique = - case lookupVarEnv_Directly z_tail id_unique of - Just MarkNonTail -> NoTailCallInfo - - -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - Just MarkQuasi -> - case tail_info0 of - NoTailCallInfo -> NoTailCallInfo - atc@AlwaysTailCalled {} -> - atc { tailCallJoinPointType = QuasiJoinPoint } - - Nothing -> tail_info0 + Just ti -> maybeZapTailCallInfo ti z_tail z_quasi (idUnique id) + +maybeZapTailCallInfo + :: TailCallInfo + -> ZappedSet -- ^ zap tail + -> ZappedSet -- ^ quasi tail + -> Unique + -> TailCallInfo +maybeZapTailCallInfo tail_info0 no_tail quasi_tail id_unique + | elemVarEnvByKey id_unique no_tail + = NoTailCallInfo + | elemVarEnvByKey id_unique quasi_tail + -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. + = case tail_info0 of + NoTailCallInfo -> NoTailCallInfo + atc@AlwaysTailCalled {} -> + atc { tailCallJoinPointType = QuasiJoinPoint } + | otherwise + = tail_info0 udFreeVars :: VarSet -> UsageDetails -> VarSet -- Find the subset of bndrs that are mentioned in uds @@ -3921,18 +3916,20 @@ combineUsageDetailsWith :: (Unique -> LocalOcc -> LocalOcc -> LocalOcc) -> UsageDetails -> UsageDetails -> UsageDetails {-# INLINE combineUsageDetailsWith #-} combineUsageDetailsWith plus_occ_info - uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) - uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) + uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1, ud_z_quasi = z_quasi1 }) + uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2, ud_z_quasi = z_quasi2 }) | isEmptyVarEnv env1 = uds2 | isEmptyVarEnv env2 = uds1 | otherwise -- See Note [Strictness in the occurrence analyser] -- Using strictPlusVarEnv here speeds up the test T26425 -- by about 10% by avoiding intermediate thunks. - = UD { ud_env = strictPlusVarEnv_C_Directly plus_occ_info env1 env2 - , ud_z_many = strictPlusVarEnv z_many1 z_many2 - , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 - , ud_z_tail = strictPlusVarEnv_C (Semi.<>) z_tail1 z_tail2 } + = UD { ud_env = strictPlusVarEnv_C_Directly plus_occ_info env1 env2 + , ud_z_many = strictPlusVarEnv z_many1 z_many2 + , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = strictPlusVarEnv z_tail1 z_tail2 + , ud_z_quasi = strictPlusVarEnv z_quasi1 z_quasi2 + } lookupLetOccInfo :: UsageDetails -> Id -> OccInfo -- Don't use locally-generated occ_info for exported (visible-elsewhere) @@ -3950,13 +3947,14 @@ lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo lookupOccInfoByUnique (UD { ud_env = env , ud_z_many = z_many , ud_z_in_lam = z_in_lam - , ud_z_tail = z_tail }) + , ud_z_tail = z_tail + , ud_z_quasi = z_quasi }) uniq = case lookupVarEnv_Directly env uniq of Nothing -> IAmDead Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt , lo_tail = tail_info }) - | uniq `elemVarEnvByKey`z_many + | uniq `elemVarEnvByKey` z_many -> ManyOccs { occ_tail = mk_tail_info tail_info } | otherwise -> OneOcc { occ_in_lam = in_lam @@ -3969,7 +3967,7 @@ lookupOccInfoByUnique (UD { ud_env = env Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info } where - mk_tail_info ti = maybeZapTailCallInfo ti z_tail uniq + mk_tail_info ti = maybeZapTailCallInfo ti z_tail z_quasi uniq ------------------- -- See Note [Adjusting right-hand sides] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0cf400eea489c3ccae58dd9e2ef2fb63... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0cf400eea489c3ccae58dd9e2ef2fb63... You're receiving this email because of your account on gitlab.haskell.org.