diff options
-rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 89 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/FloatIn.hs | 102 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/OccurAnal.hs | 72 | ||||
-rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 36 | ||||
-rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs-boot | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold.hs-boot | 3 | ||||
-rw-r--r-- | compiler/GHC/Core/Unfold/Make.hs | 47 | ||||
-rw-r--r-- | compiler/GHC/Driver/Config/Core/Opt/Arity.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Types/Basic.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Types/Id/Make.hs | 6 | ||||
-rw-r--r-- | hadrian/src/Settings/Flavours/Release.hs | 2 |
13 files changed, 216 insertions, 165 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 7a2fee6d0f..7e0f7ccbae 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -81,7 +81,6 @@ import GHC.Data.FastString import GHC.Data.Graph.UnVar import GHC.Data.Pair -import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -138,13 +137,14 @@ joinRhsArity _ = 0 --------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) +exprBotStrictness_maybe :: StateHackFlag -> CoreExpr -> Maybe (Arity, DmdSig, CprSig) -- A cheap and cheerful function that identifies bottoming functions -- and gives them a suitable strictness and CPR signatures. -- It's used during float-out -exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e) +exprBotStrictness_maybe st_hack e = + arityTypeBotSigs_maybe (cheapArityType st_hack e) -arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) +arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) -- Arity of a divergent function arityTypeBotSigs_maybe (AT lams div) | isDeadEndDiv div = Just ( arity @@ -203,11 +203,12 @@ typeArity ty0 = | otherwise = acc -typeOneShots :: Type -> [OneShotInfo] + +typeOneShots :: StateHackFlag -> Type -> [OneShotInfo] -- How many value arrows are visible in the type? -- We look through foralls, and newtypes -- See Note [Arity invariants for bindings] -typeOneShots ty +typeOneShots st_hack ty = go initRecTc ty where go rec_nts ty @@ -215,7 +216,7 @@ typeOneShots ty = go rec_nts ty' | Just (_,_,arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res + = typeOneShot st_hack arg : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys @@ -235,17 +236,17 @@ typeOneShots ty | otherwise = [] -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = OneShotLam - | otherwise = NoOneShotInfo +typeOneShot :: StateHackFlag -> Type -> OneShotInfo +typeOneShot st_hack ty + | isStateHackType st_hack ty = OneShotLam + | otherwise = NoOneShotInfo -- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = OneShotLam - | otherwise = idOneShotInfo id +idStateHackOneShotInfo :: StateHackFlag -> Id -> OneShotInfo +idStateHackOneShotInfo st_hack id + | isStateHackType st_hack (idType id) = OneShotLam + | otherwise = idOneShotInfo id -- | Returns whether the lambda associated with the 'Id' is -- certainly applied at most once @@ -253,15 +254,15 @@ idStateHackOneShotInfo id -- It works on type variables as well as Ids, returning True -- Its main purpose is to encapsulate the Horrible State Hack -- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - -isStateHackType :: Type -> Bool -isStateHackType ty - | unsafeHasNoStateHack -- Switch off with -fno-state-hack +isOneShotBndr :: StateHackFlag -> Var -> Bool +isOneShotBndr st_hack var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo st_hack var = True + | otherwise = False + +isStateHackType :: StateHackFlag -> Type -> Bool +isStateHackType st_hack ty + | not (stateHackEnabled st_hack) -- Switch off with -fno-state-hack = False | otherwise = case tyConAppTyCon_maybe ty of @@ -419,17 +420,17 @@ The test simplCore/should_compile/T3722 is an excellent example. * * ********************************************************************* -} -zapLamBndrs :: FullArgCount -> [Var] -> [Var] +zapLamBndrs :: StateHackFlag -> FullArgCount -> [Var] -> [Var] -- If (\xyz. t) appears under-applied to only two arguments, -- we must zap the occ-info on x,y, because they appear (in 't') under the \z. -- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal -- -- NB: both `arg_count` and `bndrs` include both type and value args/bndrs -zapLamBndrs arg_count bndrs +zapLamBndrs st_hack arg_count bndrs | no_need_to_zap = bndrs | otherwise = zap_em arg_count bndrs where - no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) + no_need_to_zap = all (isOneShotBndr st_hack) (drop arg_count bndrs) zap_em :: FullArgCount -> [Var] -> [Var] zap_em 0 bs = bs @@ -864,6 +865,7 @@ trimArityType max_arity at@(AT lams _) data ArityOpts = ArityOpts { ao_ped_bot :: !Bool -- See Note [Dealing with bottom] , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries] + , ao_state_hack :: !StateHackFlag } -- | The Arity returned is the number of value args the @@ -917,6 +919,8 @@ findRhsArity opts is_rec bndr rhs init_env :: ArityEnv init_env = findRhsArityEnv opts (isJoinId bndr) + st_hack = ao_state_hack opts + -- Non-join-points only non_join_arity_type = case is_rec of Recursive -> go 0 botArityType @@ -928,7 +932,7 @@ findRhsArity opts is_rec bndr rhs -- and Note [Arity for recursive join bindings] join_arity_type = case is_rec of Recursive -> go 0 botArityType - NonRecursive -> trimArityType ty_arity (cheapArityType rhs) + NonRecursive -> trimArityType ty_arity (cheapArityType st_hack rhs) ty_arity = typeArity (idType bndr) id_one_shots = idDemandOneShots bndr @@ -1235,12 +1239,12 @@ in the main arityType function.) * * ********************************************************************* -} -arityLam :: Id -> ArityType -> ArityType -arityLam id (AT oss div) +arityLam :: StateHackFlag -> Id -> ArityType -> ArityType +arityLam st_hack id (AT oss div) = AT ((IsCheap, one_shot) : oss) div where one_shot | isDeadEndDiv div = OneShotLam - | otherwise = idStateHackOneShotInfo id + | otherwise = idStateHackOneShotInfo st_hack id -- If the body diverges, treat it as one-shot: no point -- in floating out, and no penalty for floating in -- See Wrinkle [Bottoming functions] in Note [ArityType] @@ -1513,17 +1517,18 @@ arityType env (Var v) = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $ -- All join-point should be in the ae_sigs -- See Note [No free join points in arityType] - idArityType v + idArityType (ao_state_hack $ am_opts env) v arityType env (Cast e _) = arityType env e -- Lambdas; increase arity arityType env (Lam x e) - | isId x = arityLam x (arityType env' e) + | isId x = arityLam st_hack x (arityType env' e) | otherwise = arityType env' e where env' = delInScope env x + st_hack = ao_state_hack (am_opts env) -- Applications; decrease arity, except for types arityType env (App fun (Type _)) @@ -1573,9 +1578,10 @@ arityType env (Let (Rec prs) e) where bind_cost (b,e) = exprCost env' e (Just (idType b)) env' = foldl extend_rec env prs + st_hack = ao_state_hack (am_opts env) extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv extend_rec env (b,_) = extendSigEnv env b $ - idArityType b + idArityType st_hack b -- See Note [arityType for recursive let-bindings] arityType env (Tick t e) @@ -1584,8 +1590,8 @@ arityType env (Tick t e) arityType _ _ = topArityType -------------------- -idArityType :: Id -> ArityType -idArityType v +idArityType :: StateHackFlag -> Id -> ArityType +idArityType st_hack v | strict_sig <- idDmdSig v , (ds, div) <- splitDmdSig strict_sig , isDeadEndDiv div @@ -1600,10 +1606,11 @@ idArityType v id_ty = idType v one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type - one_shots = repeat IsCheap `zip` typeOneShots id_ty + one_shots = repeat IsCheap `zip` typeOneShots st_hack id_ty -------------------- -cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType +cheapArityType :: HasDebugCallStack + => StateHackFlag -> CoreExpr -> ArityType -- A fast and cheap version of arityType. -- Returns an ArityType with IsCheap everywhere -- c.f. GHC.Core.Utils.exprIsDeadEnd @@ -1614,11 +1621,11 @@ cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType -- -- Returns ArityType, not SafeArityType. The caller must do -- trimArityType if necessary. -cheapArityType e = go e +cheapArityType st_hack e = go e where - go (Var v) = idArityType v + go (Var v) = idArityType st_hack v go (Cast e _) = go e - go (Lam x e) | isId x = arityLam x (go e) + go (Lam x e) | isId x = arityLam st_hack x (go e) | otherwise = go e go (App e a) | isTypeArg a = go e | otherwise = arity_app a (go e) diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index cf3ca726e4..ab664822d8 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -28,7 +28,7 @@ import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type -import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) ) +import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted), StateHackFlag ) import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var @@ -43,13 +43,13 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. -} -floatInwards :: Platform -> CoreProgram -> CoreProgram -floatInwards platform binds = map (fi_top_bind platform) binds +floatInwards :: Platform -> StateHackFlag -> CoreProgram -> CoreProgram +floatInwards platform st_hack binds = map (fi_top_bind platform) binds where fi_top_bind platform (NonRec binder rhs) - = NonRec binder (fiExpr platform [] (freeVars rhs)) + = NonRec binder (fiExpr platform st_hack [] (freeVars rhs)) fi_top_bind platform (Rec pairs) - = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ] + = Rec [ (b, fiExpr platform st_hack [] (freeVars rhs)) | (b, rhs) <- pairs ] {- @@ -136,19 +136,20 @@ type FloatInBinds = [FloatInBind] -- In reverse dependency order (innermost binder first) fiExpr :: Platform + -> StateHackFlag -> FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result -fiExpr _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) +fiExpr _ _ to_drop (_, AnnLit lit) = wrapFloats to_drop (Lit lit) -- See Note [Dead bindings] -fiExpr _ to_drop (_, AnnType ty) = assert (null to_drop) $ Type ty -fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) -fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) -fiExpr platform to_drop (_, AnnCast expr (co_ann, co)) +fiExpr _ _ to_drop (_, AnnType ty) = assert (null to_drop) $ Type ty +fiExpr _ _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) +fiExpr _ _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) +fiExpr platform st_hack to_drop (_, AnnCast expr (co_ann, co)) = wrapFloats (drop_here ++ co_drop) $ - Cast (fiExpr platform e_drop expr) co + Cast (fiExpr platform st_hack e_drop expr) co where [drop_here, e_drop, co_drop] = sepBindsByDropPoint platform False @@ -161,11 +162,11 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. -} -fiExpr platform to_drop ann_expr@(_,AnnApp {}) +fiExpr platform st_hack to_drop ann_expr@(_,AnnApp {}) = wrapFloats drop_here $ wrapFloats extra_drop $ mkTicks ticks $ - mkApps (fiExpr platform fun_drop ann_fun) - (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args) + mkApps (fiExpr platform st_hack fun_drop ann_fun) + (zipWithEqual "fiExpr" (fiExpr platform st_hack) arg_drops ann_args) -- use zipWithEqual, we should have -- length ann_args = length arg_fvs = length arg_drops where @@ -196,7 +197,7 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {}) add_arg (fun_ty, extra_fvs) (_, AnnType ty) = (piResultTy fun_ty ty, extra_fvs) add_arg (fun_ty, extra_fvs) (arg_fvs, arg) - | noFloatIntoArg arg + | noFloatIntoArg st_hack arg = (funResultTy fun_ty, extra_fvs `unionDVarSet` arg_fvs) | otherwise = (funResultTy fun_ty, extra_fvs) @@ -294,13 +295,13 @@ be dropped right away. -} -fiExpr platform to_drop lam@(_, AnnLam _ _) - | noFloatIntoLam bndrs -- Dump it all here +fiExpr platform st_hack to_drop lam@(_, AnnLam _ _) + | noFloatIntoLam st_hack bndrs -- Dump it all here -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088 - = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) + = wrapFloats to_drop (mkLams bndrs (fiExpr platform st_hack [] body)) | otherwise -- Float inside - = mkLams bndrs (fiExpr platform to_drop body) + = mkLams bndrs (fiExpr platform st_hack to_drop body) where (bndrs, body) = collectAnnBndrs lam @@ -312,12 +313,12 @@ We don't float lets inwards past an SCC. cc, change current cc to the new one and float binds into expr. -} -fiExpr platform to_drop (_, AnnTick tickish expr) +fiExpr platform st_hack to_drop (_, AnnTick tickish expr) | tickish `tickishScopesLike` SoftScope - = Tick tickish (fiExpr platform to_drop expr) + = Tick tickish (fiExpr platform st_hack to_drop expr) | otherwise -- Wimp out for now - we could push values in - = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr)) + = wrapFloats to_drop (Tick tickish (fiExpr platform st_hack [] expr)) {- For @Lets@, the possible ``drop points'' for the \tr{to_drop} @@ -370,11 +371,11 @@ idRuleAndUnfoldingVars of x. No need for type variables, hence not using idFreeVars. -} -fiExpr platform to_drop (_,AnnLet bind body) - = fiExpr platform (after ++ new_float : before) body +fiExpr platform st_hack to_drop (_,AnnLet bind body) + = fiExpr platform st_hack (after ++ new_float : before) body -- to_drop is in reverse dependency order where - (before, new_float, after) = fiBind platform to_drop bind body_fvs + (before, new_float, after) = fiBind platform st_hack to_drop bind body_fvs body_fvs = freeVarsOf body {- Note [Floating primops] @@ -435,17 +436,17 @@ bindings are: -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) +fiExpr platform st_hack to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) | isUnliftedType (idType case_bndr) -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType , exprOkForSideEffects (deAnnotate scrut) -- See Note [Floating primops] = wrapFloats shared_binds $ - fiExpr platform (case_float : rhs_binds) rhs + fiExpr platform st_hack (case_float : rhs_binds) rhs where case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) - scrut' = fiExpr platform scrut_binds scrut + scrut' = fiExpr platform st_hack scrut_binds scrut rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs) scrut_fvs = freeVarsOf scrut @@ -454,10 +455,10 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs] [scrut_fvs, rhs_fvs] to_drop -fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) +fiExpr platform st_hack to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $ wrapFloats drop_here2 $ - Case (fiExpr platform scrut_drops scrut) case_bndr ty + Case (fiExpr platform st_hack scrut_drops scrut) case_bndr ty (zipWithEqual "fiExpr" fi_alt alts_drops_s alts) -- use zipWithEqual, we should have length alts_drops_s = length alts where @@ -480,10 +481,11 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt - fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) + fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform st_hack to_drop rhs) ------------------ fiBind :: Platform + -> StateHackFlag -> FloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreBindWithFVs -- Input binding @@ -492,7 +494,7 @@ fiBind :: Platform , FloatInBind -- The binding itself , FloatInBinds) -- Land these after -fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs +fiBind platform st_hack to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs = ( extra_binds ++ shared_binds -- Land these before -- See Note [extra_fvs (1)] and Note [extra_fvs (2)] , FB (unitDVarSet id) rhs_fvs' -- The new binding itself @@ -503,7 +505,7 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs body_fvs2 = body_fvs `delDVarSet` id rule_fvs = bndrRuleAndUnfoldingVarsDSet id -- See Note [extra_fvs (2)] - extra_fvs | noFloatIntoRhs NonRecursive id rhs + extra_fvs | noFloatIntoRhs st_hack NonRecursive id rhs = rule_fvs `unionDVarSet` rhs_fvs | otherwise = rule_fvs @@ -518,11 +520,11 @@ fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs to_drop -- Push rhs_binds into the right hand side of the binding - rhs' = fiRhs platform rhs_binds id ann_rhs + rhs' = fiRhs platform st_hack rhs_binds id ann_rhs rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs -- Don't forget the rule_fvs; the binding mentions them! -fiBind platform to_drop (AnnRec bindings) body_fvs +fiBind platform st_hack to_drop (AnnRec bindings) body_fvs = ( extra_binds ++ shared_binds , FB (mkDVarSet ids) rhs_fvs' (FloatLet (Rec (fi_bind rhss_binds bindings))) @@ -535,7 +537,7 @@ fiBind platform to_drop (AnnRec bindings) body_fvs rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids extra_fvs = rule_fvs `unionDVarSet` unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings - , noFloatIntoRhs Recursive bndr rhs ] + , noFloatIntoRhs st_hack Recursive bndr rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) = sepBindsByDropPoint platform False @@ -552,28 +554,28 @@ fiBind platform to_drop (AnnRec bindings) body_fvs -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiRhs platform to_drop binder rhs) + = [ (binder, fiRhs platform st_hack to_drop binder rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] ------------------ -fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr -fiRhs platform to_drop bndr rhs +fiRhs :: Platform -> StateHackFlag -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr +fiRhs platform st_hack to_drop bndr rhs | Just join_arity <- isJoinId_maybe bndr , let (bndrs, body) = collectNAnnBndrs join_arity rhs - = mkLams bndrs (fiExpr platform to_drop body) + = mkLams bndrs (fiExpr platform st_hack to_drop body) | otherwise - = fiExpr platform to_drop rhs + = fiExpr platform st_hack to_drop rhs ------------------ -noFloatIntoLam :: [Var] -> Bool -noFloatIntoLam bndrs = any bad bndrs +noFloatIntoLam :: StateHackFlag -> [Var] -> Bool +noFloatIntoLam st_hack bndrs = any bad bndrs where - bad b = isId b && not (isOneShotBndr b) + bad b = isId b && not (isOneShotBndr st_hack b) -- Don't float inside a non-one-shot lambda -noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool +noFloatIntoRhs :: StateHackFlag -> RecFlag -> Id -> CoreExprWithFVs' -> Bool -- ^ True if it's a bad idea to float bindings into this RHS -noFloatIntoRhs is_rec bndr rhs +noFloatIntoRhs st_hack is_rec bndr rhs | isJoinId bndr = isRec is_rec -- Joins are one-shot iff non-recursive @@ -581,13 +583,13 @@ noFloatIntoRhs is_rec bndr rhs = True -- Preserve let-can-float invariant, see Note [noFloatInto considerations] | otherwise - = noFloatIntoArg rhs + = noFloatIntoArg st_hack rhs -noFloatIntoArg :: CoreExprWithFVs' -> Bool -noFloatIntoArg expr +noFloatIntoArg :: StateHackFlag -> CoreExprWithFVs' -> Bool +noFloatIntoArg st_hack expr | AnnLam bndr e <- expr , (bndrs, _) <- collectAnnBndrs e - = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) + = noFloatIntoLam st_hack (bndr:bndrs) -- Wrinkle 1 (a) || all isTyVar (bndr:bndrs) -- Wrinkle 1 (b) -- See Note [noFloatInto considerations] wrinkle 2 diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 0c6f4d5413..841aa94883 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -73,17 +73,18 @@ Here's the externally-callable interface: -} -- | Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr :: CoreExpr -> CoreExpr -occurAnalyseExpr expr = expr' +occurAnalyseExpr :: StateHackFlag -> CoreExpr -> CoreExpr +occurAnalyseExpr st_hack expr = expr' where - (WithUsageDetails _ expr') = occAnal initOccEnv expr + (WithUsageDetails _ expr') = occAnal (initOccEnv st_hack) expr -occurAnalysePgm :: Module -- Used only in debug output +occurAnalysePgm :: StateHackFlag + -> Module -- Used only in debug output -> (Id -> Bool) -- Active unfoldings -> (Activation -> Bool) -- Active rules -> [CoreRule] -- Local rules for imported Ids -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds +occurAnalysePgm st_hack this_mod active_unf active_rule imp_rules binds | isEmptyDetails final_usage = occ_anald_binds @@ -91,8 +92,8 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage)) occ_anald_glommed_binds where - init_env = initOccEnv { occ_rule_act = active_rule - , occ_unf_act = active_unf } + init_env = (initOccEnv st_hack) { occ_rule_act = active_rule + , occ_unf_act = active_unf } (WithUsageDetails final_usage occ_anald_binds) = go init_env binds (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel @@ -840,8 +841,9 @@ occAnalRec :: OccEnv -> TopLevelFlag -> WithUsageDetails [CoreBind] -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs - , nd_uds = rhs_uds })) +occAnalRec !env lvl + (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs + , nd_uds = rhs_uds })) (WithUsageDetails body_uds binds) | not (bndr `usedIn` body_uds) = WithUsageDetails body_uds binds -- See Note [Dead code] @@ -851,8 +853,9 @@ occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs (NonRec tagged_bndr rhs : binds) where (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr - rhs_uds' = adjustRhsUsage mb_join_arity rhs rhs_uds + rhs_uds' = adjustRhsUsage st_hack mb_join_arity rhs rhs_uds mb_join_arity = willBeJoinId_maybe tagged_bndr + st_hack = occ_state_hack env -- The Rec case is the interesting one -- See Note [Recursive bindings: the grand plan] @@ -1477,7 +1480,7 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag mkLoopBreakerNodes !env lvl body_uds details_s = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs') where - (final_uds, bndrs') = tagRecBinders lvl body_uds details_s + (final_uds, bndrs') = tagRecBinders (occ_state_hack env) lvl body_uds details_s mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr = DigraphNode { node_payload = new_nd @@ -1772,20 +1775,22 @@ recognises except that the latter looks through (some) ticks. Maybe a lambda group should also look through (some) ticks? -} -isOneShotFun :: CoreExpr -> Bool +isOneShotFun :: StateHackFlag -> CoreExpr -> Bool -- The top level lambdas, ignoring casts, of the expression -- are all one-shot. If there aren't any lambdas at all, this is True -isOneShotFun (Lam b e) = isOneShotBndr b && isOneShotFun e -isOneShotFun (Cast e _) = isOneShotFun e -isOneShotFun _ = True +isOneShotFun st_hack = go + where + go (Lam b e) = isOneShotBndr st_hack b && go e + go (Cast e _) = go e + go _ = True -zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr +zapLambdaBndrs :: StateHackFlag -> CoreExpr -> FullArgCount -> CoreExpr -- If (\xyz. t) appears under-applied to only two arguments, -- we must zap the occ-info on x,y, because they appear under the \z -- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal -- -- NB: `arg_count` includes both type and value args -zapLambdaBndrs fun arg_count +zapLambdaBndrs st_hack fun arg_count = -- If the lambda is fully applied, leave it alone; if not -- zap the OccInfo on the lambdas that do have arguments, -- so they beta-reduce to use-many Lets rather than used-once ones. @@ -1794,8 +1799,8 @@ zapLambdaBndrs fun arg_count zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr -- Nothing => No need to change the occ-info -- Just e => Had to change - zap 0 e | isOneShotFun e = Nothing -- All remaining lambdas are one-shot - | otherwise = Just e -- in which case no need to zap + zap 0 e | isOneShotFun st_hack e = Nothing -- All remaining lambdas are one-shot + | otherwise = Just e -- in which case no need to zap zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) } zap n (Lam b e) = do { e' <- zap (n-1) e ; return (Lam (zap_bndr b) e') } @@ -1904,7 +1909,8 @@ occAnalRhs !env is_rec mb_join_arity rhs -- do the markAllInsideLam and markNonTailCall stuff before -- we've had a chance to help with join points; that comes next rhs2 = markJoinOneShots is_rec mb_join_arity rhs1 - rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage + rhs_usage = adjustRhsUsage st_hack mb_join_arity rhs2 usage + st_hack = occ_state_hack env in WithUsageDetails rhs_usage rhs2 @@ -2209,8 +2215,9 @@ occAnal env app@(App _ _) occAnal env expr@(Lam {}) = let (WithUsageDetails usage expr') = occAnalLam env expr - final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $ + final_usage = markAllInsideLamIf (not (isOneShotFun st_hack expr')) $ markAllNonTail usage + st_hack = occ_state_hack env in WithUsageDetails final_usage expr' occAnal env (Case scrut bndr ty alts) @@ -2470,6 +2477,7 @@ data OccEnv , occ_bs_rng :: !VarSet -- Vars free in the range of occ_bs_env -- Domain is Global and Local Ids -- Range is just Local Ids + , occ_state_hack :: !StateHackFlag } @@ -2502,8 +2510,8 @@ instance Outputable OccEncl where -- See Note [OneShots] type OneShots = [OneShotInfo] -initOccEnv :: OccEnv -initOccEnv +initOccEnv :: StateHackFlag -> OccEnv +initOccEnv st_hack = OccEnv { occ_encl = OccVanilla , occ_one_shots = [] @@ -2513,7 +2521,9 @@ initOccEnv , occ_rule_act = \_ -> True , occ_bs_env = emptyVarEnv - , occ_bs_rng = emptyVarSet } + , occ_bs_rng = emptyVarSet + , occ_state_hack = st_hack + } noBinderSwaps :: OccEnv -> Bool noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env @@ -3132,17 +3142,18 @@ flattenUsageDetails ud@(UD { ud_env = env }) ------------------- -- See Note [Adjusting right-hand sides] -adjustRhsUsage :: Maybe JoinArity +adjustRhsUsage :: StateHackFlag + -> Maybe JoinArity -> CoreExpr -- Rhs, AFTER occ anal -> UsageDetails -- From body of lambda -> UsageDetails -adjustRhsUsage mb_join_arity rhs usage +adjustRhsUsage st_hack mb_join_arity rhs usage = -- c.f. occAnal (Lam {}) markAllInsideLamIf (not one_shot) $ markAllNonTailIf (not exact_join) $ usage where - one_shot = isOneShotFun rhs + one_shot = isOneShotFun st_hack rhs exact_join = exactJoin mb_join_arity bndrs (bndrs,_) = collectBinders rhs @@ -3200,7 +3211,8 @@ tagNonRecBinder lvl usage binder in usage' `seq` (usage', binder') -tagRecBinders :: TopLevelFlag -- At top level? +tagRecBinders :: StateHackFlag + -> TopLevelFlag -- At top level? -> UsageDetails -- Of body of let ONLY -> [Details] -> (UsageDetails, -- Adjusted details for whole scope, @@ -3208,7 +3220,7 @@ tagRecBinders :: TopLevelFlag -- At top level? [IdWithOccInfo]) -- Tagged binders -- Substantially more complicated than non-recursive case. Need to adjust RHS -- details *before* tagging binders (because the tags depend on the RHSes). -tagRecBinders lvl body_uds details_s +tagRecBinders st_hack lvl body_uds details_s = let bndrs = map nd_bndr details_s rhs_udss = map nd_uds details_s @@ -3224,7 +3236,7 @@ tagRecBinders lvl body_uds details_s -- 2. Adjust usage details of each RHS, taking into account the -- join-point-hood decision - rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds + rhs_udss' = [ adjustRhsUsage st_hack (mb_join_arity bndr) rhs rhs_uds | ND { nd_bndr = bndr, nd_uds = rhs_uds , nd_rhs = rhs } <- details_s ] diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 5638762e08..1dca48e126 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -92,14 +92,16 @@ data SimpleOpts = SimpleOpts { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options , so_eta_red :: !Bool -- ^ Eta reduction on? + , so_st_hack :: !StateHackFlag -- ^ State hack on? } -- | Default options for the Simple optimiser. -defaultSimpleOpts :: SimpleOpts -defaultSimpleOpts = SimpleOpts - { so_uf_opts = defaultUnfoldingOpts +defaultSimpleOpts :: StateHackFlag -> SimpleOpts +defaultSimpleOpts st_hack = SimpleOpts + { so_uf_opts = defaultUnfoldingOpts st_hack , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } , so_eta_red = False + , so_st_hack = st_hack } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -145,9 +147,10 @@ simpleOptExpr opts expr simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith opts subst expr - = simple_opt_expr init_env (occurAnalyseExpr expr) + = simple_opt_expr init_env (occurAnalyseExpr st_hack expr) where init_env = (emptyEnv opts) { soe_subst = subst } + st_hack = so_st_hack opts ---------------------- simpleOptPgm :: SimpleOpts @@ -159,7 +162,7 @@ simpleOptPgm :: SimpleOpts simpleOptPgm opts this_mod binds rules = (reverse binds', rules', occ_anald_binds) where - occ_anald_binds = occurAnalysePgm this_mod + occ_anald_binds = occurAnalysePgm (so_st_hack opts) this_mod (\_ -> True) {- All unfoldings active -} (\_ -> False) {- No rules active -} rules binds @@ -348,7 +351,7 @@ simple_app env (App e1 e2) as = simple_app env e1 ((env, e2) : as) simple_app env e@(Lam {}) as@(_:_) - = do_beta env (zapLambdaBndrs e n_args) as + = do_beta env (zapLambdaBndrs st_hack e n_args) as -- Be careful to zap the lambda binders if necessary -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify -- Lacking this zap caused #19347, when we had a redex @@ -356,6 +359,7 @@ simple_app env e@(Lam {}) as@(_:_) -- where (as it happens) the eta-expanded K is produced by -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head where + st_hack = so_st_hack (soe_opts env) n_args = length as do_beta env (Lam b body) (a:as) @@ -1421,23 +1425,23 @@ Currently, it is used in GHC.Core.Rules.match, and is required to make -} exprIsLambda_maybe :: HasDebugCallStack - => InScopeEnv -> CoreExpr + => StateHackFlag -> InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr,[CoreTickish]) -- See Note [exprIsLambda_maybe] -- The simple case: It is a lambda already -exprIsLambda_maybe _ (Lam x e) +exprIsLambda_maybe _ _ (Lam x e) = Just (x, e, []) -- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) +exprIsLambda_maybe st_hack (in_scope_set, id_unf) (Tick t e) | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + , Just (x, e, ts) <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) e = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e +exprIsLambda_maybe st_hack (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) @@ -1448,19 +1452,19 @@ exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) res -- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e +exprIsLambda_maybe st_hack (in_scope_set, id_unf) e | (Var f, as, ts) <- collectArgsTicks tickishFloatable e , idArity f > count isValArg as -- Make sure there is hope to get a lambda , Just rhs <- expandUnfolding_maybe (id_unf f) -- Optimize, for beta-reduction - , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as) + , let e' = simpleOptExprWith (defaultSimpleOpts st_hack) (mkEmptySubst in_scope_set) (rhs `mkApps` as) -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , Just (x', e'', ts') <- exprIsLambda_maybe st_hack (in_scope_set, id_unf) e' , let res = Just (x', e'', ts++ts') = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) res -exprIsLambda_maybe _ _e +exprIsLambda_maybe _ _ _e = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) Nothing diff --git a/compiler/GHC/Core/SimpleOpt.hs-boot b/compiler/GHC/Core/SimpleOpt.hs-boot index 4a63105475..0a37a2077f 100644 --- a/compiler/GHC/Core/SimpleOpt.hs-boot +++ b/compiler/GHC/Core/SimpleOpt.hs-boot @@ -3,9 +3,11 @@ module GHC.Core.SimpleOpt where import GHC.Core import {-# SOURCE #-} GHC.Core.Unfold import GHC.Utils.Misc (HasDebugCallStack) +import GHC.Types.Basic (StateHackFlag) data SimpleOpts so_uf_opts :: SimpleOpts -> UnfoldingOpts +so_st_hack :: SimpleOpts -> StateHackFlag simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 56f8251e3d..3260e83e87 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -55,6 +55,7 @@ import GHC.Data.Bag import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Types.Basic ( StateHackFlag ) import GHC.Types.ForeignCall import GHC.Types.Name import GHC.Types.Tickish @@ -88,10 +89,12 @@ data UnfoldingOpts = UnfoldingOpts , unfoldingReportPrefix :: !(Maybe String) -- ^ Only report inlining decisions for names with this prefix + + , unfoldingStateHack :: !StateHackFlag } -defaultUnfoldingOpts :: UnfoldingOpts -defaultUnfoldingOpts = UnfoldingOpts +defaultUnfoldingOpts :: StateHackFlag -> UnfoldingOpts +defaultUnfoldingOpts st_hack = UnfoldingOpts { unfoldingCreationThreshold = 750 -- The unfoldingCreationThreshold threshold must be reasonably high -- to take account of possible discounts. @@ -122,6 +125,8 @@ defaultUnfoldingOpts = UnfoldingOpts -- Don't filter inlining decision reports , unfoldingReportPrefix = Nothing + + , unfoldingStateHack = st_hack } -- Helpers for "GHC.Driver.Session" diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot index c62f1915c9..86bf2d5e11 100644 --- a/compiler/GHC/Core/Unfold.hs-boot +++ b/compiler/GHC/Core/Unfold.hs-boot @@ -1,10 +1,11 @@ module GHC.Core.Unfold where import GHC.Prelude +import GHC.Types.Basic ( StateHackFlag ) data UnfoldingOpts -defaultUnfoldingOpts :: UnfoldingOpts +defaultUnfoldingOpts :: StateHackFlag -> UnfoldingOpts updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index adbbdec763..88cdba0f36 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -51,12 +51,13 @@ mkFinalUnfolding opts src strict_sig expr -- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding -mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) +mkCompulsoryUnfolding' opts expr + = mkCompulsoryUnfolding (simpleOptExpr opts expr) -- | Used for things that absolutely must be unfolded mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr - = mkCoreUnfolding CompulsorySrc True + = mkCoreUnfolding (StateHackFlag True) CompulsorySrc True expr (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) @@ -71,17 +72,17 @@ mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs = mkUnfolding opts VanillaSrc False False rhs -mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding -mkDFunUnfolding bndrs con ops +mkDFunUnfolding :: StateHackFlag -> [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding st_hack bndrs con ops = DFunUnfolding { df_bndrs = bndrs , df_con = con - , df_args = map occurAnalyseExpr ops } + , df_args = map (occurAnalyseExpr st_hack) ops } -- See Note [Occurrence analysis of unfoldings] -mkDataConUnfolding :: CoreExpr -> Unfolding +mkDataConUnfolding :: StateHackFlag -> CoreExpr -> Unfolding -- Used for non-newtype data constructors with non-trivial wrappers -mkDataConUnfolding expr - = mkCoreUnfolding StableSystemSrc True expr guide +mkDataConUnfolding st_hack expr + = mkCoreUnfolding st_hack StableSystemSrc True expr guide -- No need to simplify the expression where guide = UnfWhen { ug_arity = manifestArity expr @@ -92,11 +93,13 @@ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split -- after demand/CPR analysis mkWrapperUnfolding opts expr arity - = mkCoreUnfolding StableSystemSrc True + = mkCoreUnfolding st_hack StableSystemSrc True (simpleOptExpr opts expr) (UnfWhen { ug_arity = arity , ug_unsat_ok = unSaturatedOk , ug_boring_ok = boringCxtNotOk }) + where + st_hack = so_st_hack opts mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding -- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap @@ -104,10 +107,11 @@ mkWorkerUnfolding opts work_fn (CoreUnfolding { uf_src = src, uf_tmpl = tmpl , uf_is_top = top_lvl }) | isStableSource src - = mkCoreUnfolding src top_lvl new_tmpl guidance + = mkCoreUnfolding st_hack src top_lvl new_tmpl guidance where new_tmpl = simpleOptExpr opts (work_fn tmpl) guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl + st_hack = so_st_hack opts mkWorkerUnfolding _ _ _ = noUnfolding @@ -117,7 +121,7 @@ mkWorkerUnfolding _ _ _ = noUnfolding -- resolve before doing any work). mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding mkInlineUnfoldingNoArity opts src expr - = mkCoreUnfolding src + = mkCoreUnfolding st_hack src True -- Note [Top-level flag on inline rules] expr' guide where @@ -126,12 +130,13 @@ mkInlineUnfoldingNoArity opts src expr , ug_unsat_ok = unSaturatedOk , ug_boring_ok = boring_ok } boring_ok = inlineBoringOk expr' + st_hack = so_st_hack opts -- | Make an INLINE unfolding that will be used once the RHS has been saturated -- to the given arity. mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding mkInlineUnfoldingWithArity opts src arity expr - = mkCoreUnfolding src + = mkCoreUnfolding st_hack src True -- Note [Top-level flag on inline rules] expr' guide where @@ -143,6 +148,7 @@ mkInlineUnfoldingWithArity opts src arity expr -- at the arity here. boring_ok | arity == 0 = True | otherwise = inlineBoringOk expr' + st_hack = so_st_hack opts mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding mkInlinableUnfolding opts src expr @@ -163,7 +169,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args = assertPpr (rule_lhs_args `equalLength` old_bndrs) (ppr df $$ ppr rule_lhs_args) $ -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise - mkDFunUnfolding spec_bndrs con (map spec_arg args) + mkDFunUnfolding (so_st_hack opts) spec_bndrs con (map spec_arg args) -- For DFunUnfoldings we transform -- \obs. MkD <op1> ... <opn> -- to @@ -180,7 +186,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args , uf_guidance = old_guidance }) | isStableSource src -- See Note [Specialising unfoldings] , UnfWhen { ug_arity = old_arity } <- old_guidance - = mkCoreUnfolding src top_lvl new_tmpl + = mkCoreUnfolding st_hack src top_lvl new_tmpl (old_guidance { ug_arity = old_arity - arity_decrease }) where new_tmpl = simpleOptExpr opts $ @@ -188,6 +194,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args spec_app tmpl -- The beta-redexes created by spec_app -- will be simplified away by simplOptExpr arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs + st_hack = so_st_hack opts specUnfolding _ _ _ _ _ = noUnfolding @@ -314,22 +321,23 @@ mkUnfolding :: UnfoldingOpts -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it mkUnfolding opts src top_lvl is_bottoming expr - = mkCoreUnfolding src top_lvl expr guidance + = mkCoreUnfolding st_hack src top_lvl expr guidance where is_top_bottoming = top_lvl && is_bottoming guidance = calcUnfoldingGuidance opts is_top_bottoming expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + st_hack = unfoldingStateHack opts -mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr +mkCoreUnfolding :: StateHackFlag -> UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it -mkCoreUnfolding src top_lvl expr guidance +mkCoreUnfolding st_hack src top_lvl expr guidance = CoreUnfolding { uf_tmpl = is_value `seq` is_conlike `seq` is_work_free `seq` is_expandable `seq` - occurAnalyseExpr expr + occurAnalyseExpr st_hack expr -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings] -- See #20905 for what a discussion of these 'seq's -- We are careful to make sure we only @@ -371,7 +379,7 @@ certainlyWillInline opts fn_info rhs' | otherwise = StableSystemSrc tmpl' | isStableSource src = uf_tmpl fn_unf - | otherwise = occurAnalyseExpr rhs' + | otherwise = occurAnalyseExpr st_hack rhs' -- Do not overwrite stable unfoldings! DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense @@ -381,6 +389,7 @@ certainlyWillInline opts fn_info rhs' _other_unf -> Nothing where + st_hack = unfoldingStateHack opts noinline = isNoInlinePragma (inlinePragInfo fn_info) fn_unf = unfoldingInfo fn_info -- NB: loop-breakers never inline diff --git a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs index c1ffac1270..2f2173d0c7 100644 --- a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs +++ b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs @@ -2,14 +2,16 @@ module GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) where -import GHC.Prelude () +import GHC.Prelude (not) import GHC.Driver.Session import GHC.Core.Opt.Arity +import GHC.Types.Basic (StateHackFlag(..)) initArityOpts :: DynFlags -> ArityOpts initArityOpts dflags = ArityOpts { ao_ped_bot = gopt Opt_PedanticBottoms dflags , ao_dicts_cheap = gopt Opt_DictsCheap dflags + , ao_state_hack = StateHackFlag (not (gopt Opt_G_NoStateHack dflags)) } diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 3e205402e9..c303e2cf40 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -247,7 +247,7 @@ import GHC.Utils.Monad import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.SrcLoc import GHC.Types.SafeHaskell -import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, StateHackFlag(..) ) import GHC.Types.ProfAuto import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString @@ -1251,7 +1251,7 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], - unfoldingOpts = defaultUnfoldingOpts, + unfoldingOpts = defaultUnfoldingOpts (StateHackFlag True), maxWorkerArgs = 10, ghciHistSize = 50, -- keep a log of length 50 by default diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 88baab297c..b004d118b5 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -59,6 +59,9 @@ module GHC.Types.Basic ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension, sumParens, pprAlternative, + -- ** Enabling the state hack + StateHackFlag(..), + -- ** The OneShotInfo type OneShotInfo(..), noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, @@ -327,6 +330,8 @@ Other notes But the `\y` is most definitely not one-shot! -} +newtype StateHackFlag = StateHackFlag { stateHackEnabled :: Bool } + -- | If the 'Id' is a lambda-bound variable then it may have lambda-bound -- variable info. Sometimes we know whether the lambda binding this variable -- is a "one-shot" lambda; that is, whether it is applied at most once. diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 41e37b7f69..82ccf2c11f 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -488,7 +488,8 @@ mkDictSelId name clas info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts + `setUnfoldingInfo` mkInlineUnfoldingWithArity + (defaultSimpleOpts (StateHackFlag True)) StableSystemSrc 1 (mkDictSelRhs clas val_index) -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance @@ -497,7 +498,8 @@ mkDictSelId name clas | otherwise = base_info `setRuleInfo` mkRuleInfo [rule] `setInlinePragInfo` neverInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts + `setUnfoldingInfo` mkInlineUnfoldingWithArity + (defaultSimpleOpts (StateHackFlag True)) StableSystemSrc 1 (mkDictSelRhs clas val_index) -- Add a magic BuiltinRule, but no unfolding diff --git a/hadrian/src/Settings/Flavours/Release.hs b/hadrian/src/Settings/Flavours/Release.hs index 2f3daadae1..492f6b30d0 100644 --- a/hadrian/src/Settings/Flavours/Release.hs +++ b/hadrian/src/Settings/Flavours/Release.hs @@ -4,4 +4,4 @@ import Settings.Flavours.Performance import Flavour releaseFlavour :: Flavour -releaseFlavour = enableHaddock performanceFlavour { name = "release" } +releaseFlavour = splitSections $ enableHaddock performanceFlavour { name = "release" } |