sheaf pushed to branch wip/andreask/ticked_joins at Glasgow Haskell Compiler / GHC Commits: 425073c8 by sheaf at 2026-01-26T20:00:08+01:00 WIP: refactoring - - - - - 591bc759 by sheaf at 2026-01-26T20:26:19+01:00 WIP fixes - - - - - 19 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -935,7 +935,12 @@ lintCoreExpr (Tick tickish expr) -- ; when block_joins ; pure r} where - block_joins = not (tickishCanScopeJoin tickish) + block_joins + | ProfNote {} <- tickish + = False -- Turns a true join point into a quasi join point. + -- SLD TODO: proper Core Lint support for quasi join points. + | otherwise + = not (tickishCanScopeJoin tickish) -- TODO Consider whether this is the correct rule. It is consistent with -- the simplifier's behaviour - cost-centre-scoped ticks become part of -- the continuation, and thus they behave like part of an evaluation @@ -1021,22 +1026,27 @@ lintCoreExpr e@(App _ _) ; return app_pair} where - skipTick t = case collectFunSimple e of - (Var v) -> etaExpansionTick v t - _ -> tickishFloatable t - (fun, args, _source_ticks) = collectArgsTicks skipTick e - -- We must look through source ticks to avoid #21152, for example: + skipTick t = + case collectFunSimple e of + Var v -> canCollectArgsThroughTick v t + _ -> tickishFloatable t + (fun, args, _ticks) = collectArgsTicks skipTick e + -- We must look through ticks, using similar logic as CorePrep does, + -- otherwise we may fail to spot a saturated application. + -- + -- 1. Look through floatable ticks, as per Note [Eta expansion and source notes] + -- in GHC.Core.Opt.Arity. We need to do this to avoid e.g.: + -- + -- reallyUnsafePtrEquality + -- = \ @a -> + -- (src<loc> reallyUnsafePtrEquality#) + -- @Lifted @a @Lifted @a -- - -- reallyUnsafePtrEquality - -- = \ @a -> - -- (src<loc> reallyUnsafePtrEquality#) - -- @Lifted @a @Lifted @a + -- 2. Look through profiling ticks when the head of the application must + -- always remain saturated (e.g. a primop or a join point), as per + -- Note [Ticks and mandatory eta expansion] in GHC.CoreToStg.Prep. -- - -- To do this, we use `collectArgsTicks tickishFloatable` to match - -- the eta expansion behaviour, as per Note [Eta expansion and source notes] - -- in GHC.Core.Opt.Arity. - -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. - -- See Note [Ticks and mandatory eta expansion] + -- To do this, we use 'canCollectArgsThroughTick', as CorePrep does. lintCoreExpr (Lam var expr) = markAllJoinsBad $ ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -226,7 +226,7 @@ exitifyRec in_scope pairs let rhs = mkLams abs_vars e avoid = in_scope `extendInScopeSetList` captured -- Remember this binding under a suitable name - ; v <- addExit avoid TrueJoinPoint (length abs_vars) rhs + ; v <- addExit avoid (length abs_vars) rhs -- And jump to it from here ; return $ mkVarApps (Var v) abs_vars } @@ -262,7 +262,7 @@ exitifyRec in_scope pairs -- * the free variables of the whole joinrec -- * any bound variables (captured) -- * any exit join points created so far. -mkExitJoinId :: InScopeSet -> Type -> JoinType -> JoinArity -> ExitifyM JoinId +mkExitJoinId :: InScopeSet -> Type -> JoinPointType -> JoinArity -> ExitifyM JoinId mkExitJoinId in_scope ty join_ty join_arity = do fs <- get let avoid = in_scope `extendInScopeSetList` (map fst fs) @@ -273,11 +273,11 @@ mkExitJoinId in_scope ty join_ty join_arity = do asJoinId (mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty) join_ty join_arity -addExit :: InScopeSet -> JoinType -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_ty join_arity rhs = do +addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId +addExit in_scope join_arity rhs = do -- Pick a suitable name let ty = exprType rhs - v <- mkExitJoinId in_scope ty join_ty join_arity + v <- mkExitJoinId in_scope ty TrueJoinPoint join_arity fs <- get put ((v,rhs):fs) return v ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1126,7 +1126,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- returned by of occAnalLamTail. It's totally OK for them to mismatch; -- hence adjust the UDs from the RHS - WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ + WUD adj_rhs_uds final_rhs = adjustNonRecRhs (joinPointHoodArity mb_join) $ occAnalLamTail rhs_env rhs final_bndr_with_rules | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] @@ -1140,7 +1140,8 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs -- See Note [Join points and unfoldings/rules] unf = idUnfolding bndr WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf - adj_unf_uds = adjustTailArity mb_join unf_tuds + adj_unf_uds = adjustTailArity mb_join_arity unf_tuds + mb_join_arity = joinPointHoodArity mb_join --------- Rules --------- -- See Note [Rules are extra RHSs] and Note [Rule dependency info] @@ -1160,7 +1161,7 @@ occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs adj_rule_uds :: [UsageDetails] adj_rule_uds = imp_rule_uds ++ - [ l `andUDs` adjustTailArity mb_join r + [ l `andUDs` adjustTailArity mb_join_arity r | (_,l,r) <- rules_w_uds ] mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl @@ -1215,7 +1216,7 @@ occAnalRec !_ lvl = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr - !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds + !(WUD rhs_uds' rhs') = adjustNonRecRhs (joinPointHoodArity mb_join) wtuds in WUD (body_uds `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) where @@ -1831,7 +1832,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness -- here because that is what we are setting! WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf - adj_unf_uds = adjustTailArity (JoinPoint True rhs_ja) unf_tuds + adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source MAr -- of Note [Join arity prediction based on joinRhsArity] @@ -1846,7 +1847,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source MAr -- of Note [Join arity prediction based on joinRhsArity] rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = [ (r,l,adjustTailArity (JoinPoint True rhs_ja) rhs_wuds) + rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_wuds) | rule <- idCoreRules bndr , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ] rules' = map fstOf3 rules_w_uds @@ -2298,7 +2299,7 @@ occ_anal_lam_tail env (Cast expr co) _ -> usage1 -- usage3: see Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - usage3 = markAllQuasiTail usage2 + usage3 = markAllQuasiTail usage2 -- SLD TODO in WUD usage3 (Cast expr' co) @@ -2606,19 +2607,11 @@ occAnal env (Tick tickish body) usage_lam = markAllNonTail (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick<t> (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. - occAnal env (Cast expr co) = let (WUD usage expr') = occAnal env expr usage1 = addManyOccs usage (coVarsOfCo co) -- usage1: see Note [Gather occurrences of coercion variables] - usage2 = markAllQuasiTail usage1 + usage2 = markAllQuasiTail usage1 -- SLD TODO -- usage2: see Note [Quasi join points] in WUD usage2 (Cast expr' co) @@ -2626,7 +2619,7 @@ occAnal env app@(App _ _) = occAnalApp env (collectArgsTicks tickishFloatable app) occAnal env expr@(Lam {}) - = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail + = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail occAnalLamTail env expr occAnal env (Case scrut bndr ty alts) @@ -2754,7 +2747,8 @@ occAnalApp env (Var fun, args, ticks) -- This caused #18296 | fun `hasKey` runRWKey , [t1, t2, arg] <- args - , WUD usage arg' <- adjustNonRecRhs (JoinPoint True 1) $ occAnalLamTail env arg + , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg + -- SLD TODO TrueJoinPoint OK here?? = let app_out = mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'] in WUD usage app_out @@ -3814,8 +3808,8 @@ mkOneOcc !env id int_cxt arity , lo_tail = AlwaysTailCalled { tailCallArity = arity - , trueTailCall = True - -- ^ Start off as a true join point. + , tailCallJoinPointType = TrueJoinPoint + -- Start off as a true join point. -- Updated by occurrence analysis. -- -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. @@ -3903,7 +3897,11 @@ maybeZapTailCallInfo tail_info0 z_tail id_unique = Just MarkNonTail -> NoTailCallInfo -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. - Just MarkQuasi -> tail_info0 { trueTailCall = False } + Just MarkQuasi -> + case tail_info0 of + NoTailCallInfo -> NoTailCallInfo + atc@AlwaysTailCalled {} -> + atc { tailCallJoinPointType = QuasiJoinPoint } Nothing -> tail_info0 @@ -3974,7 +3972,7 @@ lookupOccInfoByUnique (UD { ud_env = env ------------------- -- See Note [Adjusting right-hand sides] -adjustNonRecRhs :: JoinPointHood +adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr -- ^ This function concentrates shared logic between occAnalNonRecBind and the @@ -3985,8 +3983,8 @@ adjustNonRecRhs mb_join_arity (WTUD (TUD rhs_ja uds) rhs) where exact_join = case mb_join_arity of - NotJoinPoint -> False - JoinPoint { joinPointArity = ja' } -> ja' == rhs_ja + Nothing -> False + Just ja' -> ja' == rhs_ja adjustTailUsage :: Bool -- True <=> Exactly-matching join point; don't do markNonTail -> CoreExpr -- Rhs usage, AFTER occAnalLamTail @@ -4000,12 +3998,12 @@ adjustTailUsage exact_join rhs uds where one_shot = isOneShotFun rhs -adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails +adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails adjustTailArity mb_rhs_ja (TUD ja usage) = markAllNonTailIf not_same_arity usage where not_same_arity = case mb_rhs_ja of - NotJoinPoint -> True - JoinPoint { joinPointArity = ja' } -> ja' /= ja + Nothing -> True + Just ja' -> ja' /= ja type IdWithOccInfo = Id @@ -4037,8 +4035,11 @@ tagNonRecBinder :: TopLevelFlag -- At top level? -- Precondition: OccInfo is not IAmDead tagNonRecBinder lvl occ bndr | okForJoinPoint lvl bndr tail_call_info - , AlwaysTailCalled { tailCallArity = ar, trueTailCall = true } <- tail_call_info - = (setBinderOcc occ bndr, JoinPoint true ar) + , AlwaysTailCalled + { tailCallArity = ar + , tailCallJoinPointType = join_ty + } <- tail_call_info + = (setBinderOcc occ bndr, JoinPoint join_ty ar) | otherwise = (setBinderOcc zapped_occ bndr, NotJoinPoint) where @@ -4229,5 +4230,5 @@ orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2 andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo (AlwaysTailCalled arity1 true1) (AlwaysTailCalled arity2 true2) - | arity1 == arity2 = AlwaysTailCalled arity1 (true1 && true2) + | arity1 == arity2 = AlwaysTailCalled arity1 (true1 Semi.<> true2) andTailCallInfo _ _ = NoTailCallInfo ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -1889,11 +1889,10 @@ newPolyBndrs dest_lvl dest_is_top = isTopLvl dest_lvl transfer_join_info bndr new_bndr | JoinPoint - { isTrueJoinPoint = true_join + { joinPointType = join_ty , joinPointArity = join_arity } <- idJoinPointHood bndr , not dest_is_top - , let join_ty = if true_join then TrueJoinPoint else QuasiJoinPoint = asJoinId new_bndr join_ty ( join_arity + length abs_vars ) ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -493,8 +493,8 @@ instance Outputable SimplSR where where pp_mj = case mj of NotJoinPoint -> empty - JoinPoint true_join n - -> (if true_join then empty else text "[Quasi]") <> parens (int n) + JoinPoint { joinPointType = join_ty, joinPointArity = n } + -> ppr join_ty <> parens (int n) ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -2073,7 +2073,7 @@ simplNonRecJoinPoint env bndr rhs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case - | Just True <- occInfoIsTrueJoinPoint (idOccInfo bndr) + | Just TrueJoinPoint <- occInfoJoinPointType_maybe (idOccInfo bndr) = seCaseCase env | otherwise = False @@ -2094,7 +2094,7 @@ simplRecJoinPoint env pairs body cont ; return (floats1 `addFloats` floats2, body') } where do_case_case = - if all ((== Just True) . occInfoIsTrueJoinPoint . idOccInfo . fst) pairs + if all ((== Just TrueJoinPoint) . occInfoJoinPointType_maybe . idOccInfo . fst) pairs then seCaseCase env else False @@ -2133,10 +2133,12 @@ trimJoinCont :: Id -- Used only in error message trimJoinCont _ NotJoinPoint cont = cont -- Not a jump -trimJoinCont var (JoinPoint { isTrueJoinPoint = true_join, joinPointArity = arity }) cont - = assertPpr true_join - (text "trimJoinCont: unexpected quasi join point:" <+> ppr var) $ - trim arity cont +trimJoinCont var (JoinPoint { joinPointType = join_ty, joinPointArity = arity }) cont + | QuasiJoinPoint <- join_ty + -- SLD TODO: not sure why we can end up here. Needs further investigation. + = cont + | otherwise + = trim arity cont where trim 0 cont@(Stop {}) = cont @@ -2246,7 +2248,7 @@ Note [Join points and case-of-case]: This transformation is not valid if the occurrences of 'j' in 'body' appear: 1. under casts (see #26422) - 2. under profiling ticks (see #26693, #26157, #26642) + 2. under profiling ticks (see #14242, #26157, #26642, #26693) For example, consider (a minimisation of) the program in #26693: @@ -2312,7 +2314,7 @@ we proceed as follows: 2. In the simplifier, when we come across a join point binding (in either 'simplNonRecJoinPoint' or 'simplRecJoinPoint'), we retrieve the information of whether this is a true join point or a quasi join point using - 'occInfoIsTrueJoinPoint'. + 'occInfoJoinPointType_maybe'. If we are dealing with a quasi join point, we switch off the case-of-case transformation. ===================================== compiler/GHC/Core/Opt/Simplify/Monad.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Prelude import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) -import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo, JoinType (..) ) +import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) import GHC.Core.Opt.Stats import GHC.Core.Rules ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -46,7 +46,7 @@ import GHC.Types.InlinePragma import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id -import GHC.Types.Id.Info ( IdDetails(..), JoinType (..) ) +import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -1993,9 +1993,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) spec_id_ty = mkLamTypes spec_lam_args spec_body_ty spec_arity = count isId spec_lam_args spec_join_arity - | Just ty <- joinId_maybe fn - , let is_true = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False } - = JoinPoint { isTrueJoinPoint = is_true, joinPointArity = length spec_call_args } + | Just join_ty <- joinId_maybe fn + = JoinPoint { joinPointType = join_ty, joinPointArity = length spec_call_args } | otherwise = NotJoinPoint spec_id = setCbvCandidate $ ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -844,10 +844,10 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div -- inl_rule: it does not make sense for workers to be constructorlike. work_join_arity - | Just ty <- joinId_maybe fn_id = - let true_join = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False } - in JoinPoint true_join join_arity - | otherwise = NotJoinPoint + | Just join_ty <- joinId_maybe fn_id + = JoinPoint join_ty join_arity + | otherwise + = NotJoinPoint -- worker is join point iff wrapper is join point -- (see Note [Don't w/w join points for CPR]) ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -308,13 +308,21 @@ ppr_expr add_par (Let bind expr) sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), pprCoreExpr expr] where - keyword (NonRec b _) - | isJoinPoint (bndrIsJoin_maybe b) = text "join" - | otherwise = text "let" - keyword (Rec pairs) - | ((b,_):_) <- pairs - , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec" - | otherwise = text "letrec" + keyword (NonRec b _) = + case bndrIsJoin_maybe b of + NotJoinPoint -> text "let" + JoinPoint { joinPointType = join_ty } -> + case join_ty of + TrueJoinPoint -> text "join" + QuasiJoinPoint -> text "quasijoin" + keyword (Rec ((b,_):_)) = + case bndrIsJoin_maybe b of + NotJoinPoint -> text "letrec" + JoinPoint { joinPointType = join_ty } -> + case join_ty of + TrueJoinPoint -> text "joinrec" + QuasiJoinPoint -> text "quasijoinrec" + keyword (Rec _) = text "letrec" ppr_expr add_par (Tick tickish expr) = sdocOption sdocSuppressTicks $ \case ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -38,7 +38,10 @@ import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Types.Literal import GHC.Types.Id -import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..), JoinType (..) ) +import GHC.Types.Id.Info + ( IdInfo(..) + , realUnfoldingInfo, setUnfoldingInfo, setRuleInfo + ) import GHC.Types.InlinePragma ( isAlwaysActive ) import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set @@ -1078,12 +1081,11 @@ joinPointBinding_maybe bndr rhs | AlwaysTailCalled { tailCallArity = join_arity - , trueTailCall = is_true_tail } + , tailCallJoinPointType = join_ty } <- tailCallInfo (idOccInfo bndr) , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs , let str_sig = idDmdSig bndr str_arity = count isId bndrs -- Strictness demands are for Ids only - join_ty = if is_true_tail then TrueJoinPoint else QuasiJoinPoint join_bndr = (asJoinId bndr join_ty join_arity) `setIdDmdSig` etaConvertDmdSig str_arity str_sig ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Core.Utils ( exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, exprIsUnaryClassFun, isUnaryClassId, - altsAreExhaustive, etaExpansionTick, + altsAreExhaustive, canCollectArgsThroughTick, cantEtaReduceFun, -- * Equality @@ -2076,14 +2076,17 @@ altsAreExhaustive (Alt con1 _ _ : alts) -- we behave conservatively here -- I don't think it's important -- enough to deserve special treatment --- | Should we look past this tick when eta-expanding the given function? +-- | Should we look past this tick when collecting arguments +-- for the given function? -- -- See Note [Ticks and mandatory eta expansion] --- Takes the function we are applying as argument. -etaExpansionTick :: Id -> GenTickish pass -> Bool -etaExpansionTick id t - = ( cantEtaReduceFun id ) && - ( tickishFloatable t || isProfTick t ) +canCollectArgsThroughTick + :: Id -- ^ function at the head of the application + -> GenTickish pass -- ^ tick we want to collect arguments past + -> Bool +canCollectArgsThroughTick id t + = tickishFloatable t + || (cantEtaReduceFun id && isProfTick t) -- | Can we eta-reduce the given function? -- See Note [Eta reduction soundness], criteria (B), (J), and (W). ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1052,8 +1052,8 @@ cpeApp top_env expr -- floating the tick which isn't optimal for perf. But this only makes -- a difference if we have a non-floatable tick which is somewhat rare. | Var vh <- head - , Var head' <- lookupCorePrepEnv top_env vh - , etaExpansionTick head' tickish + , Just head' <- getIdFromTrivialExpr_maybe (lookupCorePrepEnv top_env vh) + , canCollectArgsThroughTick head' tickish = (head,as') where (head,as') = go fun (AITick tickish : as) ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -24,7 +24,7 @@ module GHC.Types.Basic ( ConTag, ConTagZ, fIRST_TAG, Arity, VisArity, RepArity, JoinArity, FullArgCount, - JoinPointHood(..), isJoinPoint, + JoinPointType(..), JoinPointHood(..), joinPointHoodArity, isJoinPoint, Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -70,7 +70,7 @@ module GHC.Types.Basic ( BranchCount, oneBranch, InterestingCxt(..), TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, - isAlwaysTailCalled, occInfoIsTrueJoinPoint, + isAlwaysTailCalled, occInfoJoinPointType_maybe, EP(..), @@ -1150,11 +1150,16 @@ instance Monoid InsideLam where ----------------- +joinPointHoodArity :: JoinPointHood -> Maybe JoinArity +joinPointHoodArity = \case + NotJoinPoint -> Nothing + JoinPoint { joinPointArity = ja } -> Just ja + -- | See Note [TailCallInfo] data TailCallInfo = AlwaysTailCalled - { tailCallArity :: {-# UNPACK #-} !JoinArity - , trueTailCall :: !Bool -- ^ is this a true join point? see Note [Quasi join points] + { tailCallArity :: {-# UNPACK #-} !JoinArity + , tailCallJoinPointType :: !JoinPointType -- ^ See Note [Quasi join points] } | NoTailCallInfo deriving (Eq) @@ -1176,14 +1181,14 @@ isAlwaysTailCalled occ -- If so, is it a true join point or a quasi join point? -- -- See Note [Quasi join points] in GHC.Core.Opt.Simplify.Iteration. -occInfoIsTrueJoinPoint :: OccInfo -> Maybe Bool -occInfoIsTrueJoinPoint occ = +occInfoJoinPointType_maybe :: OccInfo -> Maybe JoinPointType +occInfoJoinPointType_maybe occ = case tailCallInfo occ of - AlwaysTailCalled { trueTailCall = true } -> Just true + AlwaysTailCalled { tailCallJoinPointType = join_ty } -> Just join_ty NoTailCallInfo -> Nothing instance Outputable TailCallInfo where - ppr (AlwaysTailCalled ar t) = - sep [ text "Tail", (if t then empty else text "Quasi"), int ar ] + ppr (AlwaysTailCalled { tailCallJoinPointType = join_ty, tailCallArity = ar }) = + sep [ ppr join_ty <> text "Tail", int ar ] ppr NoTailCallInfo = text "NoTailCallInfo" ----------------- @@ -1232,8 +1237,11 @@ instance Outputable OccInfo where pp_tail = pprShortTailCallInfo tail_info pprShortTailCallInfo :: TailCallInfo -> SDoc -pprShortTailCallInfo (AlwaysTailCalled ar t) - = char 'T' <> (if t then empty else text "[Q]") +pprShortTailCallInfo + (AlwaysTailCalled + { tailCallJoinPointType = join_type + , tailCallArity = ar }) + = char 'T' <> (case join_type of { TrueJoinPoint -> empty; QuasiJoinPoint -> char 'Q' }) <> brackets (int ar) pprShortTailCallInfo NoTailCallInfo = empty ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -574,7 +574,7 @@ isWorkerLikeId id = isJoinId :: Var -> Bool isJoinId = isJust . joinId_maybe -joinId_maybe :: Var -> Maybe JoinType +joinId_maybe :: Var -> Maybe JoinPointType -- It is convenient in GHC.Core.Opt.SetLevels.lvlMFE to apply isJoinId -- to the free vars of an expression, so it's convenient -- if it returns False for type variables @@ -589,10 +589,11 @@ idJoinPointHood :: Var -> JoinPointHood idJoinPointHood id | isId id = case Var.idDetails id of - JoinId ty arity _marks -> - let isTrue = case ty of { TrueJoinPoint -> True; QuasiJoinPoint -> False} - in JoinPoint isTrue arity - _ -> NotJoinPoint + JoinId + { joinIdType = join_type + , joinIdArity = arity } + -> JoinPoint join_type arity + _ -> NotJoinPoint | otherwise = NotJoinPoint idDataCon :: Id -> DataCon @@ -675,7 +676,7 @@ idJoinArity id = JoinPoint { joinPointArity = ar } -> ar NotJoinPoint -> pprPanic "idJoinArity" (ppr id) -asJoinId :: Id -> JoinType -> JoinArity -> JoinId +asJoinId :: Id -> JoinPointType -> JoinArity -> JoinId asJoinId id ty arity = warnPprTrace (not (isLocalId id)) "global id being marked as join var" (ppr id) $ @@ -710,9 +711,8 @@ zapJoinId jid asJoinId_maybe :: Id -> JoinPointHood -> Id asJoinId_maybe id = \case NotJoinPoint -> zapJoinId id - JoinPoint { isTrueJoinPoint = true_join, joinPointArity = arity } -> - let ty = if true_join then TrueJoinPoint else QuasiJoinPoint - in asJoinId id ty arity + JoinPoint { joinPointType = join_type, joinPointArity = arity } -> + asJoinId id join_type arity {- ************************************************************************ ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -65,7 +65,7 @@ module GHC.Types.Id.Info ( TailCallInfo(..), tailCallInfo, isAlwaysTailCalled, - JoinType(..), + JoinPointType(..), -- ** The RuleInfo type RuleInfo(..), @@ -207,7 +207,7 @@ data IdDetails -- This only covers /un-lifted/ coercions, of type -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants | JoinId - { joinIdType :: JoinType + { joinIdType :: JoinPointType , joinIdArity :: JoinArity , joinIdCbvMarks :: Maybe [CbvMark] } @@ -226,14 +226,6 @@ data IdDetails -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current -- module. -data JoinType - = TrueJoinPoint - | QuasiJoinPoint - deriving stock ( Eq, Show ) -instance Outputable JoinType where - ppr TrueJoinPoint = text "TrueJoinPoint" - ppr QuasiJoinPoint = text "QuasiJoinPoint" - data RecSelInfo = RSI { rsi_def :: [ConLike] -- Record selector defined for these , rsi_undef :: [ConLike] -- Record selector not defined for these @@ -422,7 +414,7 @@ isCoVarDetails :: IdDetails -> Bool isCoVarDetails CoVarId = True isCoVarDetails _ = False -isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinType, JoinArity, Maybe [CbvMark]) +isJoinIdDetails_maybe :: IdDetails -> Maybe (JoinPointType, JoinArity, Maybe [CbvMark]) isJoinIdDetails_maybe (JoinId ty join_arity marks) = Just (ty, join_arity, marks) isJoinIdDetails_maybe _ = Nothing ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -330,7 +330,8 @@ tickishCanSplit _ = False -- | Is @join f x in <tick> jump f x@ valid? tickishCanScopeJoin :: GenTickish pass -> Bool tickishCanScopeJoin tick = case tick of - ProfNote{} -> True + ProfNote{} -> False -- Turns the join point into a quasi join point. + -- See Note [Quasi join points] HpcTick{} -> False Breakpoint{} -> False SourceNote{} -> True ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -132,7 +132,7 @@ import GHC.Utils.Fingerprint import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict -import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHC.Utils.Outputable( JoinPointHood(..), JoinPointType (..) ) import GHCi.FFI import GHCi.Message @@ -1053,6 +1053,10 @@ instance Binary DiffTime where get bh = do r <- get bh return $ fromRational r +instance Binary JoinPointType where + put_ bh ty = put_ bh (ty == TrueJoinPoint) + get bh = do { true <- get bh; return $ if true then TrueJoinPoint else QuasiJoinPoint } + instance Binary JoinPointHood where put_ bh NotJoinPoint = putByte bh 0 put_ bh (JoinPoint t ar) = do ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -15,7 +15,7 @@ module GHC.Utils.Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), - BindingSite(..), JoinPointHood(..), isJoinPoint, + BindingSite(..), JoinPointType(..), JoinPointHood(..), isJoinPoint, IsOutput(..), IsLine(..), IsDoc(..), HLine, HDoc, @@ -150,6 +150,7 @@ import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) import Data.Semigroup (Arg(..)) +import qualified Data.Semigroup as Semi import qualified Data.List.NonEmpty as NEL import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 @@ -1284,10 +1285,21 @@ data BindingSite | LetBind -- ^ The x in (let x = rhs in e) deriving Eq +data JoinPointType + = TrueJoinPoint + | QuasiJoinPoint + deriving Eq +instance Outputable JoinPointType where + ppr TrueJoinPoint = empty + ppr QuasiJoinPoint = text "Quasi" +instance Semigroup JoinPointType where + TrueJoinPoint <> TrueJoinPoint = TrueJoinPoint + _ <> _ = QuasiJoinPoint + data JoinPointHood = JoinPoint - { isTrueJoinPoint :: {-# UNPACK #-} !Bool - , joinPointArity :: {-# UNPACK #-} !Int + { joinPointType :: {-# UNPACK #-} !JoinPointType + , joinPointArity :: {-# UNPACK #-} !Int -- ^ The JoinArity (but an Int here because synonym JoinArity is defined in Types.Basic) } | NotJoinPoint @@ -1298,10 +1310,9 @@ isJoinPoint (JoinPoint {}) = True isJoinPoint NotJoinPoint = False instance Outputable JoinPointHood where - ppr NotJoinPoint = text "NotJoinPoint" - ppr (JoinPoint true arity) = - (if true then empty else text "Quasi") - <> text "JoinPoint" <> parens (ppr arity) + ppr NotJoinPoint = text "NotJoinPoint" + ppr (JoinPoint join_type arity) = + ppr join_type <> text "JoinPoint" <> parens (ppr arity) instance NFData JoinPointHood where rnf x = x `seq` () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d01b5ee6554022b6898aed101f3cf7e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d01b5ee6554022b6898aed101f3cf7e... You're receiving this email because of your account on gitlab.haskell.org.