April 2026 - ghc-commits

[Git][ghc/ghc][wip/T26989] Wibbles
by Simon Peyton Jones (＠simonpj) 11 Apr '26

11 Apr '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 76ed405c by Simon Peyton Jones at 2026-04-11T22:59:23+01:00 Wibbles - - - - - 3 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Driver/Config/Core/Lint.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1067,7 +1067,13 @@ lintIdOcc in_id nargs checkL (idName in_id /= makeStaticName) $ text "Found makeStatic nested in an expression" - ; checkDeadIdOcc in_id + -- Occurrences of an Id should never be dead.... + -- except in a couple of special cases + -- See Note [Dead occurrences] + ; flags <- getLintFlags + ; checkL (not (isDeadOcc (idOccInfo in_id)) + || lf_allow_dead_occs flags) + (text "Occurrence of a dead Id" <+> ppr in_id) ; case isDataConId_maybe in_id of Nothing -> return () @@ -1078,7 +1084,17 @@ lintIdOcc in_id nargs ; return (out_ty, usage) } - +{- Note [Dead occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +An occurrence of an Id whose binder is marked as dead is usually +a mistake. But + * For the RULE forall a b. f [a,b] = g a + we mark `b` as dead because it is unused in the body, even though + it is of course used in the patterns + * For case patterns... I don't really understand, but it dates back a long way + +We permit these dead occurrences by setting the flag `lf_allow_dead_occs` +-} lintCoreFun :: CoreExpr -> Int -- Number of arguments (type or val) being passed @@ -1104,17 +1120,6 @@ lintLambda var lintBody = do { (body_ty, ue) <- lintBody ; ue' <- checkLinearity ue var' ; return (mkLamType var' body_ty, ue') } ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () ------------------ lintJoinBndrType :: OutType -- Type of the body @@ -1737,7 +1742,8 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh -- And now bring the new binders into scope ; lintBinders CasePatBind args $ \ args' -> do { rhs_ue <- lintAltExpr rhs alt_ty - ; rhs_ue' <- addLoc (CasePat alt) $ + ; rhs_ue' <- allowDeadOccs $ -- See Note [Dead occurrences] + addLoc (CasePat alt) $ lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual multiplicities args') ; return $ deleteUE rhs_ue' case_bndr @@ -2221,7 +2227,8 @@ lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs = noMultiplicityChecks $ -- Skip linearity checking for rules -- See Note [Linting linearity] lintBinders LambdaBind bndrs $ \ _ -> - do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + do { (lhs_ty, _) <- allowDeadOccs $ -- See Note [Dead occurrences] + lintCoreArgs (fun_ty, zeroUE) args ; (rhs_ty, _) <- case idJoinPointHood fun of JoinPoint join_arity -> do { checkL (args `lengthIs` join_arity) $ @@ -2999,7 +3006,8 @@ data LintFlags , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] , lf_check_fixed_rep :: Bool -- ^ See Note [Checking for representation polymorphism] , lf_check_rubbish_lits :: Bool -- ^ See Note [Checking for rubbish literals] - , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_weak_joins :: Bool -- ^ See Note [Linting join points with casts or ticks] + , lf_allow_dead_occs :: Bool -- ^ See Note [Dead occurrences] } -- See Note [Checking StaticPtrs] @@ -3366,6 +3374,10 @@ noMultiplicityChecks :: LintM a -> LintM a noMultiplicityChecks = updLintFlags $ \ flags -> flags { lf_check_linearity = False } +allowDeadOccs :: LintM a -> LintM a +allowDeadOccs = + updLintFlags $ \ flags -> flags { lf_allow_dead_occs = True } + getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) @@ -3429,12 +3441,6 @@ addLoc extra_loc m = LintM $ \ env errs -> unLintM m (env { le_loc = extra_loc : le_loc env }) errs -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a -- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned addInScopeId in_id out_ty thing_inside ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1873,9 +1873,6 @@ simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se , not (needsCaseBindingL arg_levity arg) -- Ok to test arg::InExpr in needsCaseBinding because -- exprOkForSpeculation is stable under simplification - , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] - not (exprIsTrivial arg) && - not (isDeadOcc (idOccInfo bndr)) ) -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $ tick (PreInlineUnconditionally bndr) ; simplLam env' body cont } @@ -2056,6 +2053,8 @@ Wrinkles: is no danger of simplifying repeatedly. But there is a benefit: it can save a simplifier iteration. So we check for that. + ToDo: I have improved this via simplOutExpr + ************************************************************************ * * ===================================== compiler/GHC/Driver/Config/Core/Lint.hs ===================================== @@ -116,7 +116,8 @@ perPassFlags dflags pass , lf_check_static_ptrs = check_static_ptrs , lf_check_linearity = check_linearity , lf_check_rubbish_lits = check_rubbish - , lf_allow_weak_joins = allow_weak_joins } + , lf_allow_weak_joins = allow_weak_joins + , lf_allow_dead_occs = False } where -- See Note [Checking for global Ids] check_globals = case pass of @@ -175,4 +176,5 @@ defaultLintFlags dflags = LF { lf_check_global_ids = False , lf_check_fixed_rep = True , lf_check_rubbish_lits = True , lf_allow_weak_joins = False + , lf_allow_dead_occs = False } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76ed405cfbf9d63f274dc7f2a40e668… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76ed405cfbf9d63f274dc7f2a40e668… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] Wibbles
by Simon Peyton Jones (＠simonpj) 11 Apr '26

