sheaf pushed to branch wip/debug-join-point at Glasgow Haskell Compiler / GHC Commits: 14de70ed by sheaf at 2026-02-03T15:21:02+01:00 WIP: debug panic - - - - - 3 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Prelude import GHC.Core.Coercion.Opt ( OptCoercionOpts ) import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core.SimpleOpt ( isJoinPointBinding ) import GHC.Core.Opt.Arity ( ArityOpts(..) ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Rules.Config ( RuleOpts(..) ) @@ -854,7 +855,7 @@ isEmptyJoinFloats = isNilOL unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form -unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ +unitLetFloat bind = assert (all (not . isJoinPointBinding) (bindersOf bind)) $ LetFloats (unitOL bind) (flag bind) where flag (Rec {}) = FltLifted @@ -867,7 +868,7 @@ unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ | otherwise = FltCareful unitJoinFloat :: OutBind -> JoinFloats -unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $ +unitJoinFloat bind = assert (all isJoinPointBinding (bindersOf bind)) $ unitOL bind mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv) @@ -1123,7 +1124,7 @@ simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids -- See Note [Bangs in the Simplifier] - = assert (all (not . isJoinId) ids) $ + = assert (all (not . isJoinPointBinding) ids) $ do { let (!env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } @@ -1256,7 +1257,7 @@ simplRecJoinBndrs :: SimplEnv -> [InBndr] -- context being pushed inward may change types -- See Note [Return type for join points] simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty - = assert (all isJoinId ids) $ + = assert (all isJoinPointBinding ids) $ do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids ; seqIds ids1 `seq` return env1 } @@ -1283,7 +1284,7 @@ adjustJoinPointType :: Mult -- INVARIANT: If any of the first n binders are foralls, those tyvars -- cannot appear in the original result type. See isValidJoinPointType. adjustJoinPointType mult new_res_ty join_id - = assert (isJoinId join_id) $ + = assert (isJoinPointBinding join_id) $ setIdType join_id new_join_ty where join_arity = idJoinArity join_id ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -38,7 +38,7 @@ import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe , pushCoTyArg, pushCoValArg, exprIsDeadEnd , typeArity, arityTypeArity, etaExpandAT ) -import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe, isJoinPointBinding ) import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) import GHC.Core.Rules ( lookupRule, getRules ) import GHC.Core.Multiplicity @@ -316,8 +316,8 @@ simplLazyBind :: TopLevelFlag -> RecFlag -- Precondition: Ids only, no TyVars; not a JoinId -- Precondition: rhs obeys the let-can-float invariant simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) - = assert (isId bndr ) - assertPpr (not (isJoinId bndr)) (ppr bndr) $ + = assert (isId bndr) + assertPpr (not $ isJoinPointBinding bndr) (ppr bndr) $ -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] (tvs, body) = case collectTyAndValBinders rhs of @@ -399,7 +399,7 @@ simplAuxBind :: String -- Precondition: rhs satisfies the let-can-float invariant simplAuxBind _str env bndr new_rhs - | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ + | assertPpr (isId bndr && not (isJoinPointBinding bndr)) (ppr bndr) $ isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } = return (emptyFloats env, env) -- Here c is dead, and we avoid -- creating the binding c = (a,b) @@ -1905,7 +1905,7 @@ simplNonRecE :: HasDebugCallStack -- Otherwise it may or may not satisfy it. simplNonRecE env from_what bndr (rhs, rhs_se) body cont - | assert (isId bndr && not (isJoinId bndr) ) $ + | assert (isId bndr && not (isJoinPointBinding bndr)) $ is_strict_bind = -- Evaluate RHS strictly simplExprF (rhs_se `setInScopeFromE` env) rhs @@ -1943,7 +1943,7 @@ simplRecE :: SimplEnv -- Precondition: not a join-point binding simplRecE env pairs body cont = do { let bndrs = map fst pairs - ; massert (all (not . isJoinId) bndrs) + ; massert (isNothing $ joinPointBindings_maybe pairs) ; env1 <- simplRecBndrs env bndrs -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -2051,7 +2051,7 @@ simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) simplNonRecJoinPoint env bndr rhs body cont - = assert (isJoinId bndr ) $ + = assert (isJoinPointBinding bndr) $ wrapJoinCont env cont $ \ env cont -> do { -- We push join_cont into the join RHS and the body; -- and wrap wrap_cont around the whole thing @@ -4574,22 +4574,24 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf | isStableUnfolding unf = simplStableUnfolding env bind_cxt id rhs_ty arity unf - | freshly_born_join_point id - = -- This is a tricky one! - -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth] - return noUnfolding - | isExitJoinId id = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify return noUnfolding - | otherwise - = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs + | freshly_born_join_point + = -- This is a tricky one! + -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth] + return noUnfolding + | otherwise + = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id' is_join new_rhs' where - is_join_point = isJoinId id - freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id) - -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627 + (id', new_rhs', is_join) = + case joinPointBinding_maybe id new_rhs of + Nothing -> (id, new_rhs, False) + Just (id', new_rhs') -> (id', new_rhs', True) + freshly_born_join_point = + is_join && (not (isJoinId id) || isManyOccs (idOccInfo id)) ------------------- mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -12,6 +12,7 @@ module GHC.Core.SimpleOpt ( -- ** Join points joinPointBinding_maybe, joinPointBindings_maybe, + isJoinPointBinding, -- ** Predicates on expressions exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, @@ -1059,34 +1060,42 @@ and again its arity increases (#15517) -} --- | Returns Just (bndr,rhs) if the binding is a join point: --- If it's a JoinId, just return it --- If it's not yet a JoinId but is always tail-called, --- make it into a JoinId and return it. --- In the latter case, eta-expand the RHS if necessary, to make the --- lambdas explicit, as is required for join points --- --- Precondition: the InBndr has been occurrence-analysed, --- so its OccInfo is valid +-- | Returns @Just (bndr,rhs)@ if the binding is a join point or can be made +-- into a join point (it is always tail called). In the latter case, eta-expand +-- the RHS if necessary, to make the lambdas explicit, as is required for join points. joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) joinPointBinding_maybe bndr rhs | not (isId bndr) = Nothing + -- NB: the 'OccInfo' of the 'InBndr' may have been zapped, e.g. if we + -- have inlined it. In this case, we may lose the join-point-hood of the + -- original binder. A later occurrence analysis pass may recover it. | isJoinId bndr - = Just (bndr, rhs) + = case tailCallInfo (idOccInfo bndr) of + NoTailCallInfo -> Nothing + AlwaysTailCalled {} -> Just (bndr, rhs) | AlwaysTailCalled join_arity <- 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_bndr = bndr `asJoinId` join_arity + join_bndr = bndr `asJoinId` join_arity `setIdDmdSig` etaConvertDmdSig str_arity str_sig = Just (join_bndr, mkLams bndrs body) | otherwise = Nothing +isJoinPointBinding :: InBndr -> Bool +isJoinPointBinding bndr + | not (isId bndr) + = False + | AlwaysTailCalled {} <- tailCallInfo (idOccInfo bndr) + = True + | otherwise + = False + joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] joinPointBindings_maybe bndrs = mapM (uncurry joinPointBinding_maybe) bndrs @@ -1443,7 +1452,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr in go subst' (float:floats) body (CC args mco) go subst floats (Let (NonRec bndr rhs) expr) cont - | not (isJoinId bndr) + | not (isJoinPointBinding bndr) -- Crucial guard! See Note [Don't float join points] = let rhs' = subst_expr subst rhs (subst', bndr') = subst_bndr subst bndr View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14de70ed55de42b02074edb907cf8d60... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14de70ed55de42b02074edb907cf8d60... You're receiving this email because of your account on gitlab.haskell.org.