Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6f212121 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Encapsulate options of occurAnalysePgm in a record - - - - - adfbb179 by Facundo Domínguez at 2026-06-26T20:56:27-04:00 Allow to configure the occurrence analyser to retain some dead bindings This is needed by plugins that are the only consumers of a binding which is otherwise unused in the program. See Note [Controlling elimination of dead bindings in occurrence analysis] added in this commit, or https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for more discussion. - - - - - c745b11f by Copilot at 2026-06-26T20:56:27-04:00 Address documentation feedback - - - - - 2c2a4a2a by Copilot at 2026-06-26T20:56:27-04:00 Keep the imp_rules parameter of occurPgmAnalysePgm and add occ_opts to OccEnv - - - - - e2262b0e by Copilot at 2026-06-26T20:56:27-04:00 Strengthen T27240.hs with a binding that should be removed - - - - - 5f9d9268 by Copilot at 2026-06-26T20:56:27-04:00 Move the reference #27240 to a related paragraph - - - - - 7 changed files: - + changelog.d/add_can_drop_to_occurence_analyser - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Driver/Config.hs - + testsuite/tests/ghc-api/T27240.hs - testsuite/tests/ghc-api/all.T Changes: ===================================== changelog.d/add_can_drop_to_occurence_analyser ===================================== @@ -0,0 +1,19 @@ +section: ghc-lib +synopsis: Add ``oa_can_drop`` option to the occurrence analyser which selects + bindings to preserve. + +issues: #27240 +mrs: !16253 + +description: { + This is only relevant to clients of the GHC API. + + The ``oa_can_drop`` option of the occurrence analyser indicates whether a + binding is ok to drop. The option is also exposed in the simple optimiser as + ``so_can_drop``. + + In addition, the function ``occurAnalysePgm`` earned a record parameter of + type ``OccurAnalOpts`` which aggregates former parameters of the function. + The record type ``OccEnv`` in turn, replaces its fields ``occ_unf_act`` and + ``occ_rule_act`` with a field ``occ_opts`` of type ``OccurAnalOpts``. +} ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -26,6 +26,7 @@ core expression with (hopefully) improved usage information. -} module GHC.Core.Opt.OccurAnal ( + OccurAnalOpts(..), occurAnalysePgm, occurAnalyseExpr, occurAnalyseBndrsAndExpr, occurAnalyseExpr_Prep, @@ -103,12 +104,21 @@ occurAnalyseExpr_Prep expr = expr' where WUD _ expr' = occAnal (initOccEnv { occ_allow_weak_joins = True }) expr +-- | Options for occurrence analysis of a program +data OccurAnalOpts = OccurAnalOpts + { oa_active_unf :: Id -> Bool -- ^ Active unfoldings + , oa_active_rule :: ActivationGhc -> Bool -- ^ Active rules + , oa_can_drop :: Id -> Bool + -- ^ Can we drop this Id if it is dead? + -- See Note [Controlling elimination of dead bindings in occurrence analysis]. + } + occurAnalysePgm :: Module -- Used only in debug output - -> (Id -> Bool) -- Active unfoldings - -> (ActivationGhc -> Bool) -- Active rules - -> [CoreRule] -- Local rules for imported Ids - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds + -> OccurAnalOpts + -> [CoreRule] -- Local rules for imported Ids + -> CoreProgram + -> CoreProgram +occurAnalysePgm this_mod opts imp_rules binds | isEmptyDetails final_usage = occ_anald_binds @@ -116,8 +126,7 @@ 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 { occ_opts = opts } WUD final_usage occ_anald_binds = go binds init_env WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel @@ -1033,6 +1042,27 @@ Note [Occurrences in stable unfoldings and RULES]: occurrences in an unfolding or RULE are treated as ManyOcc anyway. But NB that tail-call info is preserved so that we don't thereby lose join points. + +Note [Controlling elimination of dead bindings in occurrence analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, plugins might want to retain dead bindings. + +For instance, Liquid Haskell might be the sole consumer of a binding that is +providing a proof. Or it might provide a lemma that is needed to check other +parts of the program. Or it might provide a value that is only referred from a +refinement type, but not from the Haskell code itself. See #27240 for more +details. + +For this reason, the occurrence analyser can be configured to retain +some bindings even if they are dead. This is done by setting the `oa_can_drop` +field of `OccAnalOpts` to a function that returns `False` for the bindings that +should be retained. All calls to the occurrence analyser from within GHC itself +use `const True` for this predicate; only calls from plugins might return +`False` in some cases. + +Alternatively, the plugin could avoid running the occurrence analyser, but that +would also disable other effects, such as the split of the program in strongly +connected components. -} ------------------------------------------------------------------ @@ -1078,7 +1108,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine !(WUD body_uds (occ, body)) = occAnalNonRecBody env_body bndr' $ \env -> thing_inside (addJoinPoint env bndr' rhs_uds) in - if isDeadOcc occ -- Drop dead code; see Note [Dead code] + if isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Drop dead code; see Note [Dead code] then WUD body_uds body else WUD (combineJoinPointUDs env rhs_uds body_uds) -- Note `orUDs` (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs'] @@ -1088,7 +1118,7 @@ occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine -- Analyse the body and /then/ the RHS | let env_body = addLocalLet env lvl bndr , WUD body_uds (occ,body) <- occAnalNonRecBody env_body bndr thing_inside - = if isDeadOcc occ -- Drop dead code; see Note [Dead code] + = if isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Drop dead code; see Note [Dead code] then WUD body_uds body else let -- Get the join info from the *new* decision; NB: bndr is not already a JoinId @@ -1225,10 +1255,10 @@ occAnalRec :: OccEnv -> TopLevelFlag -> WithUsageDetails [CoreBind] -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec !_ lvl +occAnalRec !env lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) (WUD body_uds binds) - | isDeadOcc occ -- Check for dead code: see Note [Dead code] + | isDeadOcc occ && oa_can_drop (occ_opts env) bndr -- Check for dead code: see Note [Dead code] = WUD body_uds binds | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr @@ -1463,8 +1493,8 @@ However, tagZero can only be inlined in phase 1 and later, while the RULE is only active *before* phase 1. So there's no problem. To make this work, we look for the RHS free vars only for -*active* rules. That's the reason for the occ_rule_act field -of the OccEnv. +*active* rules. That's the reason for the oa_active_rule field +of occ_opts in OccEnv. Note [loopBreakNodes] ~~~~~~~~~~~~~~~~~~~~~ @@ -1854,7 +1884,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs) -- of Note [Join arity prediction based on joinRhsArity] --------- IMP-RULES -------- - is_active = occ_rule_act env :: ActivationGhc -> Bool + is_active = oa_active_rule (occ_opts env) :: ActivationGhc -> Bool imp_rule_info = lookupImpRules imp_rule_edges bndr imp_rule_uds = impRulesScopeUsage imp_rule_info imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info @@ -1963,8 +1993,8 @@ nodeScore !env new_bndr lb_deps | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers = (0, 0, True) -- See Note [Self-recursion and loop breakers] - | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has - = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + | not (oa_active_unf (occ_opts env) old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker | exprIsTrivial rhs = mk_score 10 -- Practically certain to be inlined @@ -2985,8 +3015,7 @@ scrutinised y). data OccEnv = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - , occ_rule_act :: ActivationGhc -> Bool -- Which rules are active + , occ_opts :: !OccurAnalOpts -- See Note [Finding rule RHS free vars] , occ_allow_weak_joins :: !Bool @@ -3055,18 +3084,19 @@ initOccEnv :: OccEnv initOccEnv = OccEnv { occ_encl = OccVanilla , occ_one_shots = [] - - -- To be conservative, we say that all - -- inlines and rules are active - , occ_unf_act = \_ -> True - , occ_rule_act = \_ -> True - , occ_allow_weak_joins = False - , occ_join_points = emptyVarEnv , occ_bs_env = emptyVarEnv , occ_bs_rng = emptyVarSet - , occ_nested_lets = emptyVarSet } + , occ_nested_lets = emptyVarSet + -- To be conservative, we say that all + -- inlines and rules are active + , occ_opts = OccurAnalOpts + { oa_active_rule = \_ -> True + , oa_active_unf = \_ -> True + , oa_can_drop = \_ -> True + } + } noBinderSwaps :: OccEnv -> Bool noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env ===================================== compiler/GHC/Core/Opt/Simplify.hs ===================================== @@ -12,7 +12,7 @@ import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( OccurAnalOpts(..), occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) @@ -252,8 +252,15 @@ simplifyPgm logger unit_env name_ppr_ctx opts = do { -- Occurrence analysis let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule - local_rules binds + occurAnalysePgm + this_mod + OccurAnalOpts + { oa_active_unf = active_unf + , oa_active_rule = active_rule + , oa_can_drop = const True + } + local_rules + binds } ; Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -28,7 +28,7 @@ import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Make -import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) +import GHC.Core.Opt.OccurAnal( OccurAnalOpts(..), occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Core.DataCon import GHC.Core.Coercion.Opt ( optCoercion, optTransCo, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList @@ -208,6 +208,8 @@ data SimpleOpts = SimpleOpts -- used-once things -- -- See Note [Controlling inlining in the simple optimiser] + , so_can_drop :: !(Var -> Bool) -- ^ True <=> can drop the given binding if it is dead + -- See 'oa_can_drop' in 'OccurAnalOpts'. } -- | Default options for the Simple optimiser. @@ -217,6 +219,7 @@ defaultSimpleOpts = SimpleOpts , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } , so_eta_red = False , so_inline = const True + , so_can_drop = const True } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -282,10 +285,15 @@ simpleOptPgm :: SimpleOpts simpleOptPgm opts this_mod binds rules = (reverse binds', rules', occ_anald_binds) where - occ_anald_binds = occurAnalysePgm this_mod - (\_ -> True) {- All unfoldings active -} - (\_ -> False) {- No rules active -} - rules binds + occ_anald_binds = occurAnalysePgm + this_mod + OccurAnalOpts + { oa_active_unf = \_ -> True {- All unfoldings active -} + , oa_active_rule = \_ -> False {- No rules active -} + , oa_can_drop = so_can_drop opts + } + rules + binds (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds final_subst = soe_subst final_env ===================================== compiler/GHC/Driver/Config.hs ===================================== @@ -27,6 +27,7 @@ initSimpleOpts dflags = SimpleOpts , so_co_opts = initOptCoercionOpts dflags , so_eta_red = gopt Opt_DoEtaReduction dflags , so_inline = const True + , so_can_drop = const True } -- | Instruct the interpreter evaluation to break... ===================================== testsuite/tests/ghc-api/T27240.hs ===================================== @@ -0,0 +1,128 @@ + +-- This test checks that bindings are preserved when configuring the occurrence +-- analyzer and the simple optimizer to not drop dead bindings with names +-- selected by a predicate. +-- +-- This feature is important for the LiquidHaskell plugin, which relies on the +-- simple optimizer to make core programs easier to read, but needs to preserve +-- bindings that are relevant for verification. +-- +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/27240 for the full discussion. +-- + +import Control.Monad +import Data.List (find) +import Data.Time (getCurrentTime) +import GHC +import GHC.Core +import GHC.Core.SimpleOpt +import GHC.Data.StringBuffer +import GHC.Driver.Config +import GHC.Driver.DynFlags +import GHC.Driver.Env.Types +import GHC.Types.Name +import GHC.Unit.Module.ModGuts +import GHC.Unit.Types +import GHC.Utils.Error +import GHC.Utils.Outputable + +import System.Environment (getArgs) + + +main :: IO () +main = + testLocalBindingsDesugaring + +testLocalBindingsDesugaring :: IO () +testLocalBindingsDesugaring = do + let inputSource = unlines + [ "module LocalDeadBindingsDesugaring where" + , "f :: ()" + , "f = ()" + , " where" + , " w = ()" + , " z = ()" + ] + + isExpectedDesugaring p = case findExpr "f" p of + Just (Let (NonRec b _) _) + -> isIdNamed "z" b + _ -> False + + isIdNamed name v = occNameString (occName v) == name + + coreProgram <- + compileToCore + (not . isIdNamed "z") + "LocalDeadBindingsDesugaring" + inputSource + unless (isExpectedDesugaring coreProgram) $ + fail $ unlines $ + "Unexpected desugaring: No local binding for `z` found in the Core program." + : map showPprQualified coreProgram + +-- | Find the Core expression bound to the given name. +findExpr :: String -> CoreProgram -> Maybe CoreExpr +findExpr _ [] = + Nothing +findExpr name (p:ps) = case p of + NonRec b e + | occNameString (occName b) == name + -> Just e + Rec binds + | Just (_, e) <- find (\(b, _e) -> occNameString (occName b) == name) binds + -> Just e + _ -> findExpr name ps + +showPprQualified :: Outputable a => a -> String +showPprQualified = showSDocQualified . ppr + +showSDocQualified :: SDoc -> String +showSDocQualified = renderWithContext ctx + where + ctx = defaultSDocContext { sdocStyle = cmdlineParserStyle } + + + +compileToCore :: (Id -> Bool) -> String -> String -> IO [CoreBind] +compileToCore canDrop modName inputSource = do + [libdir] <- getArgs + now <- getCurrentTime + runGhc (Just libdir) $ do + df1 <- getSessionDynFlags + GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend } + let target = Target { + targetId = TargetFile (modName ++ ".hs") Nothing + , targetUnitId = homeUnitId_ df1 + , targetAllowObjCode = False + , targetContents = Just (stringToStringBuffer inputSource, now) + } + setTargets [target] + void $ GHC.depanal [] False + + dsMod <- getModSummary + (mkModule mainUnit (mkModuleName modName)) + >>= parseModule + >>= typecheckModule NoTcMPlugins + >>= desugarModule + hsc_env <- getSession + return $ mg_binds $ simpleOptimize canDrop hsc_env $ dm_core_module dsMod + +-- Run the simple optimizer +simpleOptimize :: (Id -> Bool) -> GHC.HscEnv -> ModGuts -> ModGuts +simpleOptimize canDrop hsc_env guts@(ModGuts + { mg_module = mgmod + , mg_binds = binds + , mg_rules = rules + }) = + let dflags = hsc_dflags hsc_env + simpl_opts = (initSimpleOpts dflags) + { so_inline = canDrop + , so_can_drop = canDrop + } + (binds2, rules2, _occ_anald_binds) = + simpleOptPgm simpl_opts mgmod binds rules + in guts + { mg_binds = binds2 + , mg_rules = rules2 + } ===================================== testsuite/tests/ghc-api/all.T ===================================== @@ -82,6 +82,7 @@ test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc']) test('T25121_status', normal, compile_and_run, ['-package ghc']) test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) +test('T27240', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) test('T27273', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412f16756dff9d3b71ba1c4646c8bce... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/412f16756dff9d3b71ba1c4646c8bce... You're receiving this email because of your account on gitlab.haskell.org.