11 Apr '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: 27d8694f by Simon Peyton Jones at 2026-04-11T22:05:02+01:00 Wibbles Better management of casts - - - - - 6 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/IfaceToCore.hs Changes: ===================================== compiler/GHC/Core.hs ===================================== @@ -1968,6 +1968,11 @@ Given this decision it's vital that we do *always* do it. occurrence in f out of scope. This happened in #8892, where the unfolding in question was a DFun unfolding. +Wrinkles + +(OUR1) For a RULE, say, + forall x y. f (x,y) = x+y +ToDO ************************************************************************ * * ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -27,7 +27,8 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, - occurAnalyseExpr, occurAnalyseExpr_Prep, + occurAnalyseExpr, occurAnalyseBndrsAndExpr, + occurAnalyseExpr_Prep, zapLambdaBndrs ) where @@ -85,6 +86,14 @@ occurAnalyseExpr expr = expr' where WUD _ expr' = occAnal initOccEnv expr +occurAnalyseBndrsAndExpr :: [Var] -> CoreExpr -> ([Var], CoreExpr) +-- Occur-anal (\bs.e), but taking and returning `bs` and `e` separately +occurAnalyseBndrsAndExpr bndrs expr + = (bndrs', expr') + where + WUD usage expr' = occAnal initOccEnv expr + bndrs' = tagLamBinders usage bndrs + -- | A version of 'occurAnalyseExpr' suitable for CorePrep. -- -- Different from 'occurAnalyseExpr' due to (JCT3) ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1219,9 +1219,21 @@ simplExprF1 _ (Type ty) cont simplExprF1 env (Var v) cont = {-#SCC "simplInId" #-} simplInId env v cont simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont +simplExprF1 env (Cast body co) cont + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} + simplCoercion env co + + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont -- See Note [Optimising reflexivity] + else pushCast env co1 cont + -- True <=> co1 is optimised + + ; {-#SCC "simplCast-simplExprF" #-} + simplExprF env body cont1 } + simplExprF1 env (App fun arg) cont = {-#SCC "simplExprF1-App" #-} case arg of Type ty -> do { -- The argument type will (almost) certainly be used @@ -1567,6 +1579,10 @@ rebuild_go env expr cont Stop {} -> return (emptyFloats env, expr) TickIt t cont -> rebuild_go env (mkTick t expr) cont CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } + | isReflexiveCo co' -- Worth trying this because casts can + -- get stacked up by simplCast + -> rebuild_go env expr cont + | otherwise -> rebuild_go env (mkCast expr co') cont -- NB: mkCast implements the (Coercion co |> g) optimisation where @@ -1689,9 +1705,8 @@ on each successive composition -- that's at least quadratic. So: * In `addCoerce` (in `simplCast`) if we combine this new coercion with an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False. -* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise - the (presumably composed) coercion if sc_opt=False; this is done - by `optOutCoercion`. +* When unpacking a CastIt, in `rebuild`, we optimise the (presumably + composed) coercion if sc_opt=False; this is done by `optOutCoercion`. * When duplicating a continuation in `mkDupableContWithDmds`, before duplicating a CastIt, optimise the coercion. Otherwise we'll end up @@ -1708,76 +1723,70 @@ optOutCoercion env co already_optimised empty_subst = mkEmptySubst (seInScope env) opts = seOptCoercionOpts env -simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 True cont0 - -- True <=> co1 is optimised - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } +pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont +pushCast env co cont + = go co True cont where + go :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont + go co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = go (mkTransCo co1 co2) False cont + -- False: (mkTransCo co1 co2) is not fully optimised + -- See Note [Avoid re-simplifying coercions] + + go co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- go_mco m_co' co_is_opt tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + go co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail + , sc_hole_ty = fun_ty }) + | not co_is_opt + = -- pushCoValArg duplicates the coercion, so optimise first + go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont + + | Just (m_co1, m_co2) <- pushCoValArg co + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- go_mco m_co2 co_is_opt tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- See Note [Avoiding simplifying repeatedly] + + MCo co1 -> + do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + go co co_is_opt cont + | isReflCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + -- If the first parameter is MRefl, then simplifying revealed a -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerceM MRefl _ cont = return cont - addCoerceM (MCo co) opt cont = addCoerce co opt cont - - addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont - addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] - = addCoerce (mkTransCo co1 co2) False cont - -- False: (mkTransCo co1 co2) is not fully optimised - -- See Note [Avoid re-simplifying coercions] - - addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' co_is_opt tail - ; return (ApplyToTy { sc_arg_ty = arg_ty' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } - -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - - -- (f |> co) e ===> (f (e |> co1)) |> co2 - -- where co :: (s1->s2) ~ (t1->t2) - -- co1 :: t1 ~ s1 - -- co2 :: s2 ~ t2 - addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail - , sc_hole_ty = fun_ty }) - | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first - = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont - - | Just (m_co1, m_co2) <- pushCoValArg co - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 co_is_opt tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; - -- See Note [Avoiding simplifying repeatedly] - - MCo co1 -> - do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } - - addCoerce co co_is_opt cont - | isReflCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont }) + go_mco :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont + go_mco MRefl _ cont = return cont + go_mco (MCo co) opt cont = go co opt cont simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet -> DupFlag @@ -2293,14 +2302,21 @@ simplInId env var cont --------------------------------------------------------- simplOutExpr :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) simplOutExpr env expr cont - = case fun of - Var v -> simplOutId env v cont' - Lam {} | not (null args) -> simplLam env occ_fun cont' -- We have a beta-redex - _ -> rebuild_go env expr cont - where - (fun, args) = collectArgs expr - cont' = pushArgs env Simplified (exprType fun) args cont - occ_fun = occurAnalyseExpr fun -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] + | Lam {} <- expr + , hasArgs cont + = simplLam env (occurAnalyseExpr expr) cont + -- ToDo:explain; c.f. Note [Occurrence-analyse after rule firing] + + | Cast e co <- expr -- The inlined expression may be (x |> co) + -- and the cast may cancel with `cont` + = do { cont' <- pushCast env co cont + ; simplOutExpr env e cont' } + + | (Var v, args) <- collectArgs expr + = simplOutId env v (pushArgs env (idType v) args cont) + + | otherwise + = rebuild_go env expr cont --------------------------------------------------------- simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -2654,7 +2670,7 @@ fireRuleAFTER env rule_match arg_specs cont , rm_binds = wrap, rm_bndrs = bndrs } <- rule_match = do { let env' = env `addNewInScopeIds` bndrs ; (floats, e') <- simplExprF env' rhs $ - pushArgs env' Simplified (exprType rhs) rhs_args $ + pushArgs env' (exprType rhs) rhs_args $ pushArgSpecs env' (drop (ruleArity rule) arg_specs) cont ; return $ if isEmptyBindWrapper wrap -- Not very pretty ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -25,7 +25,7 @@ module GHC.Core.Opt.Simplify.Utils ( isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, - countArgs, contOutArgs, dropContArgs, + hasArgs, countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, @@ -384,17 +384,17 @@ isStrictArgInfo (ArgInfo { ai_dmds = dmds }) | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False -pushArgs :: SimplEnvIS -> DupFlag -> Type -> [OutExpr] -> SimplCont -> SimplCont -pushArgs _env _dup _fun_ty [] cont +pushArgs :: SimplEnvIS -> Type -> [OutExpr] -> SimplCont -> SimplCont +pushArgs _env _fun_ty [] cont = cont -pushArgs env dup fun_ty (arg:args) cont +pushArgs env fun_ty (arg:args) cont | Type ty <- arg = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty - , sc_cont = pushArgs env dup (piResultTy fun_ty ty) args cont } + , sc_cont = pushArgs env (piResultTy fun_ty ty) args cont } | otherwise - = ApplyToVal { sc_dup = dup, sc_hole_ty = fun_ty + = ApplyToVal { sc_dup = Simplified, sc_hole_ty = fun_ty , sc_arg = arg, sc_env = env - , sc_cont = pushArgs env dup (funResultTy fun_ty) args cont} + , sc_cont = pushArgs env (funResultTy fun_ty) args cont} pushArgSpecs :: SimplEnvIS -- Barely needed, since sc_dup = Simplified -> [ArgSpec] -- In normal, forward order @@ -522,6 +522,12 @@ contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k contHoleScaling (TickIt _ k) = contHoleScaling k ------------------- +hasArgs :: SimplCont -> Bool +-- True <=> some leading arguments +hasArgs (ApplyToTy {}) = True +hasArgs (ApplyToVal {}) = True +hasArgs _ = False + countArgs :: SimplCont -> Int -- Count all arguments, including types, coercions, -- and other values; skipping over casts. ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Core.Make ( mkCoreLams ) -import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal( occurAnalyseBndrsAndExpr ) import GHC.Core.Rules.Config (roBuiltinRules) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) @@ -200,16 +200,18 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs = Rule { ru_name = name , ru_act = act , ru_fn = fn - , ru_bndrs = bndrs + , ru_bndrs = bndrs' , ru_args = args - , ru_rhs = occurAnalyseExpr rhs - -- See Note [OccInfo in unfoldings and rules] + , ru_rhs = rhs' , ru_rough = roughTopNames args , ru_origin = this_mod , ru_orphan = orph , ru_auto = is_auto , ru_local = is_local } where + (bndrs', rhs') = occurAnalyseBndrsAndExpr bndrs rhs + -- See Note [OccInfo in unfoldings and rules] + -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -76,7 +76,7 @@ import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseBndrsAndExpr ) import GHC.Core.Ppr import GHC.Hs.Extension ( GhcRn ) @@ -1418,18 +1418,22 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd (emptyBag, errs) } ; return (bndrs', args', rhs') } ; let mb_tcs = map ifTopFreeName args + (bndrs_occ, rhs_occ) = occurAnalyseBndrsAndExpr bndrs' rhs' + -- See Note [OccInfo in unfoldings and rules] ; this_mod <- getIfModule - ; return (Rule { ru_name = name, ru_fn = fn, - ru_act = act, - ru_bndrs = bndrs', ru_args = args', - ru_rhs = occurAnalyseExpr rhs', - ru_rough = mb_tcs, - ru_origin = this_mod, - ru_orphan = orph, - ru_auto = auto, - ru_local = False }) } -- An imported RULE is never for a local Id - -- or, even if it is (module loop, perhaps) - -- we'll just leave it in the non-local set + ; return (Rule { ru_name = name + , ru_fn = fn + , ru_act = act + , ru_bndrs = bndrs_occ + , ru_args = args' + , ru_rhs = rhs_occ + , ru_rough = mb_tcs + , ru_origin = this_mod + , ru_orphan = orph + , ru_auto = auto + , ru_local = False }) } + -- ru_local=False: an imported RULE is never for a local Id or, even if + -- it is (module loop, perhaps) we'll just leave it in the non-local set where -- This function *must* mirror exactly what Rules.roughTopNames does -- We could have stored the ru_rough field in the iface file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27d8694fc3cbecf96dc78924ecfac51… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/27d8694fc3cbecf96dc78924ecfac51… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Improve naming
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: d99388ed by Wolfgang Jeltsch at 2026-04-11T21:47:00+03:00 Improve naming - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -44,7 +44,11 @@ import GHC.Data.OsPath import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Module.Graph (ModuleNameHomeMap (..), mgHomeModuleMap) +import GHC.Unit.Module.Graph + ( + CompleteUnits (cu_inventory, cu_providers), + mgCompleteUnits + ) import GHC.Unit.Home import GHC.Unit.Home.Graph (UnitEnvGraph) import qualified GHC.Unit.Home.Graph as HUG @@ -178,13 +182,13 @@ getDirHash dir = do findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult findImportedModule hsc_env mod pkg_qual = - let fc = hsc_FC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags + let fc = hsc_FC hsc_env + mb_home_unit = hsc_home_unit_maybe hsc_env + dflags = hsc_dflags hsc_env + fopts = initFinderOpts dflags in do - let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual + let complete_home_units = mgCompleteUnits (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) complete_home_units mb_home_unit mod pkg_qual findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do @@ -197,27 +201,26 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv - -> ModuleNameHomeMap + -> CompleteUnits -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue complete_home_units mb_home_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import - ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import + ThisPkg uid | (homeUnitId <$> mb_home_unit) == Just uid -> home_import | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) - | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) + | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mb_home_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - ModuleNameHomeMap complete_units module_name_map = home_module_map - module_home_units = M.findWithDefault Set.empty mod_name module_name_map - current_unit_id = homeUnitId <$> mhome_unit - all_opts = case current_unit_id of + cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units) + mb_home_unit_id = homeUnitId <$> mb_home_unit + all_opts = case mb_home_unit_id of Nothing -> other_fopts Just home_unit_id -> (home_unit_id, fopts) : other_fopts - home_import = case mhome_unit of + home_import = case mb_home_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit") @@ -226,7 +229,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue complete_home_units (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -243,23 +246,23 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = `orIfNotFound` findExposedPackageModule fc fopts units mod_name NoPkgQual - units = case current_unit_id of + units = case mb_home_unit_id of Nothing -> ue_homeUnitState ue Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - dep_providers = Set.intersection module_home_units hpt_deps - known_other_uids = - let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id - in Set.toList providers - unknown_units = - let candidates = Set.difference hpt_deps complete_units - excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + cached_providing_deps = Set.intersection cached_module_providers hpt_deps + other_cached_providing_deps = + Set.toList $ + maybe cached_providing_deps (\u -> Set.delete u cached_providing_deps) mb_home_unit_id + uncached_providing_deps = + let candidates = Set.difference hpt_deps (cu_inventory complete_home_units) + excluded = maybe cached_providing_deps (\u -> Set.insert u cached_providing_deps) mb_home_unit_id in Set.toList (Set.difference candidates excluded) - other_home_uids = known_other_uids ++ unknown_units + other_providing_deps = other_cached_providing_deps ++ uncached_providing_deps other_fopts = [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) - | uid <- other_home_uids + | uid <- other_providing_deps ] -- | Locate a plugin module requested by the user, for a compiler @@ -278,15 +281,15 @@ findPluginModule :: HscEnv -> ModuleName -> IO FindResult findPluginModule hsc_env mod_name = do let fc = hsc_FC hsc_env let units = hsc_units hsc_env - let mhome_unit = hsc_home_unit_maybe hsc_env - findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name + let mb_home_unit = hsc_home_unit_maybe hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mb_home_unit mod_name -- | A version of findExactModule which takes the exact parts of the HscEnv it needs -- directly. findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do - res <- case mhome_unit of +findExactModuleNoHsc fc fopts other_fopts unit_state mb_home_unit mod is_boot = do + res <- case mb_home_unit of Just home_unit | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,8 +67,8 @@ module GHC.Unit.Module.Graph , mgLookupModule , mgLookupModuleName , mgHasHoles - , ModuleNameHomeMap (ModuleNameHomeMap) - , mgHomeModuleMap + , CompleteUnits (CompleteUnits, cu_inventory, cu_providers) + , mgCompleteUnits , showModMsg -- ** Reachability queries @@ -205,18 +205,21 @@ data ModuleGraph = ModuleGraph -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, -- This is only used for a hack in GHC.Iface.Load to do with backpack, please -- remove this at the earliest opportunity. - , mg_home_map :: ModuleNameHomeMap + , mg_complete_units :: CompleteUnits -- ^ For each module name, which home unit UnitIds define it together with the set of units for which the listing is complete. } -data ModuleNameHomeMap = ModuleNameHomeMap !(Set UnitId) - !(Map ModuleName (Set UnitId)) +data CompleteUnits = CompleteUnits + { + cu_inventory :: !(Set UnitId), + cu_providers :: !(Map ModuleName (Set UnitId)) + } -mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap -mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where +mkCompleteUnits :: [ModuleGraphNode] -> CompleteUnits +mkCompleteUnits nodes = CompleteUnits inventory providers where - providerMap :: Map ModuleName (Set UnitId) - providerMap + providers :: Map ModuleName (Set UnitId) + providers = Map.fromListWith Set.union $ [ (moduleName, Set.singleton unitID) | @@ -225,11 +228,11 @@ mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where let unitID = moduleNodeInfoUnitId moduleNodeInfo ] - completeUnits :: Set UnitId - completeUnits = Set.unions (Map.elems providerMap) + inventory :: Set UnitId + inventory = Set.unions (Map.elems providers) -mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap -mgHomeModuleMap = mg_home_map +mgCompleteUnits :: ModuleGraph -> CompleteUnits +mgCompleteUnits = mg_complete_units -- | Why do we ever need to construct empty graphs? Is it because of one shot mode? emptyMG :: ModuleGraph @@ -237,7 +240,7 @@ emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) False - (ModuleNameHomeMap Set.empty Map.empty) + (CompleteUnits Set.empty Map.empty) -- | Construct a module graph. This function should be the only entry point for -- building a 'ModuleGraph', since it is supposed to be built once and never modified. @@ -513,7 +516,7 @@ isEmptyMG = null . mg_mss mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg { mg_mss = new_mss - , mg_home_map = mkHomeModuleMap new_mss + , mg_complete_units = mkCompleteUnits new_mss } where new_mss = @@ -1086,7 +1089,7 @@ extendMG ModuleGraph{..} node = , mg_loop_graph = mkTransLoopDeps new_mss , mg_zero_graph = mkTransZeroDeps new_mss , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) - , mg_home_map = mkHomeModuleMap new_mss + , mg_complete_units = mkCompleteUnits new_mss } where new_mss = node : mg_mss View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d99388ed3e52d6fc4e90044835cb23e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d99388ed3e52d6fc4e90044835cb23e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Improve naming
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: 943f569e by Wolfgang Jeltsch at 2026-04-11T21:21:55+03:00 Improve naming - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -44,7 +44,11 @@ import GHC.Data.OsPath import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module -import GHC.Unit.Module.Graph (ModuleNameHomeMap (..), mgHomeModuleMap) +import GHC.Unit.Module.Graph + ( + CompleteUnits (cu_inventory, cu_providers), + mgCompleteUnits + ) import GHC.Unit.Home import GHC.Unit.Home.Graph (UnitEnvGraph) import qualified GHC.Unit.Home.Graph as HUG @@ -183,8 +187,8 @@ findImportedModule hsc_env mod pkg_qual = dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags in do - let home_module_map = mgHomeModuleMap (hsc_mod_graph hsc_env) - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) home_module_map mhome_unit mod pkg_qual + let complete_home_units = mgCompleteUnits (hsc_mod_graph hsc_env) + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) complete_home_units mhome_unit mod pkg_qual findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do @@ -197,12 +201,12 @@ findImportedModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnv - -> ModuleNameHomeMap + -> CompleteUnits -> Maybe HomeUnit -> ModuleName -> PkgQual -> IO FindResult -findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = +findImportedModuleNoHsc fc fopts ue complete_home_units mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import @@ -210,8 +214,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where - ModuleNameHomeMap complete_units module_name_map = home_module_map - module_home_units = M.findWithDefault Set.empty mod_name module_name_map + cached_module_providers = M.findWithDefault Set.empty mod_name (cu_providers complete_home_units) current_unit_id = homeUnitId <$> mhome_unit all_opts = case current_unit_id of Nothing -> other_fopts @@ -226,7 +229,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = -- If the module is reexported, then look for it as if it was from the perspective -- of that package which reexports it. | Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name = - findImportedModuleNoHsc fc opts ue home_module_map (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual + findImportedModuleNoHsc fc opts ue complete_home_units (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual | elementOfUniqSet mod_name (finder_hiddenModules opts) = return (mkHomeHidden uid) | otherwise = @@ -248,12 +251,12 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue hpt_deps :: Set.Set UnitId hpt_deps = homeUnitDepends units - dep_providers = Set.intersection module_home_units hpt_deps + dep_providers = Set.intersection cached_module_providers hpt_deps known_other_uids = let providers = maybe dep_providers (\u -> Set.delete u dep_providers) current_unit_id in Set.toList providers unknown_units = - let candidates = Set.difference hpt_deps complete_units + let candidates = Set.difference hpt_deps (cu_inventory complete_home_units) excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id in Set.toList (Set.difference candidates excluded) other_home_uids = known_other_uids ++ unknown_units ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,8 +67,8 @@ module GHC.Unit.Module.Graph , mgLookupModule , mgLookupModuleName , mgHasHoles - , ModuleNameHomeMap (ModuleNameHomeMap) - , mgHomeModuleMap + , CompleteUnits (CompleteUnits, cu_inventory, cu_providers) + , mgCompleteUnits , showModMsg -- ** Reachability queries @@ -205,18 +205,21 @@ data ModuleGraph = ModuleGraph -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, -- This is only used for a hack in GHC.Iface.Load to do with backpack, please -- remove this at the earliest opportunity. - , mg_home_map :: ModuleNameHomeMap + , mg_complete_units :: CompleteUnits -- ^ For each module name, which home unit UnitIds define it together with the set of units for which the listing is complete. } -data ModuleNameHomeMap = ModuleNameHomeMap !(Set UnitId) - !(Map ModuleName (Set UnitId)) +data CompleteUnits = CompleteUnits + { + cu_inventory :: !(Set UnitId), + cu_providers :: !(Map ModuleName (Set UnitId)) + } -mkHomeModuleMap :: [ModuleGraphNode] -> ModuleNameHomeMap -mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where +mkCompleteUnits :: [ModuleGraphNode] -> CompleteUnits +mkCompleteUnits nodes = CompleteUnits inventory providers where - providerMap :: Map ModuleName (Set UnitId) - providerMap + providers :: Map ModuleName (Set UnitId) + providers = Map.fromListWith Set.union $ [ (moduleName, Set.singleton unitID) | @@ -225,11 +228,11 @@ mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where let unitID = moduleNodeInfoUnitId moduleNodeInfo ] - completeUnits :: Set UnitId - completeUnits = Set.unions (Map.elems providerMap) + inventory :: Set UnitId + inventory = Set.unions (Map.elems providers) -mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap -mgHomeModuleMap = mg_home_map +mgCompleteUnits :: ModuleGraph -> CompleteUnits +mgCompleteUnits = mg_complete_units -- | Why do we ever need to construct empty graphs? Is it because of one shot mode? emptyMG :: ModuleGraph @@ -237,7 +240,7 @@ emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) (graphReachability emptyGraph, const Nothing) False - (ModuleNameHomeMap Set.empty Map.empty) + (CompleteUnits Set.empty Map.empty) -- | Construct a module graph. This function should be the only entry point for -- building a 'ModuleGraph', since it is supposed to be built once and never modified. @@ -513,7 +516,7 @@ isEmptyMG = null . mg_mss mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph mapMG f mg@ModuleGraph{..} = mg { mg_mss = new_mss - , mg_home_map = mkHomeModuleMap new_mss + , mg_complete_units = mkCompleteUnits new_mss } where new_mss = @@ -1086,7 +1089,7 @@ extendMG ModuleGraph{..} node = , mg_loop_graph = mkTransLoopDeps new_mss , mg_zero_graph = mkTransZeroDeps new_mss , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) - , mg_home_map = mkHomeModuleMap new_mss + , mg_complete_units = mkCompleteUnits new_mss } where new_mss = node : mg_mss View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/943f569e5e152ca2917266024f63beb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/943f569e5e152ca2917266024f63beb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Implement `completeUnits` based on `providerMap`
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: 0ea88d7d by Wolfgang Jeltsch at 2026-04-11T20:42:01+03:00 Implement `completeUnits` based on `providerMap` - - - - - 1 changed file: - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -226,11 +226,7 @@ mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where ] completeUnits :: Set UnitId - completeUnits = Set.fromList $ - [ - moduleNodeInfoUnitId moduleNodeInfo | - ModuleNode _ moduleNodeInfo <- nodes - ] + completeUnits = Set.unions (Map.elems providerMap) mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap mgHomeModuleMap = mg_home_map View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ea88d7dec780e34f938f798661a921… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ea88d7dec780e34f938f798661a921… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/dcanon-local-binds-proposal
by Simon Jakobi (＠sjakobi2) 11 Apr '26

