Simon Peyton Jones pushed to branch wip/T26831 at Glasgow Haskell Compiler / GHC Commits: 64a6369d by Simon Peyton Jones at 2026-03-13T14:07:37+00:00 Wibbles - - - - - 1 changed file: - compiler/GHC/CoreToStg/Prep.hs Changes: ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -143,16 +143,13 @@ Here is the syntax of the Core produced by CorePrep: Expressions body ::= app - | let(rec) x = rhs in body -- Boxed only + | let(rec) x = body in body -- Boxed only | case body of pat -> body - | /\a. body | /\c. body + | /\a. body | /\c. body | \x. body | body |> co - Right hand sides (only place where value lambdas can occur) - rhs ::= /\a.rhs | \x.rhs | body - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. +We define a synonym for each of these non-terminals, CpeArg, CpeApp, and +CpeBody. Functions with the corresponding name produce a result in that syntax. Note [Cloning in CorePrep] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -217,7 +214,6 @@ So our plan is: type CpeArg = CoreExpr -- Non-terminal 'arg' type CpeApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' {- ************************************************************************ @@ -260,7 +256,7 @@ corePrepExpr logger config expr = do withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do us <- mkSplitUniqSupply StgTag let initialCorePrepEnv = mkInitialCorePrepEnv config - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + let new_expr = initUs_ us (cpeBody initialCorePrepEnv expr) putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr @@ -657,7 +653,7 @@ cpeBind top_lvl env (Rec pairs) --------------- cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity -> CorePrepEnv -> OutId -> CoreExpr - -> UniqSM (Floats, CpeRhs) + -> UniqSM (Floats, CpeBody) -- Used for all bindings -- The binder is already cloned, hence an OutId cpePair top_lvl is_rec dmd lev env0 bndr rhs @@ -666,7 +662,7 @@ cpePair top_lvl is_rec dmd lev env0 bndr rhs -- See if we are allowed to float this stuff out of the RHS ; let dec = want_float_from_rhs floats1 rhs1 - ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1 + (floats2, rhs2) = executeFloatDecision dec floats1 rhs1 -- Make the arity match up ; (floats3, rhs3) @@ -709,7 +705,7 @@ it seems good for CorePrep to be robust. --------------- cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr - -> UniqSM (JoinId, CpeRhs) + -> UniqSM (JoinId, CpeBody) -- Used for all join bindings -- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils cpeJoinPair env bndr rhs @@ -721,7 +717,7 @@ cpeJoinPair env bndr rhs ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts + ; body' <- cpeBody env' body -- Will let-bind the body if it starts -- with a lambda ; let rhs' = mkCoreLams bndrs' body' @@ -749,10 +745,20 @@ for us to mess with the arity because a join point is never exported. -} -- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs +-- cpeRhsE: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce +-- a list of 'Floats' which are being propagated upwards. In +-- fact, this function is used in only two cases: to +-- implement 'cpeBody' (which is what you usually want), +-- and in the case when a let-binding is in a case scrutinee--here, +-- we can always float out: +-- +-- case (let x = y in z) of ... +-- ==> let x = y in case z of ... +-- -- If -- e ===> (bs, e') -- then @@ -786,7 +792,7 @@ cpeRhsE env (Tick tickish expr) -- See [Floating Ticks in CorePrep] ; return (FloatTick tickish `consFloat` floats, body) } | otherwise - = do { body <- cpeBodyNF env expr + = do { body <- cpeBody env expr ; return (emptyFloats, mkTick tickish' body) } where tickish' | Breakpoint ext bid fvs <- tickish @@ -802,7 +808,7 @@ cpeRhsE env (Cast expr co) cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body + ; body' <- cpeBody env' body ; return (emptyFloats, mkLams bndrs' body') } cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) @@ -820,7 +826,7 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) -- Note that `x` is a value here. This is visible in the GHCi debugger tests -- (such as `print003`). | Just rhs <- isUnsafeEqualityCase scrut bndr alts - = do { (floats_scrut, scrut) <- cpeBody env scrut + = do { (floats_scrut, scrut) <- cpeRhsE env scrut ; (env, bndr') <- cpCloneBndr env bndr ; (env, covar') <- cpCloneCoVarBndr env covar @@ -829,7 +835,7 @@ cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) -- Up until here this should do exactly the same as the regular code -- path of `cpeRhsE Case{}`. - ; (floats_rhs, rhs) <- cpeBody env rhs + ; (floats_rhs, rhs) <- cpeRhsE env rhs -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might -- become a value ; let case_float = UnsafeEqualityCase scrut bndr' con [covar'] @@ -864,7 +870,7 @@ cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs]) = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs cpeRhsE env (Case scrut bndr ty alts) - = do { (floats, scrut') <- cpeBody env scrut + = do { (floats, scrut') <- cpeRhsE env scrut ; (env', bndr2) <- cpCloneBndr env bndr ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding ; let alts' @@ -888,7 +894,7 @@ cpeRhsE env (Case scrut bndr ty alts) where sat_alt env (Alt con bs rhs) = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs + ; rhs' <- cpeBody env2 rhs ; return (Alt con bs' rhs') } -- --------------------------------------------------------------------------- @@ -900,76 +906,11 @@ cpeRhsE env (Case scrut bndr ty alts) -- let-bound using 'wrapBinds'). Generally you want this, esp. -- when you've reached a binding form (e.g., a lambda) and -- floating any further would be incorrect. -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce --- a list of 'Floats' which are being propagated upwards. In --- fact, this function is used in only two cases: to --- implement 'cpeBodyNF' (which is what you usually want), --- and in the case when a let-binding is in a case scrutinee--here, --- we can always float out: --- --- case (let x = y in z) of ... --- ==> let x = y in case z of ... --- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody env rhs - ; return (floats1 `appFloats` floats2, body) } - --------- -rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -{- -rhsToBody env (Tick t expr) - | tickishScoped t == NoScope -- only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody env expr - ; return (floats, mkTick t expr') } - -rhsToBody env (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody env e - ; return (floats, Cast e' co) } - -rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { let rhs = cpeEtaExpand (exprArity expr) expr - ; fn <- newVar env (exprType rhs) - ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable - ; return (unitFloat float, Var fn) } - where - (bndrs,_) = collectBinders expr --} - -rhsToBody _env expr = return (emptyFloats, expr) - - -{- Note [No eta reduction needed in rhsToBody] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Historical note. In the olden days we used to have a Prep-specific -eta-reduction step in rhsToBody: - rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - -The goal was to reduce - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } - -to avoid allocating a lambda. Of course, we'd allocate a PAP -instead, which is hardly better, but that's the way it was. + = do { (floats, body) <- cpeRhsE env expr + ; return (wrapBinds floats body) } -Now we simply don't bother with this. It doesn't seem to be a win, -and it's extra work. --} -- --------------------------------------------------------------------------- -- CpeApp: produces a result satisfying CpeApp @@ -1023,8 +964,8 @@ cpe_app filters out the tick as a underscoped tick on the expression `tagToEnum# @Bool`. During eta expansion we then put that tick back onto the body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`. -} -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs (instead of CpeApp) because of saturating primops +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +-- May return a CpeBody (instead of CpeApp) because of saturating primops cpeApp top_env expr = do { let (terminal, args) = collect_args expr -- ; pprTraceM "cpeApp" $ (ppr expr) @@ -1067,7 +1008,7 @@ cpeApp top_env expr cpe_app :: CorePrepEnv -> CoreExpr -- The thing we are calling -> [ArgInfo] - -> UniqSM (Floats, CpeRhs) + -> UniqSM (Floats, CpeBody) cpe_app env (Var f) (AIApp Type{} : AIApp arg : args) | f `hasKey` lazyIdKey -- Replace (lazy a) with a, and -- See Note [lazyId magic] in GHC.Types.Id.Make @@ -1120,7 +1061,7 @@ cpeApp top_env expr -- case thing of res { __DEFAULT -> (# token, res#) } }, -- allocating CaseBound Floats for token and thing as needed = do { (floats1, token) <- cpeArg env topDmd token - ; (floats2, thing) <- cpeBody env thing + ; (floats2, thing) <- cpeRhsE env thing ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] ; let float = mkCaseFloat case_bndr thing @@ -1134,9 +1075,10 @@ cpeApp top_env expr min_arity = case hd of Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing Nothing -> Nothing - -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity - ; mb_saturate hd app floats unsat_ticks depth } + ; case hd of + Nothing -> do { massert (null unsat_ticks); return (floats, app) } + Just fn_id -> return (floats, maybeSaturate fn_id app depth unsat_ticks) } where depth = val_args args stricts = case idDmdSig v of @@ -1163,7 +1105,8 @@ cpeApp top_env expr -- If evalDmd says that it's sure to be evaluated, -- we'll end up case-binding it ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing - ; mb_saturate Nothing app floats unsat_ticks (val_args args) } + ; massert (null unsat_ticks) + ; return (floats, app) } -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG) val_args :: [ArgInfo] -> Int @@ -1184,13 +1127,6 @@ cpeApp top_env expr | isTypeArg e = n | otherwise = n+1 - -- Saturate if necessary - mb_saturate head app floats unsat_ticks depth = - case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks - ; return (floats, sat_app) } - _other -> do { massert (null unsat_ticks) - ; return (floats, app) } -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, @@ -1526,7 +1462,7 @@ cpeArg env dmd arg ; let arg_ty = exprType arg1 lev = typeLevity arg_ty dec = wantFloatLocal NonRecursive dmd lev floats1 arg1 - ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1 + (floats2, arg2) = executeFloatDecision dec floats1 arg1 -- Else case: arg1 might have lambdas, and we can't -- put them inside a wrapBinds @@ -1583,17 +1519,17 @@ eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts) eta_would_wreck_join _ = False -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> CpeBody maybeSaturate fn expr n_args unsat_ticks | isJoinId fn -- Never eta-expand a call to a join point -- See Note [Do not eta-expand join points] - = return expr + = expr | hasNoBinding fn || (n_args > 0 && excess_arity > 0) -- n_args > 0: do not eta-expand a naked variable! -- excess_arity > 0: eta-expansion would be a no-op - = return $ wrapLamBody (mkTicks unsat_ticks) sat_expr + = wrapLamBody (mkTicks unsat_ticks) sat_expr | otherwise - = return expr + = expr {- | hasNoBinding fn -- There's no binding @@ -1672,7 +1608,7 @@ Note [Eta expansion and the CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out to be much much easier to do eta expansion *after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. +on the eta expander: given a CpeBody, it must return a CpeBody. For example here is what we do not want: f = /\a -> g (h 3) -- h has arity 2 @@ -1776,7 +1712,7 @@ There is a nasty Wrinkle: #24471 is a good example, where Prep took 25% of compile time! -} -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand :: Arity -> CpeBody -> CpeBody cpeEtaExpand arity expr | arity == 0 = expr | otherwise = etaExpand arity expr @@ -2143,9 +2079,6 @@ isEmptyFloats (Floats _ b) = isNilOL b getFloats :: Floats -> OrdList FloatingBind getFloats = fs_binds -unitFloat :: FloatingBind -> Floats -unitFloat = snocFloat emptyFloats - floatInfo :: FloatingBind -> FloatInfo floatInfo (Float _ _ info) = info floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep] @@ -2233,7 +2166,7 @@ decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, | Lifted <- lev = (LetBound, TopLvlFloatable) -- And these float freely but can't be speculated, hence LetBound -mkCaseFloat :: Id -> CpeRhs -> FloatingBind +mkCaseFloat :: Id -> CpeBody -> FloatingBind mkCaseFloat bndr scrut = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info) -- -- <+> ppr is_lifted <+> ppr is_strict @@ -2251,7 +2184,7 @@ mkCaseFloat bndr scrut -- (ok-for-spec case bindings are unlikely anyway.) } -mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id) +mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeBody -> (FloatingBind, Id) mkNonRecFloat env lev bndr rhs = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info) -- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted" @@ -2391,24 +2324,18 @@ instance Outputable FloatDecision where ppr FloatNone = text "none" ppr FloatAll = text "all" -executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs) -executeFloatDecision env dec floats rhs +executeFloatDecision :: FloatDecision -> Floats -> CpeBody -> (Floats, CpeBody) +executeFloatDecision dec floats rhs = case dec of - FloatAll -> return (floats, rhs) - FloatNone - | isEmptyFloats floats -> return (emptyFloats, rhs) - | otherwise -> do { (floats', body) <- rhsToBody env rhs - ; return (emptyFloats, wrapBinds floats $ - wrapBinds floats' body) } - -- FloatNone case: `rhs` might have lambdas, and we can't - -- put them inside a wrapBinds, which expects a `CpeBody`. + FloatAll -> (floats, rhs) + FloatNone -> (emptyFloats, wrapBinds floats rhs) wantFloatTop :: Floats -> FloatDecision wantFloatTop fs | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll | otherwise = FloatNone -wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision +wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeBody -> FloatDecision -- See Note [wantFloatLocal] wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs | isEmptyFloats floats -- Well yeah... @@ -2761,8 +2688,7 @@ wrapTicks floats expr -- --------------------------------------------------------------------------- -- | Converts Bignum literals into their final CoreExpr -cpeBigNatLit - :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) +cpeBigNatLit :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeBody) cpeBigNatLit env i = assert (i >= 0) $ do let platform = cp_platform (cpe_config env) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64a6369d9799552458ee32b3c9a8b217... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64a6369d9799552458ee32b3c9a8b217... You're receiving this email because of your account on gitlab.haskell.org.