August 2026 - ghc-commits

[Git][ghc/ghc] Pushed new branch wip/torsten.schmits/mwb-26-07/abstract-linkables
by Torsten Schmits (＠torsten.schmits) 03 Aug '26

03 Aug '26

Torsten Schmits pushed new branch wip/torsten.schmits/mwb-26-07/abstract-linkables at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/torsten.schmits/mwb-26-07/abs… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/jeltsch/textual-bytecode-output] 2 commits: Escape the `#`-signs in the makefile
by Wolfgang Jeltsch (＠jeltsch) 03 Aug '26

03 Aug '26

Wolfgang Jeltsch pushed to branch wip/jeltsch/textual-bytecode-output at Glasgow Haskell Compiler / GHC Commits: 021b832a by Wolfgang Jeltsch at 2026-08-03T16:20:17+03:00 Escape the `#`-signs in the makefile - - - - - 30184f3a by Wolfgang Jeltsch at 2026-08-03T16:33:11+03:00 Establish a separate shell script for normalization - - - - - 3 changed files: - testsuite/tests/show-bytecode/Makefile - testsuite/tests/show-bytecode/all.T - + testsuite/tests/show-bytecode/normalize Changes: ===================================== testsuite/tests/show-bytecode/Makefile ===================================== @@ -2,34 +2,17 @@ TOP=../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk -compile = '$(TEST_HC)' $(TEST_HC_OPTS) \ - -fbyte-code -fwrite-byte-code -no-link -show = '$(TEST_HC)' $(TEST_HC_OPTS) \ - --show-byte-code -stabilize = sed -E -e ' \ - s/_r[[:alnum:]]+/_@name_suffix@/g; \ - s/^( *hash: )[[:xdigit:]]+/\1@hash@/g; \ - s/^( *)[[:xdigit:]]+:/\1@hash@:/g; \ - s/word [[:digit:]]{2}[[:digit:]]*/word @large_word@/ \ - ' -universalize = sed -E -e ' \ - s/UInt[[:digit:]]+/UInt@word_size@/; \ - s/W[[:digit:]]+#/W@word_size@#/ \ - ' | \ - uniq -normalize = $(stabilize) | $(universalize) -# The invocation of `uniq` in `$(universalize)` is merely for collapsing -# adjacent entries of `word @large_word@`, whose number may depend on the word -# size. +compile = '$(TEST_HC)' $(TEST_HC_OPTS) -fbyte-code -fwrite-byte-code -no-link +show = '$(TEST_HC)' $(TEST_HC_OPTS) --show-byte-code show-bytecode-vanilla: $(compile) Example.hs - $(show) Example.gbc | $(normalize) + $(show) Example.gbc | ./normalize show-bytecode-breakpoints: $(compile) -fbreak-points Example.hs - $(show) Example.gbc | $(normalize) + $(show) Example.gbc | ./normalize show-bytecode-hpc: $(compile) -fhpc Example.hs - $(show) Example.gbc | $(normalize) + $(show) Example.gbc | ./normalize ===================================== testsuite/tests/show-bytecode/all.T ===================================== @@ -1,18 +1,18 @@ test( 'show-bytecode-vanilla', - extra_files(['Example.hs']), + extra_files(['Example.hs', 'normalize']), makefile_test, [] ) test( 'show-bytecode-breakpoints', - extra_files(['Example.hs']), + extra_files(['Example.hs', 'normalize']), makefile_test, [] ) test( 'show-bytecode-hpc', - extra_files(['Example.hs']), + extra_files(['Example.hs', 'normalize']), makefile_test, [] ) ===================================== testsuite/tests/show-bytecode/normalize ===================================== @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +set -e -o pipefail + +stabilize () +{ + sed -E -e ' + s/_r[[:alnum:]]+/_@name_suffix@/g + s/^( *hash: )[[:xdigit:]]+/\1@hash@/g + s/^( *)[[:xdigit:]]+:/\1@hash@:/g + s/word [[:digit:]]{2}[[:digit:]]*/word @large_word@/ + ' +} + +universalize () +{ + sed -E -e ' + s/UInt[[:digit:]]+/UInt@word_size@/ + s/W[[:digit:]]+#/W@word_size@#/ + ' | + uniq + # The invocation of `uniq` is merely for collapsing adjacent entries of + # `word @large_word@`, whose number may depend on the word size. +} + +stabilize | universalize View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c933f62aa466a1dc960925b4c40c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c933f62aa466a1dc960925b4c40c1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27557] 4 commits: Apply oneShot Monad trick to STG LintM
by Simon Peyton Jones (＠simonpj) 03 Aug '26

03 Aug '26