11 Apr '26

Simon Jakobi pushed new branch wip/sjakobi/dcanon-local-binds-proposal at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/dcanon-local-binds-pr… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment] Deleted 1 commit: Drop the construction and use of `other_fopts_map`
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment at Glasgow Haskell Compiler / GHC WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below. Deleted commits: e49a16cd by Wolfgang Jeltsch at 2026-04-11T16:46:04+03:00 Drop the construction and use of `other_fopts_map` The map was only used for a single lookup, and directly performing the lookup in the original list is faster than constructing the map and then performing the lookup in the map. - - - - - 1 changed file: - compiler/GHC/Unit/Finder.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -206,7 +206,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) + | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where @@ -214,10 +214,8 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = module_home_units = M.findWithDefault Set.empty mod_name module_name_map current_unit_id = homeUnitId <$> mhome_unit all_opts = case current_unit_id of - Nothing -> other_fopts_list - Just home_unit_id -> (home_unit_id, fopts) : other_fopts_list - - other_fopts_map = M.fromList other_fopts_list + Nothing -> other_fopts + Just home_unit_id -> (home_unit_id, fopts) : other_fopts home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -237,7 +235,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts_list) + any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg @@ -259,7 +257,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = excluded = maybe Set.empty Set.singleton {- maybe dep_providers (\u -> Set.insert u dep_providers) -} current_unit_id in Set.toList (Set.difference candidates excluded) other_home_uids = known_other_uids ++ unknown_units - other_fopts_list = + other_fopts = [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) | uid <- other_home_uids ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e49a16cd2bc74ba3602cfae10723e3d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e49a16cd2bc74ba3602cfae10723e3d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding] Drop the construction and use of `other_fopts_map`
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding at Glasgow Haskell Compiler / GHC Commits: ca6d9764 by Wolfgang Jeltsch at 2026-04-11T16:56:30+03:00 Drop the construction and use of `other_fopts_map` The map was only used for a single lookup, and directly performing the lookup in the original list is faster than constructing the map and then performing the lookup in the map. - - - - - 1 changed file: - compiler/GHC/Unit/Finder.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -206,7 +206,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) + | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where @@ -214,10 +214,8 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = module_home_units = M.findWithDefault Set.empty mod_name module_name_map current_unit_id = homeUnitId <$> mhome_unit all_opts = case current_unit_id of - Nothing -> other_fopts_list - Just home_unit_id -> (home_unit_id, fopts) : other_fopts_list - - other_fopts_map = M.fromList other_fopts_list + Nothing -> other_fopts + Just home_unit_id -> (home_unit_id, fopts) : other_fopts home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -237,7 +235,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts_list) + any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg @@ -259,7 +257,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id in Set.toList (Set.difference candidates excluded) other_home_uids = known_other_uids ++ unknown_units - other_fopts_list = + other_fopts = [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) | uid <- other_home_uids ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca6d9764b653b3c8bd81dd08362d6e0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ca6d9764b653b3c8bd81dd08362d6e0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment] Drop the construction and use of `other_fopts_map`
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment at Glasgow Haskell Compiler / GHC Commits: e49a16cd by Wolfgang Jeltsch at 2026-04-11T16:46:04+03:00 Drop the construction and use of `other_fopts_map` The map was only used for a single lookup, and directly performing the lookup in the original list is faster than constructing the map and then performing the lookup in the map. - - - - - 1 changed file: - compiler/GHC/Unit/Finder.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -206,7 +206,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = case mb_pkg of NoPkgQual -> unqual_import ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import - | Just os <- M.lookup uid other_fopts_map -> home_pkg_import (uid, os) + | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os) | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts)) OtherPkg _ -> pkg_import where @@ -214,10 +214,8 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = module_home_units = M.findWithDefault Set.empty mod_name module_name_map current_unit_id = homeUnitId <$> mhome_unit all_opts = case current_unit_id of - Nothing -> other_fopts_list - Just home_unit_id -> (home_unit_id, fopts) : other_fopts_list - - other_fopts_map = M.fromList other_fopts_list + Nothing -> other_fopts + Just home_unit_id -> (home_unit_id, fopts) : other_fopts home_import = case mhome_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -237,7 +235,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts_list) + any_home_import = foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg @@ -259,7 +257,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = excluded = maybe Set.empty Set.singleton {- maybe dep_providers (\u -> Set.insert u dep_providers) -} current_unit_id in Set.toList (Set.difference candidates excluded) other_home_uids = known_other_uids ++ unknown_units - other_fopts_list = + other_fopts = [ (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue))) | uid <- other_home_uids ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e49a16cd2bc74ba3602cfae10723e3d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e49a16cd2bc74ba3602cfae10723e3d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment] 2 commits: Consider also `ModuleNodeFixed` nodes for the cache
by Wolfgang Jeltsch (＠jeltsch) 11 Apr '26

