Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: e07ba567 by Simon Peyton Jones at 2025-07-24T17:44:04+01:00 More wibbles - - - - - 6 changed files: - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs Changes: ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -39,7 +39,7 @@ module GHC.Core.Opt.Arity -- ** Join points - , etaExpandToJoinPoint, etaExpandToJoinPointRule + , etaExpandToJoinPoint, etaExpandToJoinPointRule, mkNewJoinPointBinding -- ** Coercions and casts , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg @@ -3168,6 +3168,16 @@ more elaborate stuff, but it'd involve substitution etc. ********************************************************************* -} ------------------- +mkNewJoinPointBinding :: Id -> JoinArity -> CoreExpr -> (Id, CoreExpr) +mkNewJoinPointBinding bndr join_arity rhs + = (join_bndr, mkLams join_lam_bndrs join_body) + where + (join_lam_bndrs, join_body) = etaExpandToJoinPoint join_arity rhs + str_sig = idDmdSig bndr + str_arity = count isId join_lam_bndrs -- Strictness demands are for Ids only + join_bndr = bndr `asJoinId` join_arity + `setIdDmdSig` etaConvertDmdSig str_arity str_sig + -- | Split an expression into the given number of binders and a body, -- eta-expanding if necessary. Counts value *and* type binders. etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -38,6 +38,7 @@ Now `t` is no longer in a recursive function, and good things happen! import GHC.Prelude import GHC.Builtin.Uniques import GHC.Core +import GHC.Core.Opt.Arity( mkNewJoinPointBinding ) import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type @@ -49,7 +50,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Basic( JoinPointHood(..) ) -import GHC.Utils.Monad.State.Strict +import qualified GHC.Utils.Monad.State.Strict as S import GHC.Utils.Misc( mapSnd, count ) import GHC.Data.FastString @@ -105,7 +106,7 @@ exitifyProgram binds = map goTopLvl binds -- | State Monad used inside `exitify` -type ExitifyM = State [(JoinId, CoreExpr)] +type ExitifyM = S.State [(JoinId, CoreExpr)] -- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as -- join-points outside the joinrec. @@ -121,7 +122,7 @@ exitifyRec in_scope pairs -- Which are the recursive calls? recursive_calls = mkVarSet $ map fst pairs - (pairs',exits) = (`runState` []) $ + (pairs',exits) = (`S.runState` []) $ forM ann_pairs $ \(x,rhs) -> do -- go past the lambdas of the join point let (args, body) = collectNAnnBndrs (idJoinArity x) rhs @@ -262,28 +263,27 @@ exitifyRec in_scope pairs captures_join_points = any isJoinId abs_vars --- Picks a new unique, which is disjoint from --- * the free variables of the whole joinrec --- * any bound variables (captured) --- * any exit join points created so far. -mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId -mkExitJoinId in_scope ty join_arity = do - fs <- get - let avoid = in_scope `extendInScopeSetList` (map fst fs) - `extendInScopeSet` exit_id_tmpl -- just cosmetics - return (uniqAway avoid exit_id_tmpl) - where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty - `asJoinId` join_arity - 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_arity - fs <- get - put ((v,rhs):fs) - return v +addExit in_scope join_arity rhs + = do { fs <- S.get + ; let ty = exprType rhs + avoid = in_scope `extendInScopeSetList` (map fst fs) + `extendInScopeSet` exit_id1 -- just cosmetics + -- avoid: pick a new unique, that is disjoint from + -- * the free variables of the whole joinrec + -- * any bound variables (captured) + -- * any exit join points created so far (in `fs`) + + exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty + exit_id2 = uniqAway avoid exit_id1 + + bind_pr@(exit_id3,_) = mkNewJoinPointBinding exit_id2 join_arity rhs + -- NB: mkNewJoinPointBinding does eta-expansion if needed, + -- to make sure that the join-point binding has the + -- right number of lambdas all lined up at the top + + ; S.put (bind_pr : fs) + ; return exit_id3 } {- Note [Interesting expression] ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -742,21 +742,27 @@ Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3). Note [Finding join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~ It's the occurrence analyser's job to find bindings that we can turn into join -points, but it doesn't perform that transformation right away. Rather, it marks -the eligible bindings as part of their occurrence data, leaving it to the -simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. -The simplifier then eta-expands the RHS if needed and then updates the -occurrence sites. Dividing the work this way means that the occurrence analyser +points, but it doesn't /perform/ that transformation right away. Rather: + +* The occurrence analyser marks the eligible bindings as part of their + occurrence data. To track potential join points, we use the 'occ_tail' field of + OccInfo. A value of `AlwaysTailCalled n` indicates that every occurrence of + the variable is a tail call with `n` arguments (counting both value and type + arguments). Otherwise `occ_tail` will be 'NoTailCallInfo'. The tail call info + flows bottom-up with the rest of `OccInfo` until it goes on the binder. + +* The simplifier (or simpleOptPgm) then + * Spots join points from that AlwaysTailCalled OccInfo + * Eta-expands the RHS if needed + * Changes the binder's `IdDetails` + * Updates the occurrence sites + The first three steps are done by GHC.Core.Opt.SimpleOpt.joinPointBinding_maybe. + +Dividing the work this way means that the occurrence analyser still only takes one pass, yet one can always tell the difference between a function call and a jump by looking at the occurrence (because the same pass changes the 'IdDetails' and propagates the binders to their occurrence sites). -To track potential join points, we use the 'occ_tail' field of OccInfo. A value -of `AlwaysTailCalled n` indicates that every occurrence of the variable is a -tail call with `n` arguments (counting both value and type arguments). Otherwise -'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the -rest of 'OccInfo' until it goes on the binder. - Note [Join arity prediction based on joinRhsArity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, the join arity from tail occurrences of a join point (O) may be ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, Id import GHC.Types.Var ( isNonCoVarId, setTyVarUnfolding, tyVarOccInfo ) import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) +import GHC.Types.Demand( topSubDmd ) import GHC.Types.Tickish import GHC.Types.Basic @@ -998,12 +998,7 @@ joinPointBinding_maybe bndr rhs = 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 - `setIdDmdSig` etaConvertDmdSig str_arity str_sig - = Just (join_bndr, mkLams bndrs body) + = Just (mkNewJoinPointBinding bndr join_arity rhs) | otherwise = Nothing ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -3121,25 +3121,20 @@ mkPolyAbsLams :: (b -> AbsVar, Var -> b -> b) -- use it for both CoreExpr and LevelledExpr {-# INLINE mkPolyAbsLams #-} mkPolyAbsLams (get,set) bndrs body - = go emptyVarSet [] bndrs + = go bndrs where - go _ tv_binds [] - = mkLets (reverse tv_binds) body - go tvs tv_binds (bndr:bndrs) + go [] = body + go (bndr:bndrs) | Just ty <- tyVarUnfolding_maybe var - = go (tvs `extendVarSet` var) (NonRec bndr (Type ty) : tv_binds) bndrs + = Let (NonRec bndr (Type ty)) $ + go bndrs | otherwise - = Lam bndr' (go tvs tv_binds bndrs) + = Lam bndr' (go bndrs) where var = get bndr - var' = updateVarType (expandTyVarUnfoldings tvs) $ - zap_unfolding var - bndr' | isEmptyVarSet tvs = bndr - | otherwise = set var' bndr - -- zap: We are going to lambda-abstract, so nuke any IdInfo - zap_unfolding var | isId var = setIdInfo var vanillaIdInfo - | otherwise = var + bndr' | isId var = set (setIdInfo var vanillaIdInfo) bndr + | otherwise = bndr mkCoreAbsLams :: AbsVars -> CoreExpr -> CoreExpr -- Specialise for CoreExpr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -819,21 +819,17 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE env (Type ty) - = return (emptyFloats, Type (cpSubstTy env ty)) -cpeRhsE env (Coercion co) - = return (emptyFloats, Coercion (cpSubstCo env co)) -cpeRhsE env expr@(Lit lit) - | LitNumber LitNumBigNat i <- lit - = cpeBigNatLit env i - | otherwise = return (emptyFloats, expr) +cpeRhsE env (Type ty) = return (emptyFloats, Type (cpSubstTy env ty)) +cpeRhsE env (Coercion co) = return (emptyFloats, Coercion (cpSubstCo env co)) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env expr@(App {}) = cpeApp env expr +cpeRhsE env expr@(Lit lit) + = case lit of + LitNumber LitNumBigNat i -> cpeBigNatLit env i + _ -> return (emptyFloats, expr) + cpeRhsE env (Let bind body) - | isTypeBind bind - = cpeRhsE env body - | otherwise = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind ; (body_floats, body') <- cpeRhsE env' body ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e07ba56779070070fec3691e3aa72474... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e07ba56779070070fec3691e3aa72474... You're receiving this email because of your account on gitlab.haskell.org.