Simon Peyton Jones pushed to branch wip/T27557 at Glasgow Haskell Compiler / GHC Commits: 4f2a21f7 by Andreas Klebinger at 2026-08-02T22:46:46-04:00 Apply oneShot Monad trick to STG LintM - - - - - 21e4b89d by Andreas Klebinger at 2026-08-02T22:46:46-04:00 stgLint: Use a single reader env for read only arguments. - - - - - d415f38a by Alan Zimmerman at 2026-08-02T22:47:27-04:00 EPA: Remove LocatedP from CType The next step of removing use of LocatedP by moving the AnnPragma for CType into its TTG extension point instead. - - - - - a7622111 by Simon Peyton Jones at 2026-08-03T13:50:08+01:00 Fix three bugs related to required type args and INLINE pragmas * `GHC.Core.Opt.Arity.mkEtaForAllMCo` got the visibility flags back to front, leading to a Lint error (#27557) * The arity in an InlineSaturation is the VisArity not the Arity; the two can differ when we have "required" type arguments. This made the INLINE pragma argument counting go wrong in `makeCorePair` (#27590). * When a simple binding has a type signature, we take special path in `tcPolyCheck`, leading to an outer `AbsBinds` that has no dictionaries, even when the binding is in fact overloaded. That confused the inline-arity computation in `makeCorePair` (#27589). The latter two are fixed using the new function `GHC.HsToCore.Binds.findSatArity`. That actually simplifies the API of `makeCorePair`, which is nice. The first bug is fixed by swapping the visiblity flags in `GHC.Core.Opt.Arity.mkEtaForAllMCo` Getting the INLINE behaviour right led to some perf changes: * Runtime /halved/ on T7954 due to better specialisation * Compile time increased by 6% in T21839c because a bit more inlining happened, as it always should have done. Geometric mean effect on our compile time benchmarks is +0.1%. Metric Decrease: T7954 Metric Increase: T21839c - - - - - 26 changed files: - + changelog.d/T27557 - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Types/Arity.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Types/Var.hs - libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - + testsuite/tests/simplCore/should_compile/T27589.hs - + testsuite/tests/simplCore/should_compile/T27589.stderr - + testsuite/tests/simplCore/should_compile/T27590.hs - + testsuite/tests/simplCore/should_compile/T27590.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T27557.hs - testsuite/tests/typecheck/should_compile/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== changelog.d/T27557 ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27577 #27589 #27590 +mrs: !16433 +synopsis: + Fix three bugs around INLINE pragmas +description: + One bug (#25777) gave a Lint error. The other two were lurking but un-reported; + they showed up when fixing the first ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2370,11 +2370,15 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco | otherwise -> mk_fco (mkRepReflCo ty) MCo co -> mk_fco co where - mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) + mk_fco co = MCo (mkForAllCo tcv coreTyLamForAllTyFlag vis MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] -- in GHC.Core.TyCo.Rep + -- + -- Orientation: remember, the output of mkEtaForAllCo goes into an `EI bs mco`, + -- and is SymCo'd in `etaInfoAbs`. Hence the orientation of the visibility + -- flags. A bit of a brain-strain (#27557). {- ************************************************************************ ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1583,7 +1583,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO -type instance Anno (CType (GhcPass p)) = SrcSpanAnnP +type instance Anno (CType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1687,10 +1687,11 @@ isSingletonMatchGroup matches | otherwise = False -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +matchGroupVisArity :: MatchGroup (GhcPass id) body -> VisArity -- This is called before type checking, when mg_arg_tys is not set -matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] -matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) +-- Returns the "visible arity" of the MatchGroup i.e. including required type arguments. +matchGroupVisArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] +matchGroupVisArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -69,7 +69,7 @@ import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Var( EvVar, mkLocalVar ) +import GHC.Types.Var( EvVar, mkLocalVar, isRuntimePiTyBinder ) import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Unique.Set( nonDetEltsUniqSet ) @@ -196,7 +196,7 @@ dsHsBind dflags (VarBind { var_id = var = do { core_expr <- dsLExpr expr -- Dictionary bindings are always VarBinds, -- so we only need do this here - ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + ; let core_bind@(id,_) = makeCorePair dflags var False core_expr force_var = if xopt LangExt.Strict dflags then [id] else [] @@ -211,11 +211,11 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun ; let body' = mkOptTickBox tick body rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + core_binds@(id,_) = makeCorePair dflags fun False rhs force_var -- Bindings are strict when -XStrict is enabled | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas + , matchGroupVisArity matches == 0 -- no need to force lambdas = [id] | isBangedHsBind b = [id] @@ -303,7 +303,7 @@ dsAbsBinds dflags tyvars dicts exports ; let global_id' = addIdSpecialisations global_id rules main_bind = makeCorePair dflags global_id' (isDefaultMethod prags) - (dictArity dicts) rhs + rhs ; return (force_vars', fromOL spec_binds ++ [main_bind]) } } @@ -386,7 +386,7 @@ dsAbsBinds dflags tyvars dicts exports mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id `orElse` lcl_id in - makeCorePair dflags lcl_w_inline False 0 rhs + makeCorePair dflags lcl_w_inline False rhs inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with -- the inline pragma from the source @@ -437,9 +437,9 @@ dsAbsBinds dflags tyvars dicts exports -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` -- using this information. ------------------------ -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr +makeCorePair :: DynFlags -> Id -> Bool -> CoreExpr -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs +makeCorePair dflags gbl_id is_default_method rhs | is_default_method -- Default methods are *always* inlined -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) @@ -456,22 +456,43 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs inline_prag = idInlinePragma gbl_id inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs inline_pair - | AppliedToAtLeast arity <- inlinePragmaSaturation inline_prag + | AppliedToAtLeast vis_arity <- inlinePragmaSaturation inline_prag -- Add an Unfolding for an INLINE (but not for NOINLINE) -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity passed to mkInlineUnfoldingWithArity - -- must take account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs - , etaExpand real_arity rhs) + , let runtime_arity = findSatArity vis_arity (idType gbl_id) + -- NB: runtime_arity: the arity passed to mkInlineUnfoldingWithArity + -- must take account of dictionaries and required type args + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc + runtime_arity rhs + , etaExpand runtime_arity rhs) | otherwise = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts +findSatArity :: VisArity -> Type -> Arity +-- Given the VisArity, find the value Arity of the function. +-- This is the number of runtime-value arguments the function must be applied +-- to before the INLINE pragma fires and inlines the function +-- We must: +-- add one for each invisible dictionary arg; and +-- subtract one for each required type argment +findSatArity vis_arity ty + = go vis_arity pi_bndrs + where + (pi_bndrs, _) = splitPiTys ty + + go vis_arity (bndr : bndrs) + | isInvisiblePiTyBinder bndr = add_bndr bndr (go vis_arity bndrs) + | vis_arity == 0 = 0 + | otherwise = add_bndr bndr (go (vis_arity-1) bndrs) + go vis_arity [] + | vis_arity == 0 = 0 + | otherwise = pprPanic "findSatArity" (ppr vis_arity $$ ppr ty) + + add_bndr :: PiTyBinder -> Arity -> Arity + add_bndr bndr ar | isRuntimePiTyBinder bndr = ar+1 + | otherwise = ar {- Note [Desugaring AbsBinds] ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -737,21 +737,21 @@ Call @match@ with all of this information! -- There are three possible cases for matchWrapper's scrutinees argument: -- -- 1. Nothing Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee --- The MatchGroup may have matchGroupArity of 0 or more. Examples: --- f p1 q1 = ... -- matchGroupArity 2 +-- The MatchGroup may have matchGroupVisArity of 0 or more. Examples: +-- f p1 q1 = ... -- matchGroupVisArity 2 -- f p2 q2 = ... -- -- \cases | g1 -> ... -- matchGroupArity 0 -- | g2 -> ... -- -- 2. Just [e] Used for HsCase, RecordUpd; exactly one scrutinee --- The MatchGroup has matchGroupArity of exactly 1. Example: --- case e of p1 -> e1 -- matchGroupArity 1 +-- The MatchGroup has matchGroupVisArity of exactly 1. Example: +-- case e of p1 -> e1 -- matchGroupVisArity 1 -- p2 -> e2 -- -- 3. Just es Used for HsCmdLamCase; zero or more scrutinees -- The MatchGroup has matchGroupArity of (length es). Example: --- \cases p1 q1 -> returnA -< ... -- matchGroupArity 2 +-- \cases p1 q1 -> returnA -< ... -- matchGroupVisArity 2 -- p2 q2 -> ... matchWrapper ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -288,7 +288,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches -- We don't want to generate code for blacklisted positions -- We don't want redundant ticks on simple pattern bindings -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = matchGroupArity matches == 0 + let simple = matchGroupVisArity matches == 0 -- A binding is a "simple pattern binding" if it is a -- funbind with zero patterns toplev = null decl_path ===================================== compiler/GHC/Parser.y ===================================== @@ -1707,15 +1707,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs | type { sL1 $1 (Nothing, mkHsOuterImplicit, $1) } -capi_ctype :: { Maybe (LocatedP (CType GhcPs)) } +capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2))) - (getSTRING $3))) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) + (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (Just (Header (getSTRINGs $2) (getSTRING $2))) + (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' - {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2))) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) + (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + Nothing (getSTRING $2)))} | { Nothing } ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn mkTyData :: SrcSpan -> Bool -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) tcdDataDefn = defn, tcdModifiers = [] })) } -mkDataDefn :: Maybe (LocatedP (CType GhcPs)) +mkDataDefn :: Maybe (LocatedA (CType GhcPs)) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) -> DataDefnCons (LConDecl GhcPs) @@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe (LocatedP (CType GhcPs)) + -> Maybe (LocatedA (CType GhcPs)) -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs , LHsType GhcPs) -> Maybe (LHsKind GhcPs) ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -92,6 +92,7 @@ be ill-typed in Core. But it must still be well-kinded! -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} module GHC.Stg.Lint ( lintStgTopBindings ) where @@ -123,6 +124,7 @@ import GHC.Unit.Module ( Module ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Control.Monad +import GHC.Exts ( oneShot ) import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) @@ -432,17 +434,40 @@ The Lint monad ************************************************************************ -} -newtype LintM a = LintM - { unLintM :: Module - -> LintFlags - -> DiagOpts -- Diagnostic options - -> StgPprOpts -- Pretty-printing options +data LintReaderEnv = LintReaderEnv + { le_mod :: !Module + , le_flags :: !LintFlags + , le_diag_opts :: !DiagOpts -- Diagnostic options + , le_ppr_opts :: !StgPprOpts -- Pretty-printing options + } + +newtype LintM a = LintM' + { unLintM :: LintReaderEnv -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope -> Bag SDoc -- Error messages so far -> (a, Bag SDoc) -- Result and error messages (if any) } - deriving (Functor) +instance Functor LintM where + fmap f (LintM m) = + LintM $ \env loc scope errs -> + case m env loc scope errs of + (a, errs') -> (f a, errs') + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE LintM #-} +pattern LintM :: (LintReaderEnv + -> [LintLocInfo] + -> IdSet + -> Bag SDoc + -> (a, Bag SDoc)) + -> LintM a +pattern LintM m <- LintM' m + where + LintM m = LintM' $ oneShot (\env -> oneShot + (\loc -> oneShot + (\scope -> oneShot + (\errs -> m env loc scope errs)))) data LintFlags = LintFlags { lf_unarised :: !Bool , lf_platform :: !Platform @@ -473,14 +498,16 @@ pp_binders bs initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL platform diag_opts this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag + let !flags = LintFlags unarised platform + !env = LintReaderEnv this_mod flags diag_opts opts + (_, errs) = m env [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where - pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) + pure a = LintM $ \_env _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -489,14 +516,14 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs' +thenL m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (r, errs') -> unLintM (k r) env loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs - -> case unLintM m mod lf diag_opts opts loc scope errs of - (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs' +thenL_ m k = LintM $ \env loc scope errs + -> case unLintM m env loc scope errs of + (_, errs') -> unLintM k env loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -525,7 +552,8 @@ checkPostUnariseId id id_ty = idType id addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) +addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs + -> ((), addErr df errs msg loc) addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr diag_opts errs_so_far msg locs @@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs - -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \env loc scope errs + -> unLintM m env (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs +addInScopeVars ids m = LintM $ \env loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs + in unLintM m env loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) +getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts -getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) +getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs +checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -808,7 +808,7 @@ checkMonomorphismRestriction mbis lbinds restricted (VarBind { var_ext = x }) = dataConCantHappen x restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) - restricted_match mg = matchGroupArity mg == 0 + restricted_match mg = matchGroupVisArity mg == 0 -- No args => like a pattern binding -- Some args => a function binding ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -599,26 +599,26 @@ mkPragEnv sigs binds Nothing -> sig -- See Note [Pattern synonym inline arity] -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds + ar_env :: NameEnv VisArity + ar_env = foldr lhsBindVisArity emptyNameEnv binds -addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn +addInlinePragArity :: VisArity -> LSig GhcRn -> LSig GhcRn addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl)) addInlinePragArity _ sig = sig -add_inl_arity :: Arity -> InlinePragma GhcRn -> InlinePragma GhcRn +add_inl_arity :: VisArity -> InlinePragma GhcRn -> InlinePragma GhcRn add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE = prag `setInlinePragmaSaturation` AppliedToAtLeast ar | otherwise = prag -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind +lhsBindVisArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindVisArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupVisArity ms) +lhsBindVisArity _ env = env -- PatBind/VarBind ----------------- ===================================== compiler/GHC/Types/Arity.hs ===================================== @@ -84,7 +84,14 @@ like Haskell, there is more than one way to count those arguments. forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 * `VisArity` is the syntactic notion of arity. It is the number of /visible/ - arguments, i.e. arguments that occur visibly in the source code. + arguments, i.e. arguments that occur visibly in the source code. For example: + f1 :: forall a. a -> a + f1 x = x + f2 :: forall a -> a -> a + f2 t x = x + Both have Arity 1 because there is one /value/ argument. + But f1 has VisArity 1 while f2 has VisArity 2, becuase f2 has a required + type argument. In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, simply because we see three arguments [x,y,z]. We write (>=) rather than (==) ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,6 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) +import GHC.Parser.Annotation (AnnPragma, noAnn) {- ************************************************************************ @@ -213,11 +214,11 @@ instance Outputable CCallSpec where defaultCType :: String -> CType (GhcPass p) defaultCType = - CType (CTypeGhc NoSourceText NoSourceText) Nothing . packHText + CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) -mkCType x y m = - CType (CTypeGhc x y) m +mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType x y ann m = + CType (CTypeGhc x y ann) m typeCheckCType :: CType GhcRn -> CType GhcTc typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z @@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText + , cTypeAnn :: AnnPragma } deriving (Data, Eq) @@ -349,6 +351,7 @@ instance Binary CTypeGhc where return $ CTypeGhc { cTypeSourceText = str1 , cTypeOtherText = str2 + , cTypeAnn = noAnn } instance NFData StaticTargetGhc where ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -104,7 +104,7 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Hs.Extension -import GHC.Types.Arity (Arity) +import GHC.Types.Arity (VisArity) import GHC.Types.SourceText (SourceText(..)) import GHC.Utils.Binary import GHC.Utils.Outputable @@ -125,12 +125,13 @@ infixl 1 `setInlinePragmaActivation`, -- | The arity /at which to/ inline a function. -- This may differ from the function's syntactic arity. data InlineSaturation - = AppliedToAtLeast !Arity + = AppliedToAtLeast !VisArity -- ^ Inline only when applied to @n@ explicit - -- (non-type, non-dictionary) arguments. + -- (required type or value) arguments. -- -- That is, 'AppliedToAtLeast' describes the number of -- *source-code* arguments the thing must be applied to. + | AnySaturation -- ^ There does not exist an explicit number of arguments -- that the inlining process should be applied to. ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -82,7 +82,7 @@ module GHC.Types.Var ( -- * PiTyBinder PiTyBinder(..), PiTyVarBinder, isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder, - isVisiblePiTyBinder, + isVisiblePiTyBinder, isRuntimePiTyBinder, isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -757,7 +757,12 @@ instance NamedThing tv => NamedThing (VarBndr tv flag) where -- not. See Note [PiTyBinders] data PiTyBinder = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag - | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- Erased (not passed at runtime) if the binder is + -- a type variable; not erased if coercion variable + + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder, passing a runtime value + -- The argument can be a constraint (incl dictionary) + -- or an ordinary value -- The arrow is described by the FunTyFlag deriving Data @@ -792,6 +797,12 @@ namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv namedPiTyBinder_maybe _ = Nothing +isRuntimePiTyBinder :: PiTyBinder -> Bool +isRuntimePiTyBinder (Anon {}) = True -- Always passed at runtime +isRuntimePiTyBinder (Named (Bndr tcv _)) = isCoVar tcv + -- isCoVar: see Note [Why ForAllTy can quantify over a coercion variable] + -- and Note [Unused coercion variable in ForAllTy], in GHC.Core.TyCo.Rep + -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. isAnonPiTyBinder :: PiTyBinder -> Bool @@ -817,7 +828,7 @@ piTyBinderType (Named (Bndr tv _)) = varType tv piTyBinderType (Anon ty _) = scaledThing ty {- Note [PiTyBinders] -~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ But a type like forall a. Maybe a -> forall b. (a,b) -> b @@ -830,14 +841,18 @@ argument to a Pi-type. GHC Core currently supports two different Pi-types: * Anon ty1 fun_flag: a non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. + + See wrinkle (PIT1) + + These are lifted to Coercions with the corresponding FunCo. + + * Named (Var tcv forall_flag): a dependent polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty - * Named (Var tv forall_flag) - A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty + See wrinkle (PIT2) Both forms of Pi-types classify terms/types that take an argument. In other words, if `x` is either a function or a polytype, `x arg` makes sense @@ -845,12 +860,16 @@ words, if `x` is either a function or a polytype, `x arg` makes sense Wrinkles -* The Anon constructor of PiTyBinder contains a FunTyFlag. Since +(PIT1) The Anon constructor of PiTyBinder contains a FunTyFlag. Since the PiTyBinder really only describes the /argument/ it should perhaps only have a TypeOrConstraint rather than a full FunTyFlag. But it's very convenient to have the full FunTyFlag, say in mkPiTys, so that's what we do. +(PIT2) The `tcv` in `Named (Var tcv forall_flag) is usually a type variable + but can exceptionally be a coercion variable: see + Note [Why ForAllTy can quantify over a coercion variable]. + If it's a type variable it will be erased; if coercion variable it will not. Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr ===================================== @@ -43,17 +43,17 @@ fusionElemFilter jump go1 eta fusionNotElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> True; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> False }; @@ -62,20 +62,20 @@ fusionNotElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionElemConcatMap - = \ x x1 -> + = \ x eta -> joinrec { go1 ds = case ds of { [] -> False; : y ys -> - case y of { I# x2 -> - case x of { I# x3 -> - case ==# x3 (+# x2 1#) of { + case y of { I# x1 -> + case x of { I# x2 -> + case ==# x2 (+# x1 1#) of { __DEFAULT -> - case ==# x3 (+# x2 2#) of { + case ==# x2 (+# x1 2#) of { __DEFAULT -> jump go1 ys; 1# -> True }; @@ -84,7 +84,7 @@ fusionElemConcatMap } } }; } in - jump go1 x1 + jump go1 eta fusionNotElemMap = \ x eta -> ===================================== testsuite/tests/simplCore/should_compile/T27589.hs ===================================== @@ -0,0 +1,9 @@ +module T28589 where + +wombat :: Num a => a -> a +{-# INLINE wombat #-} +wombat x = x+x*x + +g :: Num a => [a] -> [a] +g ys = map wombat ys + -- wombat should not inline here ===================================== testsuite/tests/simplCore/should_compile/T27589.stderr ===================================== @@ -0,0 +1,3 @@ +wombat [InlPrag=INLINE (sat-args=1)] :: forall a. Num a => a -> a +wombat + map @a @a (wombat @a $dNum) ys ===================================== testsuite/tests/simplCore/should_compile/T27590.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module Foo where + +wombat :: forall a -> a -> Maybe a +{-# INLINE wombat #-} +wombat t x = Just x + +g y = wombat Int (y+y) + -- wombat /should/ inline here ===================================== testsuite/tests/simplCore/should_compile/T27590.stderr ===================================== @@ -0,0 +1,2 @@ +wombat [InlPrag=INLINE (sat-args=2)] :: forall a -> a -> Maybe a +wombat ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -609,3 +609,5 @@ test('T4081', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-a test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O']) test('T27296', [], makefile_test, ['T27296']) test('T27296b', [], makefile_test, ['T27296b']) +test('T27589', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) +test('T27590', [grep_errmsg(r'wombat')], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques']) ===================================== testsuite/tests/typecheck/should_compile/T27557.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module RequiredTypeArgumentsMkSymCo where + +import Data.Kind (Type) + +f :: forall a . forall (b :: Type) -> a -> a +f t = id +{-# INLINE f #-} ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -968,4 +968,4 @@ test('T24464', normal, compile, ['']) test('ExpansionQLIm', normal, compile, ['']) test('T23135', normal, compile, ['']) test('LazyFieldAnnotations', normal, compile, ['']) - +test('T27557', normal, compile, ['']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -4401,13 +4401,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where -- --------------------------------------------------------------------- -instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance Typeable p => ExactPrint (CType (GhcPass p)) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do + exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext + AnnPragma o c s l1 l2 t m = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4415,7 +4416,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct)) + return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -837,7 +837,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA -type instance Anno (CType DocNameI) = EpAnn AnnPragma +type instance Anno (CType DocNameI) = SrcSpanAnnA type instance Anno (Header DocNameI) = EpAnn AnnPragma type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a8449cc16f332bb1165d0a7fdd49… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/40a8449cc16f332bb1165d0a7fdd49… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-data] StgToCmm: force unknown data pointers through stg_enter_data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC Commits: 75d4e387 by Sebastian Graf at 2026-08-03T13:18:41+02:00 StgToCmm: force unknown data pointers through stg_enter_data emitEnter's Return case entered the closure unconditionally, so a pointer that is tagged already got entered anyway. It now jumps to stg_enter_data, a new RTS stub that tests the tag first. See Note [Forcing an unknown data pointer] in rts/Apply.cmm. Implements #27594, unblocks #23173. nofib imaginary+spectral is a wash: allocations unchanged, instructions +0.07% geometric mean, compile time unchanged. - - - - - 5 changed files: - + changelog.d/27594 - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== changelog.d/27594 ===================================== @@ -0,0 +1,8 @@ +section: codegen +synopsis: Tagged data pointers are no longer entered when forced in tail position +issues: #27594 +mrs: !16445 +description: + Forcing a data pointer of statically unknown form in tail position now goes + through the new RTS stub ``stg_enter_data``, which returns the pointer if it + is tagged already. ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -36,6 +36,8 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,22 +1192,14 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. + -- For a return we jump to stg_enter_data, which returns an already + -- tagged pointer to our caller and enters an untagged one. + -- See Note [Forcing an unknown data pointer] in rts/Apply.cmm. Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -47,6 +47,31 @@ import CLOSURE stg_apply_interp_info; import CLOSURE stg_restore_cccs_eval_info; #endif +/* Note [Forcing an unknown data pointer] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * stg_enter_data forces a pointer to a thunk, a constructor, or an + * indirection to one, and returns the result to the caller's continuation. + * emitEnter (GHC.StgToCmm.Expr) jumps here for the pointers getCallMethod + * classifies as EnterIt: lifted ones whose type rules out functions, so + * whether they are forced already is unknown until the tag is tested. + * + * The stub is stg_ap_0_fast specialised to that domain, where its + * FUN/PAP/BCO arms are unreachable and an indirection's own entry code + * follows the indirection. What remains is the tag test and an entry jump. + * + * Whether the pointer turns out to be tagged decides which way a program moves: + * nofib imaginary+spectral is a wash overall, with primetest and exact-reals a + * percent faster and fft2 and fft a percent slower. + */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + /* ---------------------------------------------------------------------------- * Evaluate a closure and return it. * ===================================== rts/RtsSymbols.c ===================================== @@ -842,6 +842,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -300,6 +300,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75d4e38727ee604623cc8f488926522… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75d4e38727ee604623cc8f488926522… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-data] StgToCmm: evaluate in tail position through stg_enter_data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC Commits: ad8cf2db by Sebastian Graf at 2026-08-03T12:14:11+02:00 StgToCmm: evaluate in tail position through stg_enter_data Evaluating a value of unknown form in tail position jumps to its entry code unconditionally, so a value already in normal form is entered anyway. Enforcing that the entry code of a taggable normal form is unreachable (#23173) requires testing the tag here, as the AssignTo case already does. Add stg_enter_data and jump to it, rather than open-coding the test at every call site. The stub is stg_ap_0_fast specialised to the domain getCallMethod reaches with EnterIt, values whose type rules out functions: the FUN/PAP/BCO arms are unreachable there and an indirection's entry code follows the indirection, so the closure-type load and switch are dead. emitEnter's Return case becomes a single jump. nofib imaginary+spectral, both sides built with -fproc-alignment=64: allocations bit-identical, instructions +0.07% geometric mean, compile time unchanged. Cycles move in both directions by up to 1.5%, depending on whether a program's tail evaluations usually find a value or a thunk. - - - - - 4 changed files: - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -36,6 +36,8 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,22 +1192,16 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. + -- For a return we jump to stg_enter_data, which returns a tagged + -- (hence evaluated) value to our caller and enters an untagged + -- closure. getCallMethod picks EnterIt only for values whose type + -- rules out functions, which is what that stub is specialised to. + -- See Note [Evaluating a value in tail position] in rts/Apply.cmm. Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -47,6 +47,55 @@ import CLOSURE stg_apply_interp_info; import CLOSURE stg_restore_cccs_eval_info; #endif +/* Note [Evaluating a value in tail position] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * stg_enter_data evaluates a closure that is a thunk, a constructor, or an + * indirection to one, and returns it to the caller's continuation. This is + * stg_ap_0_fast (below) specialised to that domain: the FUN/PAP/BCO arms of + * the generic evaluation are unreachable there, and an indirection's own + * entry code follows the indirection, so what remains is the tag test and an + * entry jump. emitEnter (GHC.StgToCmm.Expr) jumps here for a tail evaluation, + * which getCallMethod reaches only for values whose type rules out functions. + * + * Three shapes evaluate such a value. Measured on nofib imaginary+spectral + * (74 benchmarks, cachegrind instruction counts, both sides built with + * -fproc-alignment=64 so that code placement is held fixed): + * + * - Enter unconditionally, reading the entry code out of the closure. This + * reaches the entry code of an evaluated value, which the enter-taggable + * invariant rules out. It also costs a load of the info pointer feeding + * an indirect jump, plus the entry code's own indirect jump to the + * continuation, whenever the value is already evaluated. + * - Jump to stg_ap_0_fast. Adds a load of the closure type and a + * bounds-checked switch on it, both dead on this domain: +0.19% + * instructions over this stub. + * - Jump to this stub. +0.07% instructions over entering unconditionally, + * allocations unchanged. The tag test mostly fails, because values whose + * tag is statically known are routed to InferedReturnIt by tag inference + * before they reach here, leaving mostly genuine thunks: fft2 +0.36%, + * fft +0.24%. + * + * Cycles move in both directions and by more than the instruction counts, + * because what the test replaces is a load feeding an indirect jump rather + * than straight-line work. Where the value is usually evaluated, primetest + * runs -1.5% and exact-reals -1.0%; where it is usually a thunk, fft2 runs + * +0.9% and fft +0.4%. + * + * The stub keeps the test out of the code generator's per-site output. Open + * coding it at each call site costs a temporary, two basic blocks and an + * explicit return there, which compiling T13960 pays for at around +3% + * allocations; through the stub the compiler emits one jump, as it did when + * it entered unconditionally. + */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + /* ---------------------------------------------------------------------------- * Evaluate a closure and return it. * ===================================== rts/RtsSymbols.c ===================================== @@ -842,6 +842,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -300,6 +300,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad8cf2dbfbf2ca108ac166927a9a665… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ad8cf2dbfbf2ca108ac166927a9a665… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-data] StgToCmm: force unknown data pointers through stg_enter_data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC Commits: 997af5dc by Sebastian Graf at 2026-08-03T13:10:44+02:00 StgToCmm: force unknown data pointers through stg_enter_data emitEnter's Return case entered the closure unconditionally, so a pointer that is tagged already got entered anyway. It now jumps to stg_enter_data, a new RTS stub that tests the tag first. See Note [Forcing an unknown data pointer] in rts/Apply.cmm. Implements #27594, unblocks #23173. nofib imaginary+spectral is a wash: allocations unchanged, instructions +0.07% geometric mean, compile time unchanged. - - - - - 4 changed files: - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -36,6 +36,8 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,22 +1192,14 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. + -- For a return we jump to stg_enter_data, which returns an already + -- tagged pointer to our caller and enters an untagged one. + -- See Note [Forcing an unknown data pointer] in rts/Apply.cmm. Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -47,6 +47,31 @@ import CLOSURE stg_apply_interp_info; import CLOSURE stg_restore_cccs_eval_info; #endif +/* Note [Forcing an unknown data pointer] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * stg_enter_data forces a pointer to a thunk, a constructor, or an + * indirection to one, and returns the result to the caller's continuation. + * emitEnter (GHC.StgToCmm.Expr) jumps here for the pointers getCallMethod + * classifies as EnterIt: lifted ones whose type rules out functions, so + * whether they are forced already is unknown until the tag is tested. + * + * The stub is stg_ap_0_fast specialised to that domain, where its + * FUN/PAP/BCO arms are unreachable and an indirection's own entry code + * follows the indirection. What remains is the tag test and an entry jump. + * + * Whether the pointer turns out to be tagged decides which way a program moves: + * nofib imaginary+spectral is a wash overall, with primetest and exact-reals a + * percent faster and fft2 and fft a percent slower. + */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + /* ---------------------------------------------------------------------------- * Evaluate a closure and return it. * ===================================== rts/RtsSymbols.c ===================================== @@ -842,6 +842,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -300,6 +300,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/997af5dcbf190a2f0c6777b369762f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/997af5dcbf190a2f0c6777b369762f5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sg/enter-data] StgToCmm: evaluate in tail position through stg_enter_data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed to branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC Commits: c62264d2 by Sebastian Graf at 2026-08-03T13:02:40+02:00 StgToCmm: evaluate in tail position through stg_enter_data emitEnter's Return case jumped to the closure's entry code unconditionally, entering pointers that are forced already, unlike the sibling AssignTo case which tests the tag inline. Implement the design from #27594: test the tag in a shared RTS stub and jump to it, which also unblocks #23173. stg_enter_data is stg_ap_0_fast specialised to the domain getCallMethod reaches with EnterIt, lifted pointers whose type rules out functions: the FUN/PAP/BCO arms are unreachable there and an indirection's entry code follows the indirection, so the closure-type load and the switch on it are dead. emitEnter's Return case becomes a single jump. Measured on nofib imaginary+spectral, both sides built with -fproc-alignment=64 to work around non-deterministic loop header alignment effects: allocations unchanged on all 74 benchmarks, instructions +0.07% geometric mean, compile time unchanged. Instruction count is the wrong metric here. The tag test mostly fails, because tag inference already routes statically known pointers to InferedReturnIt, so what reaches EnterIt is mostly genuine thunks where the test is an extra jump and branch. Where it succeeds it replaces a load feeding an indirect jump, which cycle counts see and instruction counts do not: primetest -1.5% and exact-reals -1.0% cycles at flat instruction counts, against fft2 +0.9% and fft +0.4%. Emitting the test at each call site instead costs a temporary, two basic blocks and an explicit return per site, and makes the compiler allocate 3% more on T13960. - - - - - 4 changed files: - compiler/GHC/StgToCmm/Expr.hs - rts/Apply.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h Changes: ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -36,6 +36,8 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit ) +import GHC.Cmm.CLabel ( mkCmmCodeLabel ) +import GHC.Unit ( rtsUnitId ) import GHC.Platform.Tag ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon @@ -1190,22 +1192,14 @@ emitEnter fun = do ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff - ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig ; case sequel of - -- For a return, we have the option of generating a tag-test or - -- not. If the value is tagged, we can return directly, which - -- is quicker than entering the value. This is a code - -- size/speed trade-off: when optimising for speed rather than - -- size we could generate the tag test. - -- - -- Right now, we do what the old codegen did, and omit the tag - -- test, just generating an enter. + -- For a return we jump to stg_enter_data, which returns an already + -- tagged pointer to our caller and enters an untagged one. + -- See Note [Forcing an unknown data pointer] in rts/Apply.cmm. Return -> do - { let entry = entryCode platform - $ closureInfoPtr platform align_check - $ CmmReg (nodeReg platform) - ; emit $ mkJump profile NativeNodeCall entry - [cmmUntag platform fun] updfr_off + { let enter_data = CmmLit (CmmLabel + (mkCmmCodeLabel rtsUnitId (fsLit "stg_enter_data"))) + ; emit $ mkJump profile NativeNodeCall enter_data [fun] updfr_off ; return AssignedDirectly } ===================================== rts/Apply.cmm ===================================== @@ -47,6 +47,31 @@ import CLOSURE stg_apply_interp_info; import CLOSURE stg_restore_cccs_eval_info; #endif +/* Note [Forcing an unknown data pointer] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * stg_enter_data forces a pointer to a thunk, a constructor, or an + * indirection to one, and returns the result to the caller's continuation. + * emitEnter (GHC.StgToCmm.Expr) jumps here for the pointers getCallMethod + * classifies as EnterIt: lifted ones whose type rules out functions, so + * whether they are forced already is unknown until the tag is tested. + * + * The stub is stg_ap_0_fast specialised to that domain, where its + * FUN/PAP/BCO arms are unreachable and an indirection's own entry code + * follows the indirection. What remains is the tag test and an entry jump. + * + * Whether the pointer turns out to be tagged decides which way a program moves: + * nofib imaginary+spectral is a wash overall, with primetest and exact-reals a + * percent faster and fft2 and fft a percent slower. + */ + +stg_enter_data ( P_ x ) +{ + if (GETTAG(x) != 0) { + return (x); + } + jump %GET_ENTRY(x) (x); +} + /* ---------------------------------------------------------------------------- * Evaluate a closure and return it. * ===================================== rts/RtsSymbols.c ===================================== @@ -842,6 +842,7 @@ extern char **environ; SymI_HasDataProto(stg_ap_ppppp_info) \ SymI_HasDataProto(stg_ap_pppppp_info) \ SymI_HasDataProto(stg_ap_0_fast) \ + SymI_HasDataProto(stg_enter_data) \ SymI_HasDataProto(stg_ap_v_fast) \ SymI_HasDataProto(stg_ap_f_fast) \ SymI_HasDataProto(stg_ap_d_fast) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -300,6 +300,7 @@ RTS_RET(stg_ap_ppppp); RTS_RET(stg_ap_pppppp); RTS_FUN_DECL(stg_ap_0_fast); +RTS_FUN_DECL(stg_enter_data); RTS_FUN_DECL(stg_ap_v_fast); RTS_FUN_DECL(stg_ap_f_fast); RTS_FUN_DECL(stg_ap_d_fast); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c62264d2ad17abb7fb8ce7ca8d91aa0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c62264d2ad17abb7fb8ce7ca8d91aa0… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/26300] Check external dependencies and home units for duplicates
by Hannes Siebenhandl (＠fendor) 03 Aug '26

03 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC Commits: 8fe49ece by fendor at 2026-08-03T12:39:30+02:00 Check external dependencies and home units for duplicates - - - - - 16 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - + testsuite/tests/ghci/T26300/Makefile - + testsuite/tests/ghci/T26300/T26300.script - + testsuite/tests/ghci/T26300/T26300.stderr - + testsuite/tests/ghci/T26300/T26300.stdout - + testsuite/tests/ghci/T26300/a/Main.hs - + testsuite/tests/ghci/T26300/all.T - + testsuite/tests/ghci/T26300/b/Bar.hs - + testsuite/tests/ghci/T26300/b/Data/List.hs - + testsuite/tests/ghci/T26300/c/Bar.hs - + testsuite/tests/ghci/T26300/unitA - + testsuite/tests/ghci/T26300/unitB - + testsuite/tests/ghci/T26300/unitC Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -240,7 +240,9 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst -> vcat (map pprMod mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + unambiguousPackage (Just xs) (m, ExternalUnitOrigin (ModOrigin (Just _) _ _ _)) + = Just (moduleUnit m : xs) + unambiguousPackage (Just xs) (m, HomeOrigin{}) = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing GenericMissing pkg_hiddens mod_hiddens unusables files -> @@ -251,9 +253,16 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + + pprOrigin m HomeOrigin = pprHomeOrigin m + pprOrigin m (ExternalUnitOrigin o) = pprExtOrigin m o + + pprHomeOrigin m = + text "package" <+> ppr (moduleUnit m) + + pprExtOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprExtOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprExtOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True then [text "package" <+> ppr (moduleUnit m)] else [] ++ ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Iface.Errors.Types ( , ReadInterfaceError(..) , CantFindInstalled(..) , CantFindInstalledReason(..) + , HomeOrExternalOrigin(..) , FindingModuleOrInterface(..) , BuildingCabalPackage(..) @@ -75,9 +76,13 @@ data CantFindInstalledReason | GenericMissing [UnitInfo] [Unit] [UnusableUnit] [FilePath] - | MultiplePackages [(Module, ModuleOrigin)] + | MultiplePackages [(Module, HomeOrExternalOrigin)] deriving Generic +data HomeOrExternalOrigin + = HomeOrigin + | ExternalUnitOrigin ModuleOrigin + data CantFindInstalled = CantFindInstalled ModuleName CantFindInstalledReason deriving Generic ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -78,10 +78,11 @@ import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Set (Set) -import qualified Data.Set as Set (empty, intersection, difference, null, toList) +import qualified Data.Set as Set (empty, intersection, difference, null, toList, member) import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE +import GHC.Iface.Errors.Types type FileExt = OsString -- Filename extension type BaseName = OsPath -- Basename of file @@ -247,8 +248,12 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + other_fopts = + let + (providers, others) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name + in + providers ++ others -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as @@ -263,11 +268,17 @@ findPluginModuleNoHsc -> ModuleName -> IO FindResult findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name + home_import `orIfNotFound` - findExposedPluginPackageModule fc fopts unit_state mod_name + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPluginPackageModule fc fopts unit_state mod_name + ) where + home_import = + findHomeModule fc fopts home_unit mod_name + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = @@ -291,9 +302,9 @@ findPluginModule hsc_env mod_name = do rankedHomeUnitDeps :: HomeModuleNameProvidersMap -> ModuleName -> Set UnitId - -> [UnitId] + -> ([UnitId], [UnitId]) rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps - = [] + = ([], []) -- The special handling of the situation where the dependency set is empty does -- not change the result, but it avoids triggering evaluation of the module -- graph. This is particularly important in one-shot mode, where the module @@ -309,7 +320,7 @@ rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps -- 3 | import {-# source #-} A -- | ^^^^^^^^^^^^^^^^^^^^^^^ rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps - = Set.toList cached_deps ++ Set.toList uncached_deps + = (Set.toList cached_deps, Set.toList uncached_deps) where cached_providers :: Set UnitId @@ -330,12 +341,19 @@ homeUnitDepsFinderOpts -> HomeModuleNameProvidersMap -> UnitState -- ^ unit state of the requesting home unit -> ModuleName - -> [(UnitId, FinderOpts)] + -> ([(UnitId, FinderOpts)], [(UnitId, FinderOpts)]) homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name = - [ (uid, initFinderOpts (ue_unitFlags uid ue)) - | uid <- rankedHomeUnitDeps home_module_name_providers_map mod_name + let + (providers, otherHomeUnits) = rankedHomeUnitDeps home_module_name_providers_map mod_name (homeUnitDepends unit_state) - ] + in + ( [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- providers + ] + , [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- otherHomeUnits + ] + ) -- | Search for @mod_name@ in the given home unit. findHomeUnitDepModule @@ -364,30 +382,29 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts) -- successful result. findHomeModuleAmongDeps :: FinderCache - -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) - -- Do not try to be smart and change this to `foldr orIfNotFound home_import - -- (map home_pkg_import other_fopts)`, as that would not be the same. - -- `home_import` is first because we need to first look within the current - -- unit before looking at the other units in order. +findHomeModuleAmongDeps fc ue home_module_name_providers_map mb_home_unit mod_name = + findInDirectDeps `orIfNotFound` findInOtherDeps where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + findInDirectDeps = case provider_fopts of + p:ps -> foldr1 combineFindResult (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + + findInOtherDeps = case other_fopts of + p:ps -> foldr1 orIfNotFound (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + (provider_fopts, other_fopts) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name -- | Search the home-unit graph and otherwise the regular exposed package @@ -401,10 +418,17 @@ findHomeOrRegularPackageModule -> ModuleName -> IO FindResult findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name - `orIfNotFound` - findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + case mb_home_unit of + Just home_unit -> + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + ) + Nothing -> + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual where unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue @@ -470,6 +494,40 @@ orIfNotFound this or_this = do _other -> return res2 _other -> return res +combineFindResult :: Monad m => m FindResult -> m FindResult -> m FindResult +combineFindResult this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + NoPackage{} -> pure res + FoundMultiple ms -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ ms ++ [(other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ ms ++ other_ms + NotFound{} -> pure res + Found _mod_location modl -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ [(modl, HomeOrigin), (other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ [(modl, HomeOrigin)] ++ other_ms + NotFound{} -> pure res + -- | Helper function for 'findHomeModule': this function wraps an IO action -- which would look up @mod_name@ in the file system (the home package), -- and first consults the 'hsc_FC' cache to see if the lookup has already @@ -483,8 +541,12 @@ homeSearchCache fc home_unit mod_name do_this = do findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg = - findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + findLookupResult fc fopts $ + case lookupModuleWithSuggestions units mod_name mb_pkg of + lf@(LookupFound _ (u, _)) + | unitId u `Set.member` homeUnitDepends units -> LookupNotFound [] + | otherwise -> lf + other -> other findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult findExposedPluginPackageModule fc fopts units mod_name = @@ -509,7 +571,7 @@ findLookupResult fc fopts r = case r of , fr_unusables = [] , fr_suggestions = []}) LookupMultiple rs -> - return (FoundMultiple rs) + return (FoundMultiple $ map (\ (m, o) -> (m, ExternalUnitOrigin o)) rs) LookupHidden fr_pkgs_hidden mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden @@ -588,6 +650,16 @@ mkHomeHidden uid = , fr_unusables = [] , fr_suggestions = []} +notFound :: FindResult +notFound = + NotFound { fr_paths = [] + , fr_pkg = Nothing + , fr_mods_hidden = [] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + + findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult findHomePackageModule fc fopts home_unit mod_name = do let uid = RealUnit (Definite home_unit) ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Unit.Env import GHC.Data.FastString import GHC.Types.Unique.Set +import GHC.Iface.Errors.Types (HomeOrExternalOrigin) -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for @@ -56,7 +57,7 @@ data FindResult -- ^ The module was found | NoPackage Unit -- ^ The requested unit was not found - | FoundMultiple [(Module, ModuleOrigin)] + | FoundMultiple [(Module, HomeOrExternalOrigin)] -- ^ _Error_: both in multiple packages -- | Not found ===================================== testsuite/tests/ghci/T26300/Makefile ===================================== @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: prog-mhu006a +prog-mhu006a: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db \ + -unit @unitA -unit @unitB < prog-mhu006a.script ===================================== testsuite/tests/ghci/T26300/T26300.script ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/T26300.stderr ===================================== @@ -0,0 +1,8 @@ +a/Main.hs:3:1: error: [GHC-45102] + Ambiguous module name ‘Data.List’. + it was found in multiple packages: base-4.23.0.0 b-0.0.1 + +a/Main.hs:4:1: error: [GHC-45102] + Ambiguous module name ‘Bar’. + it was found in multiple packages: c-0.0.1 b-0.0.1 + ===================================== testsuite/tests/ghci/T26300/T26300.stdout ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/a/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +import Data.List +import Bar ===================================== testsuite/tests/ghci/T26300/all.T ===================================== @@ -0,0 +1,6 @@ +test('T26300', + [extra_files(['a/', 'b/', 'c/', 'unitA', 'unitB', 'unitC']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + normalise_slashes, + req_interp], + ghci_multiunit_script, [['unitA', 'unitB', 'unitC'], 'T26300.script']) ===================================== testsuite/tests/ghci/T26300/b/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/b/Data/List.hs ===================================== @@ -0,0 +1 @@ +module Data.List where ===================================== testsuite/tests/ghci/T26300/c/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/unitA ===================================== @@ -0,0 +1,6 @@ +-i +-ia +-this-unit-id a-0.0.1 +-package-id b-0.0.1 +-package-id c-0.0.1 +Main ===================================== testsuite/tests/ghci/T26300/unitB ===================================== @@ -0,0 +1,5 @@ +-i +-ib +-this-unit-id b-0.0.1 +Data.List +Bar ===================================== testsuite/tests/ghci/T26300/unitC ===================================== @@ -0,0 +1,4 @@ +-i +-ic +-this-unit-id c-0.0.1 +Bar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fe49ecefdeb2caccc32a7fafe5add4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fe49ecefdeb2caccc32a7fafe5add4… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Pushed new branch wip/sg/enter-data
by Sebastian Graf (＠sgraf812) 03 Aug '26

03 Aug '26

Sebastian Graf pushed new branch wip/sg/enter-data at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sg/enter-data You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/fendor/26300] Check external dependencies and home units for duplicates
by Hannes Siebenhandl (＠fendor) 03 Aug '26

03 Aug '26

Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC Commits: 21fc5fe9 by fendor at 2026-08-03T12:07:35+02:00 Check external dependencies and home units for duplicates - - - - - 16 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - + testsuite/tests/ghci/T26300/Makefile - + testsuite/tests/ghci/T26300/T26300.script - + testsuite/tests/ghci/T26300/T26300.stderr - + testsuite/tests/ghci/T26300/T26300.stdout - + testsuite/tests/ghci/T26300/a/Main.hs - + testsuite/tests/ghci/T26300/all.T - + testsuite/tests/ghci/T26300/b/Bar.hs - + testsuite/tests/ghci/T26300/b/Data/List.hs - + testsuite/tests/ghci/T26300/c/Bar.hs - + testsuite/tests/ghci/T26300/unitA - + testsuite/tests/ghci/T26300/unitB - + testsuite/tests/ghci/T26300/unitC Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -240,7 +240,9 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst -> vcat (map pprMod mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + unambiguousPackage (Just xs) (m, ExternalUnitOrigin (ModOrigin (Just _) _ _ _)) + = Just (moduleUnit m : xs) + unambiguousPackage (Just xs) (m, HomeOrigin{}) = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing GenericMissing pkg_hiddens mod_hiddens unusables files -> @@ -251,9 +253,16 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + + pprOrigin m HomeOrigin = pprHomeOrigin m + pprOrigin m (ExternalUnitOrigin o) = pprExtOrigin m o + + pprHomeOrigin m = + text "package" <+> ppr (moduleUnit m) + + pprExtOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprExtOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprExtOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True then [text "package" <+> ppr (moduleUnit m)] else [] ++ ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Iface.Errors.Types ( , ReadInterfaceError(..) , CantFindInstalled(..) , CantFindInstalledReason(..) + , HomeOrExternalOrigin(..) , FindingModuleOrInterface(..) , BuildingCabalPackage(..) @@ -75,9 +76,13 @@ data CantFindInstalledReason | GenericMissing [UnitInfo] [Unit] [UnusableUnit] [FilePath] - | MultiplePackages [(Module, ModuleOrigin)] + | MultiplePackages [(Module, HomeOrExternalOrigin)] deriving Generic +data HomeOrExternalOrigin + = HomeOrigin + | ExternalUnitOrigin ModuleOrigin + data CantFindInstalled = CantFindInstalled ModuleName CantFindInstalledReason deriving Generic ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -78,10 +78,11 @@ import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Set (Set) -import qualified Data.Set as Set (empty, intersection, difference, null, toList) +import qualified Data.Set as Set (empty, intersection, difference, null, toList, member) import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE +import GHC.Iface.Errors.Types type FileExt = OsString -- Filename extension type BaseName = OsPath -- Basename of file @@ -247,8 +248,12 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + other_fopts = + let + (providers, others) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name + in + providers ++ others -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as @@ -263,11 +268,17 @@ findPluginModuleNoHsc -> ModuleName -> IO FindResult findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name + home_import `orIfNotFound` - findExposedPluginPackageModule fc fopts unit_state mod_name + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPluginPackageModule fc fopts unit_state mod_name + ) where + home_import = + findHomeModule fc fopts home_unit mod_name + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = @@ -291,9 +302,9 @@ findPluginModule hsc_env mod_name = do rankedHomeUnitDeps :: HomeModuleNameProvidersMap -> ModuleName -> Set UnitId - -> [UnitId] + -> ([UnitId], [UnitId]) rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps - = [] + = ([], []) -- The special handling of the situation where the dependency set is empty does -- not change the result, but it avoids triggering evaluation of the module -- graph. This is particularly important in one-shot mode, where the module @@ -309,7 +320,7 @@ rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps -- 3 | import {-# source #-} A -- | ^^^^^^^^^^^^^^^^^^^^^^^ rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps - = Set.toList cached_deps ++ Set.toList uncached_deps + = (Set.toList cached_deps, Set.toList uncached_deps) where cached_providers :: Set UnitId @@ -330,12 +341,19 @@ homeUnitDepsFinderOpts -> HomeModuleNameProvidersMap -> UnitState -- ^ unit state of the requesting home unit -> ModuleName - -> [(UnitId, FinderOpts)] + -> ([(UnitId, FinderOpts)], [(UnitId, FinderOpts)]) homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name = - [ (uid, initFinderOpts (ue_unitFlags uid ue)) - | uid <- rankedHomeUnitDeps home_module_name_providers_map mod_name + let + (providers, otherHomeUnits) = rankedHomeUnitDeps home_module_name_providers_map mod_name (homeUnitDepends unit_state) - ] + in + ( [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- providers + ] + , [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- otherHomeUnits + ] + ) -- | Search for @mod_name@ in the given home unit. findHomeUnitDepModule @@ -364,30 +382,29 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts) -- successful result. findHomeModuleAmongDeps :: FinderCache - -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) - -- Do not try to be smart and change this to `foldr orIfNotFound home_import - -- (map home_pkg_import other_fopts)`, as that would not be the same. - -- `home_import` is first because we need to first look within the current - -- unit before looking at the other units in order. +findHomeModuleAmongDeps fc ue home_module_name_providers_map mb_home_unit mod_name = + findInDirectDeps `orIfNotFound` findInOtherDeps where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + findInDirectDeps = case provider_fopts of + p:ps -> foldr1 combineFindResult (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + + findInOtherDeps = case other_fopts of + p:ps -> foldr1 orIfNotFound (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + (provider_fopts, other_fopts) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name -- | Search the home-unit graph and otherwise the regular exposed package @@ -401,10 +418,17 @@ findHomeOrRegularPackageModule -> ModuleName -> IO FindResult findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name - `orIfNotFound` - findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + case mb_home_unit of + Just home_unit -> + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + ) + Nothing -> + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual where unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue @@ -470,6 +494,40 @@ orIfNotFound this or_this = do _other -> return res2 _other -> return res +combineFindResult :: Monad m => m FindResult -> m FindResult -> m FindResult +combineFindResult this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + NoPackage{} -> pure res + FoundMultiple ms -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ ms ++ [(other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ ms ++ other_ms + NotFound{} -> pure res + Found _mod_location modl -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ [(modl, HomeOrigin), (other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ [(modl, HomeOrigin)] ++ other_ms + NotFound{} -> pure res + -- | Helper function for 'findHomeModule': this function wraps an IO action -- which would look up @mod_name@ in the file system (the home package), -- and first consults the 'hsc_FC' cache to see if the lookup has already @@ -483,8 +541,12 @@ homeSearchCache fc home_unit mod_name do_this = do findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg = - findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + findLookupResult fc fopts $ + case lookupModuleWithSuggestions units mod_name mb_pkg of + lf@(LookupFound _ (u, _)) + | unitId u `Set.member` homeUnitDepends units -> LookupNotFound [] + | otherwise -> lf + other -> other findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult findExposedPluginPackageModule fc fopts units mod_name = @@ -509,7 +571,7 @@ findLookupResult fc fopts r = case r of , fr_unusables = [] , fr_suggestions = []}) LookupMultiple rs -> - return (FoundMultiple rs) + return (FoundMultiple $ map (\ (m, o) -> (m, ExternalUnitOrigin o)) rs) LookupHidden fr_pkgs_hidden mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden @@ -588,6 +650,15 @@ mkHomeHidden uid = , fr_unusables = [] , fr_suggestions = []} +notFound = + NotFound { fr_paths = [] + , fr_pkg = Nothing + , fr_mods_hidden = [] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + + findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult findHomePackageModule fc fopts home_unit mod_name = do let uid = RealUnit (Definite home_unit) ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Unit.Env import GHC.Data.FastString import GHC.Types.Unique.Set +import GHC.Iface.Errors.Types (HomeOrExternalOrigin) -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for @@ -56,7 +57,7 @@ data FindResult -- ^ The module was found | NoPackage Unit -- ^ The requested unit was not found - | FoundMultiple [(Module, ModuleOrigin)] + | FoundMultiple [(Module, HomeOrExternalOrigin)] -- ^ _Error_: both in multiple packages -- | Not found ===================================== testsuite/tests/ghci/T26300/Makefile ===================================== @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: prog-mhu006a +prog-mhu006a: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db \ + -unit @unitA -unit @unitB < prog-mhu006a.script ===================================== testsuite/tests/ghci/T26300/T26300.script ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/T26300.stderr ===================================== @@ -0,0 +1,8 @@ +a/Main.hs:3:1: error: [GHC-45102] + Ambiguous module name ‘Data.List’. + it was found in multiple packages: base-4.23.0.0 b-0.0.1 + +a/Main.hs:4:1: error: [GHC-45102] + Ambiguous module name ‘Bar’. + it was found in multiple packages: c-0.0.1 b-0.0.1 + ===================================== testsuite/tests/ghci/T26300/T26300.stdout ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/a/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +import Data.List +import Bar ===================================== testsuite/tests/ghci/T26300/all.T ===================================== @@ -0,0 +1,6 @@ +test('T26300', + [extra_files(['a/', 'b/', 'c/', 'unitA', 'unitB', 'unitC']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + normalise_slashes, + req_interp], + ghci_multiunit_script, [['unitA', 'unitB', 'unitC'], 'T26300.script']) ===================================== testsuite/tests/ghci/T26300/b/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/b/Data/List.hs ===================================== @@ -0,0 +1 @@ +module Data.List where ===================================== testsuite/tests/ghci/T26300/c/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/unitA ===================================== @@ -0,0 +1,6 @@ +-i +-ia +-this-unit-id a-0.0.1 +-package-id b-0.0.1 +-package-id c-0.0.1 +Main ===================================== testsuite/tests/ghci/T26300/unitB ===================================== @@ -0,0 +1,5 @@ +-i +-ib +-this-unit-id b-0.0.1 +Data.List +Bar ===================================== testsuite/tests/ghci/T26300/unitC ===================================== @@ -0,0 +1,4 @@ +-i +-ic +-this-unit-id c-0.0.1 +Bar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21fc5fe9cf1727e2dc7594ee14495cd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/21fc5fe9cf1727e2dc7594ee14495cd… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0