11 Apr '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/more-efficient-home-unit-imports-finding.jeltsch-experiment at Glasgow Haskell Compiler / GHC Commits: da4c4d9f by Wolfgang Jeltsch at 2026-04-11T16:23:36+03:00 Consider also `ModuleNodeFixed` nodes for the cache - - - - - 261aa4e3 by Wolfgang Jeltsch at 2026-04-11T16:30:31+03:00 Experimentally exclude `dep_providers` from `excluded` - - - - - 2 changed files: - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Module/Graph.hs Changes: ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -256,7 +256,7 @@ findImportedModuleNoHsc fc fopts ue home_module_map mhome_unit mod_name mb_pkg = in Set.toList providers unknown_units = let candidates = Set.difference hpt_deps complete_units - excluded = maybe dep_providers (\u -> Set.insert u dep_providers) current_unit_id + excluded = maybe Set.empty Set.singleton {- maybe dep_providers (\u -> Set.insert u dep_providers) -} current_unit_id in Set.toList (Set.difference candidates excluded) other_home_uids = known_other_uids ++ unknown_units other_fopts_list = ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -219,22 +219,18 @@ mkHomeModuleMap nodes = ModuleNameHomeMap completeUnits providerMap where providerMap = Map.fromListWith Set.union $ [ - (ms_mod_name modSummary, Set.singleton (ms_unitid modSummary)) | - ModuleNode _ (ModuleNodeCompile modSummary) <- nodes + (moduleName, Set.singleton unitID) | + ModuleNode _ moduleNodeInfo <- nodes, + let moduleName = moduleNodeInfoModuleName moduleNodeInfo, + let unitID = moduleNodeInfoUnitId moduleNodeInfo ] completeUnits :: Set UnitId - completeUnits - = Set.fromList $ - [ - ms_unitid modSummary | - ModuleNode _ (ModuleNodeCompile modSummary) <- nodes - ] - - {-NOTE: - The matching with `ModuleNodeCompile` results in nodes with - `ModuleNodeFixed` in their info being dropped. - -} + completeUnits = Set.fromList $ + [ + moduleNodeInfoUnitId moduleNodeInfo | + ModuleNode _ moduleNodeInfo <- nodes + ] mgHomeModuleMap :: ModuleGraph -> ModuleNameHomeMap mgHomeModuleMap = mg_home_map View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91489d4ad4e9c7c134eef9089e2931… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/91489d4ad4e9c7c134eef9089e2931… You're receiving this email because of your account on gitlab.haskell.org.

1 0