- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/reduce-type-in-stg] Remove redundant import
by Jaro Reinders (＠jaro) 22 Apr '26

22 Apr '26

Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: 5913d45b by Jaro Reinders at 2026-04-22T12:58:06+02:00 Remove redundant import - - - - - 1 changed file: - compiler/GHC/StgToJS/Prim.hs Changes: ===================================== compiler/GHC/StgToJS/Prim.hs ===================================== @@ -25,7 +25,6 @@ import GHC.StgToJS.Regs import GHC.StgToJS.Symbols import GHC.Builtin.PrimOps -import GHC.Tc.Utils.TcType (isBoolTy) import GHC.Utils.Encoding (zEncodeString) import GHC.Data.FastString View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5913d45bc128db542caca3726b3352d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5913d45bc128db542caca3726b3352d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/reduce-type-in-stg] Remove EOL whitespace
by Jaro Reinders (＠jaro) 22 Apr '26

22 Apr '26

Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: f339f70c by Jaro Reinders at 2026-04-22T12:56:57+02:00 Remove EOL whitespace - - - - - 1 changed file: - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -571,7 +571,7 @@ typePrimRep ty = let ki = typeKind ty in case kindPrimRep_maybe ki of Just reps -> reps - Nothing -> + Nothing -> pprPanic "typePrimRep" (ppr ty <+> dcolon <+> ppr ki) -- | Discovers the primitive representation of a 'Type'. Returns View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f339f70c0e22e90bb51ee43325e1f95… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f339f70c0e22e90bb51ee43325e1f95… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/reduce-type-in-stg] One more thing
by Jaro Reinders (＠jaro) 22 Apr '26

22 Apr '26

Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: e12a62a3 by Jaro Reinders at 2026-04-22T11:54:23+02:00 One more thing - - - - - 1 changed file: - compiler/GHC/StgToJS/Expr.hs Changes: ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -338,12 +338,6 @@ genBody ctx startReg args e kind = do return $ la <> lav <> e <> returnStack --- TODO: move to a proper place -stgKindPrimRep :: StgKind -> [PrimRep] -stgKindPrimRep (MkStgKind kind) = case kindPrimRep_maybe kind of - Just rs -> rs - r -> pprPanic "stgKindPrimRep" (ppr r) - -- | Find the result type after applying the function to the arguments -- -- It's trickier than it looks because: View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e12a62a36288e885611d1b9be73bc49… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e12a62a36288e885611d1b9be73bc49… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/reduce-type-in-stg] Do almost all the todos
by Jaro Reinders (＠jaro) 22 Apr '26

22 Apr '26

Jaro Reinders pushed to branch wip/reduce-type-in-stg at Glasgow Haskell Compiler / GHC Commits: 5d9f2aee by Jaro Reinders at 2026-04-22T11:53:14+02:00 Do almost all the todos - - - - - 5 changed files: - compiler/GHC/Core/Type.hs - compiler/GHC/Stg/Unarise.hs - compiler/GHC/StgToCmm/Utils.hs - compiler/GHC/StgToJS/Expr.hs - compiler/GHC/Types/RepType.hs Changes: ===================================== compiler/GHC/Core/Type.hs ===================================== @@ -70,7 +70,7 @@ module GHC.Core.Type ( isLitTy, getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, - getLevity, levityType_maybe, + getLevity, levityType_maybe, isUnboxedTupleKind, mkCastTy, mkCoercionTy, splitCastTy_maybe, @@ -2802,6 +2802,12 @@ isFixedRuntimeRepKind k -- the isLiftedTypeKind check is necessary b/c of Constraint isConcreteType k +isUnboxedTupleKind :: HasDebugCallStack => Kind -> Bool +isUnboxedTupleKind kind + = tyConAppTyCon (kindRep kind) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + -- | Tests whether the given type is concrete, i.e. it -- whether it consists only of concrete type constructors, -- concrete type variables, and applications. ===================================== compiler/GHC/Stg/Unarise.hs ===================================== @@ -882,7 +882,6 @@ mapSumIdBinders alt_bndr args rhs rho0 -- Convert the argument to the given type, and wrap the conversion -- around the given expression. Use the given Id as a name for the -- converted value. --- TODO: the 'Type' in the argument here should probably be 'StgKind' castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr castArgRename ops in_arg rhs = case ops of @@ -896,17 +895,11 @@ castArgRename ops in_arg rhs = mkCastVar :: Unique -> Type -> Id mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty --- TODO: move/rename this -stgKindPrimRep1 :: HasDebugCallStack => StgKind -> PrimRep -stgKindPrimRep1 (MkStgKind k) = case kindPrimRep_maybe k of - Just [rep] -> rep - r -> pprPanic "kindPrimRepU" (ppr k $$ ppr r) - mkCast :: StgArg -> PrimOp -> OutId -> StgKind -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_kind in_rhs = let scrut = StgOpApp (StgPrimOp cast_op) [arg_in] alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} - alt_ty = PrimAlt (stgKindPrimRep1 out_kind) + alt_ty = PrimAlt (kindPrimRep1 (getStgKind out_kind)) in (StgCase scrut out_id alt_ty [alt]) -- | Build a unboxed sum term from arguments of an alternative. ===================================== compiler/GHC/StgToCmm/Utils.hs ===================================== @@ -92,7 +92,6 @@ import Control.Monad import qualified Data.Map.Strict as Map import qualified Data.IntMap.Strict as I import qualified Data.Semigroup (Semigroup(..)) -import GHC.Builtin.Names (tupleRepDataConKey) -------------------------------------------------------------------------- -- @@ -321,24 +320,22 @@ assignTemp e = do { platform <- getPlatform ; emitAssign (CmmLocal reg) e ; return reg } -newUnboxedTupleRegs :: Kind -> FCode ([LocalReg], [ForeignHint]) +newUnboxedTupleRegs :: HasDebugCallStack => Kind -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components -- of an unboxed tuple that we are about to return to -- the Sequel. If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_kind - -- TODO: clean up this messy assert. It is basically isUnboxedTupleType, but then for kinds. - = assert (Just True == ((\x -> tyConAppTyCon x `hasKey` tupleRepDataConKey) <$> kindRep_maybe res_kind)) $ - do { platform <- getPlatform - ; sequel <- getSequel - ; regs <- choose_regs platform sequel - ; massert (regs `equalLength` reps) - ; return (regs, map primRepForeignHint reps) } - where - -- TODO: this is partial - Just reps = kindPrimRep_maybe res_kind - choose_regs _ (AssignTo regs _) = return regs - choose_regs platform _ = mapM (newTemp . primRepCmmType platform) reps + = assert (isUnboxedTupleKind res_kind) $ + case kindPrimRep_maybe res_kind of + Just reps -> + do { platform <- getPlatform + ; sequel <- getSequel + ; regs <- case sequel of + AssignTo regs _ -> regs <$ massert (regs `equalLength` reps) + _ -> mapM (newTemp . primRepCmmType platform) reps + ; return (regs, map primRepForeignHint reps) } + Nothing -> pprPanic "newUnboxedTupleRegs applied to non-unboxed-tuple kind" (ppr res_kind) ------------------------------------------------------------------------- -- emitMultiAssign ===================================== compiler/GHC/StgToJS/Expr.hs ===================================== @@ -372,7 +372,7 @@ resultSize kind = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = stgKindPrimRep kind + result_reps = kindPrimRep (getStgKind kind) -- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function -- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. ===================================== compiler/GHC/Types/RepType.hs ===================================== @@ -14,6 +14,7 @@ module GHC.Types.RepType countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, + kindPrimRep, kindPrimRep1, -- * Unboxed sum representation type ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..), @@ -566,9 +567,12 @@ to process the LiftedRep and WordRep, concatenating the results. -- no runtime representation (void) or multiple (unboxed tuple/sum) -- See also Note [Getting from RuntimeRep to PrimRep] typePrimRep :: HasDebugCallStack => Type -> [PrimRep] -typePrimRep ty = kindPrimRep (text "typePrimRep" <+> - parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) - (typeKind ty) +typePrimRep ty = + let ki = typeKind ty in + case kindPrimRep_maybe ki of + Just reps -> reps + Nothing -> + pprPanic "typePrimRep" (ppr ty <+> dcolon <+> ppr ki) -- | Discovers the primitive representation of a 'Type'. Returns -- a list of 'PrimRep': it's a list because of the possibility of @@ -599,20 +603,29 @@ typePrimRepU ty = case typePrimRep ty of -- See also Note [Getting from RuntimeRep to PrimRep] tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] tyConPrimRep tc - = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) - res_kind + = case kindPrimRep_maybe res_kind of + Just reps -> reps + Nothing -> pprPanic "kindRep tc" (ppr tc $$ ppr res_kind) where res_kind = tyConResKind tc -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] -kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep doc ki - | Just runtime_rep <- kindRep_maybe ki - = runtimeRepPrimRep doc runtime_rep -kindPrimRep doc ki - = pprPanic "kindPrimRep" (ppr ki $$ doc) +kindPrimRep :: HasDebugCallStack => Kind -> [PrimRep] +kindPrimRep ki + = case kindPrimRep_maybe ki of + Just reps -> reps + Nothing -> pprPanic "kindPrimRep" (ppr ki) + +-- | Like 'kindPrimRep', but assumes that there is exactly one 'PrimRep' output. +-- This assumption holds after unarise, see Note [Post-unarisation invariants]. +-- Before unarise it may or may not hold. +-- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] +kindPrimRep1 :: HasDebugCallStack => Kind -> PrimRep +kindPrimRep1 k = case kindPrimRep_maybe k of + Just [rep] -> rep + r -> pprPanic "kindPrimRep1" (ppr k $$ ppr r) -- NB: We could implement the partial methods by calling into the maybe -- variants here. But then both would need to pass around the doc argument. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d9f2aee8ca0768e7a73f476d85574b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d9f2aee8ca0768e7a73f476d85574b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/split-driver-main] Split GHC.Driver.Main.hs up into multiple components.
by Andreas Klebinger (＠AndreasK) 22 Apr '26

22 Apr '26

Andreas Klebinger pushed to branch wip/andreask/split-driver-main at Glasgow Haskell Compiler / GHC Commits: 9db35611 by Andreas Klebinger at 2026-04-22T09:27:34+02:00 Split GHC.Driver.Main.hs up into multiple components. This commit splits GHC.Driver.Main into four components: * GHC.Driver.Main.Compile * GHC.Driver.Main.Hsc * GHC.Driver.Main.Interactive * GHC.Driver.Main.Passes We might improve that separation further in the future but this should hopefully make it easier to reason about and work with this part of the code. - - - - - 13 changed files: - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Iface/Load.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/ghc.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9db3561149bb46f4b898b9e8a9e5d17… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9db3561149bb46f4b898b9e8a9e5d17… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/split-driver-main] 7 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Andreas Klebinger (＠AndreasK) 22 Apr '26

22 Apr '26

Andreas Klebinger pushed to branch wip/andreask/split-driver-main at Glasgow Haskell Compiler / GHC Commits: 72d6dc74 by aparker at 2026-04-20T20:15:44-04:00 NCG: Implement constant folding for vector simd ops (Issue #25030) - - - - - b9cab907 by sheaf at 2026-04-20T20:15:44-04:00 Mark some SIMD tests as broken on i386 optllvm As seen in #25498, several SIMD tests are broken on i386 in the optllvm way. This commit marks them as "expect_broken". - - - - - 76528cc3 by Wolfgang Jeltsch at 2026-04-20T20:16:25-04:00 Move most of the `System.IO` implementation into `base` This involves a rewrite of the `combine` helper function to avoid the use of `last`, which would now be flagged as an error. Metric Decrease: LinkableUsage01 T3294 Metric Increase: T12227 T12707 T5642 - - - - - 04d143c0 by Luite Stegeman at 2026-04-21T14:05:33-04:00 rts: add a few missing i386 relocations in the rts linker - - - - - 014087e7 by Luite Stegeman at 2026-04-21T14:05:34-04:00 CodeOutput: Fix finalizers on multiple platforms - ELF platforms: emit .fini_array section - wasm32/Darwin: emit initializer with __cxa_atexit call - Windows: use -Wl,--whole-archive to prevent dropping finalizer symbols - rts linker: fix crash/assertion failure unloading objects with finalizers fixes #27072 - - - - - 915bba6f by Simon Jakobi at 2026-04-21T14:06:16-04:00 Add regression test for #10531 Closes #10531. - - - - - c898e417 by Andreas Klebinger at 2026-04-22T09:25:37+02:00 Split GHC.Driver.Main.hs up into multiple components. This commit splits GHC.Driver.Main into four components: * GHC.Driver.Main.Compile * GHC.Driver.Main.Hsc * GHC.Driver.Main.Interactive * GHC.Driver.Main.Passes We might improve that separation further in the future but this should hopefully make it easier to reason about and work with this part of the code. - - - - - 73 changed files: - + changelog.d/fix-finalizers-27072 - + changelog.d/simd_constant_folding - compiler/GHC/Cmm/Opt.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Main.hs - + compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Main.hs-boot → compiler/GHC/Driver/Main/Compile.hs-boot - + compiler/GHC/Driver/Main/Hsc.hs - + compiler/GHC/Driver/Main/Interactive.hs - + compiler/GHC/Driver/Main/Passes.hs - + compiler/GHC/Driver/Main/Passes.hs-boot - compiler/GHC/Iface/Load.hs - compiler/GHC/Linker/Executable.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/ForeignStubs.hs - compiler/GHC/Utils/Misc.hs - compiler/ghc.cabal.in - libraries/base/src/Control/Concurrent.hs - libraries/base/src/GHC/IO/Handle.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/IO.hs - libraries/base/src/Text/Printf.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - rts/Linker.c - rts/LinkerInternals.h - rts/linker/Elf.c - + testsuite/tests/codeGen/should_run/T27072d.hs - + testsuite/tests/codeGen/should_run/T27072d.stdout - + testsuite/tests/codeGen/should_run/T27072d_c.c - + testsuite/tests/codeGen/should_run/T27072d_check.c - + testsuite/tests/codeGen/should_run/T27072w.hs - + testsuite/tests/codeGen/should_run/T27072w.stdout - + testsuite/tests/codeGen/should_run/T27072w_c.c - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/driver/T10531/A.hs - + testsuite/tests/driver/T10531/B.hs - + testsuite/tests/driver/T10531/C.hs - + testsuite/tests/driver/T10531/Makefile - + testsuite/tests/driver/T10531/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - + testsuite/tests/rts/linker/T27072/Lib.c - + testsuite/tests/rts/linker/T27072/Makefile - + testsuite/tests/rts/linker/T27072/T27072.stdout - + testsuite/tests/rts/linker/T27072/all.T - + testsuite/tests/rts/linker/T27072/main.c - + testsuite/tests/simd/should_run/Makefile - + testsuite/tests/simd/should_run/T25030.hs - + testsuite/tests/simd/should_run/T25030.stdout - testsuite/tests/simd/should_run/all.T - testsuite/tests/th/all.T - testsuite/tests/typecheck/should_compile/T9497a.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/T9497d.stderr - testsuite/tests/typecheck/should_run/T9497a-run.stderr - testsuite/tests/typecheck/should_run/T9497b-run.stderr - testsuite/tests/typecheck/should_run/T9497c-run.stderr - utils/haddock/html-test/ref/Bug1004.html - utils/haddock/html-test/ref/Bug973.html - utils/haddock/html-test/ref/ConstructorPatternExport.html - utils/haddock/html-test/ref/DefaultSignatures.html - utils/haddock/html-test/ref/Hash.html - utils/haddock/html-test/ref/PatternSyns.html - utils/haddock/html-test/ref/PatternSyns2.html - utils/haddock/html-test/ref/QuasiExpr.html - utils/haddock/html-test/ref/Test.html The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/38c1da94be5d3051807d95bc8f5f7f… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/38c1da94be5d3051807d95bc8f5f7f… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/sjakobi/tweak-mk_mod_usage_info] Tweak mk_mod_usage_info
by Simon Jakobi (＠sjakobi2) 22 Apr '26

22 Apr '26

Simon Jakobi pushed to branch wip/sjakobi/tweak-mk_mod_usage_info at Glasgow Haskell Compiler / GHC Commits: f595622f by Simon Jakobi at 2026-04-22T02:52:00+02:00 Tweak mk_mod_usage_info * Use O(log n) `elemModuleEnv` instead of O(n) `elem` to filter the direct imports. * Use `nonDetModuleEnvKeys` to avoid sorting the ent_map keys twice. * Prepend the presumably shorter list when creating all_mods with `(++)`. Actually this eliminates the `(++)` entirely, as it seems to fuse with the `filter` expression. * As the above changes change the demand on ent_map, we force it to ensure it's only computed once. As a result there is a tiny speed-up when generating the .hi-files for modules with many imports. None of the changes affect compilation determinism as the module list is explicitly sorted to ensure a canonical order. - - - - - 2 changed files: - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Unit/Module/Env.hs Changes: ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -219,15 +219,20 @@ mk_mod_usage_info :: UsageConfig -> NameSet -> IfG [Usage] mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls used_names - = mapMaybeM mkUsageM usage_mods + = ent_map `seq` mapMaybeM mkUsageM usage_mods + -- ent_map is required _lazily_ for several sub-computations, so we force + -- it here to ensure it's built only once. where safe_implicit_imps_req = uc_safe_implicit_imps_req uc - used_mods = moduleEnvKeys ent_map - dir_imp_mods = Map.keys direct_imports - all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods - usage_mods = sortBy stableModuleCmp all_mods - -- canonical order is imported, to avoid interface-file + used_mods = nonDetModuleEnvKeys ent_map + -- nonDetModuleEnvKeys is OK here, because the + -- resulting usage_mods are sorted explicitly. + is_used_mod m = m `elemModuleEnv` ent_map + dir_imp_mods = Map.keys direct_imports + all_mods = filter (not . is_used_mod) dir_imp_mods ++ used_mods + usage_mods = sortBy stableModuleCmp all_mods + -- canonical order is important, to avoid interface-file -- wobblage. -- ent_map groups together all the things imported and used ===================================== compiler/GHC/Unit/Module/Env.hs ===================================== @@ -8,7 +8,7 @@ module GHC.Unit.Module.Env , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , alterModuleEnv , partitionModuleEnv - , moduleEnvKeys, moduleEnvElts, moduleEnvToList + , moduleEnvKeys, nonDetModuleEnvKeys, moduleEnvElts, moduleEnvToList , unitModuleEnv, isEmptyModuleEnv , extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv @@ -157,8 +157,15 @@ mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) emptyModuleEnv :: ModuleEnv a emptyModuleEnv = ModuleEnv Map.empty +-- | See Note [ModuleEnv performance and determinism]. +-- +-- If you use this, please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetModuleEnvKeys :: ModuleEnv a -> [Module] +nonDetModuleEnvKeys (ModuleEnv e) = map unNDModule $ Map.keys e + moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e +moduleEnvKeys = sort . nonDetModuleEnvKeys -- See Note [ModuleEnv performance and determinism] moduleEnvElts :: ModuleEnv a -> [a] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f595622f28c7d8fec5cd5227b2e4804… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f595622f28c7d8fec5cd5227b2e4804… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/T27156] expand the bracket expression before puting it in typed bracket
by Apoorv Ingle (＠ani) 22 Apr '26

22 Apr '26

Apoorv Ingle pushed to branch wip/ani/T27156 at Glasgow Haskell Compiler / GHC Commits: 0ebd3306 by Apoorv Ingle at 2026-04-21T19:43:24-05:00 expand the bracket expression before puting it in typed bracket - - - - - 3 changed files: - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Splice.hs Changes: ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -44,8 +44,6 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.ErrCtxt import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear ) -import GHC.Tc.Gen.Expand ( tcExpandNoTcM ) - import GHC.Core.Class import GHC.Core.DataCon import GHC.Core.TyCon @@ -1620,13 +1618,11 @@ repE (HsCase _ e (MG { mg_alts = (L _ ms) })) ; ms2 <- mapM repMatchTup ms ; core_ms2 <- coreListM matchTyConName ms2 ; repCaseE arg core_ms2 } -repE e@(HsIf _ x y z) = case (tcExpandNoTcM e) of - Nothing -> do { a <- repLE x - ; b <- repLE y - ; c <- repLE z - ; repCond a b c } - Just (HSE _ (L _ e')) -> repE e' - +repE (HsIf _ x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c repE (HsMultiIf _ alts) = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList' alts') ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -554,7 +554,7 @@ rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) ; let upd_flds = OverloadedRecUpdFields { xOLRecUpdFields = noExtField , olRecUpdFields = us } - rs_table = Rebindable [(nameOccName getField, getField) , (nameOccName getField, setField)] + rs_table = Rebindable [(nameOccName getField, getField) , (nameOccName setField, setField)] ; return (RecordUpd rs_table (L l e) upd_flds , plusFNs [fv_getField, fv_setField, fv_e, fv_us] ) } ===================================== compiler/GHC/Rename/Splice.hs ===================================== @@ -24,6 +24,7 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Expand import GHC.Driver.Env.Types import GHC.Rename.Env @@ -141,9 +142,12 @@ rnTypedBracket e br_body ; recordThUse ; traceRn "Renaming typed TH bracket" empty - ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body - ; return (HsTypedBracket noExtField body', fvs_e) - + ; (body'@(L loc b) , fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body + -- ; return (HsTypedBracket noExtField body', fvs_e) + ; mb_b <- tcExpand b + ; case mb_b of + Nothing -> return (HsTypedBracket noExtField body', fvs_e) + Just hse -> return (HsTypedBracket noExtField (L loc (XExpr (ExpandedThingRn hse))), fvs_e) } rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeNames) @@ -176,6 +180,7 @@ rnUntypedBracket e br_body setThLevel (UntypedBrack cur_level ps_var) $ rn_utbracket br_body ; pendings <- readMutVar ps_var + ; return (HsUntypedBracket pendings body', fvs_e) } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ebd33068664ea1f6bb6c0650e2c41a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0ebd33068664ea1f6bb6c0650e2c41a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mwb-26-01/mp-backports] Avoid expensive computation for debug logging in `mergeDatabases` when log level is low
by Torsten Schmits (＠torsten.schmits) 22 Apr '26

22 Apr '26

Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-01/mp-backports at Glasgow Haskell Compiler / GHC Commits: fe5932d4 by Torsten Schmits at 2026-04-22T02:29:34+02:00 Avoid expensive computation for debug logging in `mergeDatabases` when log level is low - - - - - 1 changed file: - compiler/GHC/Unit/State.hs Changes: ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1401,10 +1401,11 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> OsPath.pprOsPath db_path - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" + when (log_verbosity (logFlags logger) >= 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" return (pkg_map', prec_map') where db_map = mk_pkg_map db @@ -2382,4 +2383,3 @@ implicitPackageDeps dflags = [thUnitId | xopt TemplateHaskellQuotes dflags] -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but -- it is possible to not depend on base (for example, see `ghc-prim`) - View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe5932d418e8221bb5bcd34954caca0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fe5932d418e8221bb5bcd34954caca0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/torsten.schmits/mwb-26-01/fixed] 2 commits: Avoid expensive computation for debug logging in `mergeDatabases` when log level is low
by Torsten Schmits (＠torsten.schmits) 22 Apr '26

22 Apr '26

Torsten Schmits pushed to branch wip/torsten.schmits/mwb-26-01/fixed at Glasgow Haskell Compiler / GHC Commits: fe5932d4 by Torsten Schmits at 2026-04-22T02:29:34+02:00 Avoid expensive computation for debug logging in `mergeDatabases` when log level is low - - - - - 630ee987 by Torsten Schmits at 2026-04-22T02:30:10+02:00 Fixed nodes - - - - - 10 changed files: - compiler/GHC.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - utils/haddock Changes: ===================================== compiler/GHC.hs ===================================== @@ -75,9 +75,12 @@ module GHC ( compileToCoreModule, compileToCoreSimplified, -- * Inspecting the module structure of the program - ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, - mgLookupModule, + ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgModSummaries', + mgLookupModule, mgNodeIsModule, ModSummary(..), ms_mod_name, ModLocation(..), + ModuleNodeInfo(..), moduleNodeInfoModule, moduleNodeInfoModuleName, + moduleNodeInfoLocation, moduleNodeInfoHscSource, + isBootModuleNodeInfo, pattern ModLocation, getModSummary, getModuleGraph, ===================================== compiler/GHC/Driver/Backpack.hs ===================================== @@ -748,9 +748,9 @@ hsunitModuleGraph do_link unit = do -- create an "empty" hsig file to induce compilation for the -- requirement. let hsig_set = Set.fromList - [ ms_mod_name ms + [ moduleNodeInfoModuleName ms | ModuleNode _ ms <- nodes - , ms_hsc_src ms == HsigFile + , moduleNodeInfoHscSource ms == Just HsigFile ] req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> if Set.member mod_name hsig_set @@ -825,7 +825,7 @@ summariseRequirement pn mod_name = do ms_hspp_buf = Nothing } let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ] - return (ModuleNode nodes ms) + return (ModuleNode nodes (ModuleNodeCompile ms)) summariseDecl :: PackageName -> HscSource @@ -943,7 +943,7 @@ hsModuleToModSummary home_keys pn hsc_src modname [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] - return (ModuleNode (mod_nodes ++ inst_nodes) ms) + return (ModuleNode (mod_nodes ++ inst_nodes) (ModuleNodeCompile ms)) -- | Create a new, externally provided hashed unit id from -- a hash. ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -50,6 +50,7 @@ module GHC.Driver.Main , initModDetails , initWholeCoreBindings , loadIfaceByteCode + , loadIfaceByteCodeLazy , hscMaybeWriteIface , hscCompileCmmFile @@ -106,6 +107,7 @@ module GHC.Driver.Main , hscAddSptEntries , writeInterfaceOnlyMode , loadByteCode + , genModDetails ) where import GHC.Prelude @@ -824,7 +826,7 @@ hscRecompStatus = do let msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) + Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary)) Nothing -> return () -- First check to see if the interface file agrees with the @@ -1055,6 +1057,27 @@ loadIfaceByteCode hsc_env iface location type_env = time <- maybe getCurrentTime pure if_time return $! Linkable time (mi_module iface) parts +loadIfaceByteCodeLazy :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + IO (Maybe Linkable) +loadIfaceByteCodeLazy hsc_env iface location type_env = + case iface_core_bindings iface location of + Nothing -> return Nothing + Just wcb -> do + Just <$> compile wcb + where + compile decls = do + ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls + linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos] + + linkable parts = do + if_time <- modificationTimeIfExists (ml_hi_file location) + time <- maybe getCurrentTime pure if_time + return $!Linkable time (mi_module iface) parts + -- | If the 'Linkable' contains Core bindings loaded from an interface, replace -- them with a lazy IO thunk that compiles them to bytecode and foreign objects, -- using the supplied environment for type checking. ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -43,115 +43,108 @@ module GHC.Driver.Make ( ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith ) where -import GHC.Prelude -import GHC.Platform - -import GHC.Tc.Utils.Backpack -import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) - -import GHC.Runtime.Interpreter -import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types - -import GHC.Platform.Ways - -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Phases -import GHC.Driver.Pipeline -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Monad -import GHC.Driver.Env -import GHC.Driver.Errors -import GHC.Driver.Errors.Types -import GHC.Driver.Main -import GHC.Driver.MakeSem - -import GHC.Parser.Header +import Control.Concurrent ( + ThreadId, + forkIOWithUnmask, + killThread, + newQSem, + signalQSem, + waitQSem, + ) +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Monad +import qualified Control.Monad.Catch as MC +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Lazy +import Data.Bifunctor (first) +import Data.Either (lefts, partitionEithers, rights) +import Data.Function +import Data.IORef +import Data.List (groupBy, sortBy, sortOn, unfoldr) +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as Set +import Data.Time import GHC.ByteCode.Types - -import GHC.Iface.Load ( cannotFindModule ) -import GHC.IfaceToCore ( typecheckIface ) -import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) - -import GHC.Data.Bag ( listToBag ) -import GHC.Data.Graph.Directed +import qualified GHC.Conc as CC +import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) +import GHC.Data.Bag (listToBag) import GHC.Data.FastString -import GHC.Data.Maybe ( expectJust ) -import GHC.Data.OsPath ( unsafeEncodeUtf ) +import GHC.Data.Graph.Directed +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.Data.Maybe as MB +import GHC.Data.Maybe (expectJust) +import qualified GHC.Data.OsPath as OsPath +import GHC.Data.OsPath (OsPath, unsafeEncodeUtf) import GHC.Data.StringBuffer +import GHC.Iface.Errors.Types +import GHC.Iface.Load (cannotFindModule, readIface) +import GHC.Iface.Recomp (CompileReason (..), RecompileRequired (..)) +import GHC.IfaceToCore (typecheckIface) import qualified GHC.LanguageExtensions as LangExt - -import GHC.Utils.Exception ( throwIO, SomeAsyncException ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Misc -import GHC.Utils.Error -import GHC.Utils.Logger -import GHC.Utils.Fingerprint -import GHC.Utils.TmpFs - +import qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types +import GHC.Parser.Header +import GHC.Platform +import GHC.Platform.Ways +import GHC.Prelude +import GHC.Rename.Names +import GHC.Runtime.Interpreter +import GHC.Runtime.Loader +import GHC.Tc.Utils.Backpack +import GHC.Tc.Utils.Monad (concatMapM, initIfaceCheck) import GHC.Types.Basic import GHC.Types.Error -import GHC.Types.Target -import GHC.Types.SourceFile +import GHC.Types.PkgQual import GHC.Types.SourceError +import GHC.Types.SourceFile import GHC.Types.SrcLoc +import GHC.Types.Target +import GHC.Types.TypeEnv import GHC.Types.Unique.Map -import GHC.Types.PkgQual - import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Module.Graph import GHC.Unit.Module.ModDetails - -import Data.Either ( rights, partitionEithers, lefts ) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import GHC.Data.OsPath (OsPath) -import qualified GHC.Data.OsPath as OsPath -import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) -import qualified GHC.Conc as CC -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) -import qualified Control.Monad.Catch as MC -import Data.IORef -import Data.Maybe -import Data.Time -import Data.List (sortOn, unfoldr) -import Data.List (sortOn, unfoldr, groupBy, sortBy) -import Data.Bifunctor (first) +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Utils.Constants +import GHC.Utils.Error +import GHC.Utils.Exception (SomeAsyncException, throwIO) +import GHC.Utils.Fingerprint +import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs import System.Directory import System.FilePath -import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import GHC.Driver.Pipeline.LogQueue -import qualified Data.Map.Strict as M -import GHC.Types.TypeEnv -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Class +import GHC.Driver.Backend +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Env import GHC.Driver.Env.KnotVars -import Control.Concurrent.STM -import Control.Monad.Trans.Maybe -import GHC.Runtime.Loader -import GHC.Rename.Names -import GHC.Utils.Constants -import GHC.Iface.Errors.Types -import Data.Function - -import GHC.Data.Graph.Directed.Reachability -import qualified GHC.Unit.Home.Graph as HUG -import GHC.Unit.Home.PackageTable +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.MakeSem +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Pipeline.LogQueue +import GHC.Driver.Session -- ----------------------------------------------------------------------------- -- Loading the program @@ -628,13 +621,16 @@ createBuildPlan mod_graph maybe_top_mod = -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists boot_modules = mkModuleEnv - [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot] + [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn))) + | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph) + , let mn = moduleNodeInfoModule ms + , isBootModuleNodeInfo ms == IsBoot] select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] select_boot_modules = mapMaybe (fmap fst . get_boot_module) get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]) - get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing + get_boot_module m = case m of ModuleNode _ ms | NotBoot <- isBootModuleNodeInfo ms -> lookupModuleEnv boot_modules (moduleNodeInfoModule ms); _ -> Nothing -- Any cycles should be resolved now collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] @@ -760,7 +756,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- prune the HPT so everything is not retained when doing an -- upsweep. !pruned_cache = pruneCache cache - (flattenSCCs (filterToposortToModules mg2_with_srcimps)) + [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules mg2_with_srcimps))] -- before we unload anything, make sure we don't leave an old @@ -820,7 +816,7 @@ guessOutputFile = modifySession $ \env -> mainModuleSrcPath :: Maybe String mainModuleSrcPath = do ms <- mgLookupModule mod_graph (mainModIs hue) - ml_hs_file (ms_location ms) + ml_hs_file (moduleNodeInfoLocation ms) name = fmap dropExtension mainModuleSrcPath -- MP: This exception is quite sensitive to being forced, if you @@ -1153,7 +1149,7 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do executeInstantiationNode mod_idx n_mods hug uid iu return Nothing ModuleNode _build_deps ms -> - let !old_hmi = M.lookup (msKey ms) old_hpt + let !old_hmi = M.lookup (mnKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes in withCurrentUnit (moduleGraphNodeUnitId mod) $ do !_ <- wait_deps build_deps @@ -1523,13 +1519,13 @@ modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE -- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m () warnUnnecessarySourceImports sccs = do diag_opts <- initDiagOpts <$> getDynFlags when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do let check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, + let mods_in_this_cycle = map moduleNodeInfoModuleName ms in + [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m, unLoc i `notElem` mods_in_this_cycle ] warn :: Located ModuleName -> MsgEnvelope GhcMessage @@ -1670,7 +1666,7 @@ downsweep_imports hsc_env old_summaries old_graph excl_mods allow_dup_roots (roo (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'') + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') where k = NodeKey_Module (msKey ms) @@ -1904,7 +1900,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = where defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode - enable_code_gen n@(ModuleNode deps ms) + enable_code_gen n@(ModuleNode deps (ModuleNodeCompile ms)) | ModSummary { ms_location = ms_location , ms_hsc_src = HsSrcFile @@ -1942,7 +1938,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = , ms_hspp_opts = updOptLevel 0 $ new_dflags } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile ms')) -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough) -- we only get to this case if the default backend is already generating object files, but we need dynamic @@ -1952,19 +1948,19 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile ms')) | dynamic_too_enable enable_spec ms -> do let ms' = ms { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile ms')) | ext_interp_enable ms -> do let ms' = ms { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter } -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') + enable_code_gen (ModuleNode deps (ModuleNodeCompile ms')) | otherwise -> return n @@ -2043,7 +2039,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only -- it's dependencies. [ deps - | (ModuleNode deps ms) <- mod_graph + | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) ] @@ -2052,7 +2048,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = need_bc_set = concat [ deps - | (ModuleNode deps ms) <- mod_graph + | (ModuleNode deps (ModuleNodeCompile ms)) <- mod_graph , isTemplateHaskellOrQQNonBoot ms , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) ] @@ -2514,9 +2510,14 @@ cyclicModuleErr mss ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid) - ppr_ms :: ModSummary -> SDoc - ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> - (parens (text (msHsFilePath ms))) + ppr_ms :: ModuleNodeInfo -> SDoc + ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+> + (parens (text (node_path ms))) + + node_path :: ModuleNodeInfo -> FilePath + node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of + Just f -> f + Nothing -> ml_hi_file (moduleNodeInfoLocation ms) cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () @@ -2609,39 +2610,72 @@ executeInstantiationNode k n deps uid iu = do return res +-- | executeCompileNode interprets how --make module should compile a ModuleNode +-- +-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check +-- if the interface file exists and is up to date. If it is, we return those. +-- Otherwise, we compile the module and return the new HomeModInfo. +-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface +-- and artifacts from disk. + executeCompileNode :: Int -> Int -> Maybe HomeModInfo -> HomeUnitGraph -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling - -> ModSummary + -> ModuleNodeInfo -> RunMakeM HomeModInfo -executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do +executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do me@MakeEnv{..} <- ask -- Rehydrate any dependencies if this module had a boot file or is a signature file. lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do - hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods + hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods + case mni of + ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod + ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc + ) + + where + fixed_mrehydrate_mods = + case moduleNodeInfoHscSource mni of + -- MP: It is probably a bit of a misimplementation in backpack that + -- compiling a signature requires an knot_var for that unit. + -- If you remove this then a lot of backpack tests fail. + Just HsigFile -> Just [] + _ -> mrehydrate_mods + + executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo) + executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod_key loc = + wrapAction diag_wrapper hsc_env $ do + forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod_key loc)) + read_result <- readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod_key) (ml_hi_file loc) + case read_result of + MB.Failed interface_err -> + + let mn = mnkModuleName mod_key + err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn)) + in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err)) + MB.Succeeded iface -> do + details <- genModDetails hsc_env iface + mb_object <- findObjectLinkableMaybe (mi_module iface) loc + mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details) + let hm_linkable = HomeModLinkable mb_bytecode mb_object + return (HomeModInfo iface details hm_linkable) + + executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo) + executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas lcl_dynflags = ms_hspp_opts mod let lcl_hsc_env = -- Localise the hsc_env to use the cached flags hscSetFlags lcl_dynflags $ - hsc_env' + hsc_env -- Compile the module, locking with a semaphore to avoid too many modules -- being compiled at the same time leading to high memory usage. wrapAction diag_wrapper lcl_hsc_env $ do res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n - cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env') (hsc_tmpfs hsc_env') lcl_dynflags - return res) - - where - fixed_mrehydrate_mods = - case ms_hsc_src mod of - -- MP: It is probably a bit of a misimplementation in backpack that - -- compiling a signature requires an knot_var for that unit. - -- If you remove this then a lot of backpack tests fail. - HsigFile -> Just [] - _ -> mrehydrate_mods + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags + return res {- Rehydration, see Note [Rehydrating Modules] -} @@ -2669,9 +2703,9 @@ rehydrate hsc_env hmis = do -- If needed, then rehydrate the necessary modules with a suitable KnotVars for the -- module currently being compiled. -maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv +maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv maybeRehydrateBefore hsc_env _ Nothing = return hsc_env -maybeRehydrateBefore hsc_env mod (Just mns) = do +maybeRehydrateBefore hsc_env mni (Just mns) = do knot_var <- initialise_knot_var hsc_env let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var } hmis <- mapM (fmap (expectJust "mr") . lookupHpt (hsc_HPT hsc_env')) mns @@ -2681,7 +2715,7 @@ maybeRehydrateBefore hsc_env mod (Just mns) = do where initialise_knot_var hsc_env = liftIO $ - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod) + let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv rehydrateAfter :: HscEnv ===================================== compiler/GHC/Driver/MakeFile.hs ===================================== @@ -14,55 +14,57 @@ module GHC.Driver.MakeFile ) where -import GHC.Prelude - +import Control.Monad (when) +import Data.Either (partitionEithers) +import Data.Foldable (traverse_) +import Data.IORef +import Data.List (partition) +import qualified Data.Set as Set import qualified GHC +import GHC.Data.Graph.Directed (SCC (..)) import GHC.Data.Maybe -import GHC.Driver.Make -import GHC.Driver.Monad -import GHC.Driver.DynFlags -import GHC.Driver.Ppr -import GHC.Driver.MakeFile.JSON -import GHC.Utils.Misc -import GHC.Driver.Env -import GHC.Driver.Errors.Types -import GHC.Driver.Pipeline (runPipeline, TPhase (T_Unlit, T_FileArgs), use, mkPipeEnv) -import GHC.Driver.Phases (StopPhase (StopPreprocess), startPhase, Phase (Unlit)) -import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile)) -import GHC.Driver.Session (pgm_F) -import qualified GHC.SysTools as SysTools -import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Data.OsPath (unsafeDecodeUtf, OsPath, OsString) import qualified GHC.Data.OsPath as OS -import GHC.Utils.Outputable -import GHC.Utils.Panic +import GHC.Data.OsPath (OsPath, OsString, unsafeDecodeUtf) +import GHC.Iface.Errors.Types +import GHC.Iface.Load (cannotFindModule) +import GHC.Prelude +import qualified GHC.SysTools as SysTools +import GHC.Types.PkgQual import GHC.Types.SourceError import GHC.Types.SrcLoc -import GHC.Types.PkgQual -import Data.List (partition) -import GHC.Utils.TmpFs - -import GHC.Iface.Load (cannotFindModule) -import GHC.Iface.Errors.Types - +import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph -import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary import GHC.Unit.State (lookupUnitId) - -import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Exception import GHC.Utils.Logger - +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs import System.Directory import System.FilePath import System.IO -import System.IO.Error ( isEOFError ) -import Control.Monad ( when ) -import Data.Foldable (traverse_) -import Data.IORef -import qualified Data.Set as Set +import System.IO.Error (isEOFError) + +import GHC.Driver.DynFlags +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Make +import GHC.Driver.MakeFile.JSON +import GHC.Driver.Monad +import GHC.Driver.Phases (Phase (Unlit), StopPhase (StopPreprocess), startPhase) +import GHC.Driver.Pipeline ( + TPhase (T_FileArgs, T_Unlit), + mkPipeEnv, + runPipeline, + use, + ) +import GHC.Driver.Pipeline.Monad (PipelineOutput (NoOutputFile)) +import GHC.Driver.Ppr +import GHC.Driver.Session (pgm_F) ----------------------------------------------------------------- -- @@ -234,8 +236,10 @@ processDeps dflags _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" , nest 2 $ ppr node ] processDeps _dflags_ _ _ _ _ _ (AcyclicSCC (LinkNode {})) = return () - -processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ node)) = do +processDeps _ _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) + -- No dependencies needed for fixed modules (already compiled) + = return () +processDeps dflags hsc_env excl_mods root hdl m_dep_json (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do pp <- preprocessor deps <- fmap concat $ sequence $ [cpp_deps | depIncludeCppDeps dflags] ++ [ @@ -472,43 +476,62 @@ pprCycle :: [ModuleGraphNode] -> SDoc -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries) where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] + cycle_keys :: [NodeKey] -- The modules in this cycle + cycle_keys = map mkNodeKey summaries pp_group :: SCC ModuleGraphNode -> SDoc - pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms + pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m pp_group (AcyclicSCC _) = empty pp_group (CyclicSCC mss) = assert (not (null boot_only)) $ -- The boot-only list must be non-empty, else there would -- be an infinite chain of non-boot imports, and we've -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) + pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups) where - (boot_only, others) = partition is_boot_only mss - is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms))) - is_boot_only _ = False - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] - - loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) - all_others = tail boot_only ++ others + (boot_only, others) = partitionEithers (map is_boot_only mss) + is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_key _ = False + is_boot_only n@(ModuleNode deps ms) = + let non_boot_deps = filter (not . is_boot_key) deps + in if not (any in_group non_boot_deps) + then Left (deps, ms) + else Right n + is_boot_only n = Right n + in_group m = m `elem` group_mods + group_mods = map mkNodeKey mss + + (loop_deps, loop_breaker) = head boot_only + all_others = tail (map (uncurry ModuleNode) boot_only) ++ others groups = GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) - - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms + pp_mod :: [NodeKey] -> ModuleNodeInfo -> SDoc + pp_mod deps mn = + text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps deps + where + mod_str = moduleNameString (moduleNodeInfoModuleName mn) + + ppr_deps :: [NodeKey] -> SDoc + ppr_deps [] = empty + ppr_deps deps = + let is_mod_dep (NodeKey_Module {}) = True + is_mod_dep _ = False + + is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_dep _ = False + + cycle_deps = filter (`elem` cycle_keys) deps + (mod_deps, other_deps) = partition is_mod_dep cycle_deps + (boot_deps, normal_deps) = partition is_boot_dep mod_deps + in vcat [ + if null normal_deps then empty + else text "imports" <+> pprWithCommas ppr normal_deps, + if null boot_deps then empty + else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps, + if null other_deps then empty + else text "depends on" <+> pprWithCommas ppr other_deps + ] ----------------------------------------------------------------- -- ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -1262,19 +1262,20 @@ dynCompileExpr expr = do ----------------------------------------------------------------------------- -- show a module and it's source/object filenames -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = +showModule :: GhcMonad m => ModuleNodeInfo -> m String +showModule mni = do + let mod = moduleNodeInfoModule mni withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env interpreted <- liftIO $ - HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case Nothing -> panic "missing linkable" Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) - return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) + return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> liftIO $ - HUG.lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) >>= pure . \case +moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool +moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case Nothing -> panic "missing linkable" Just mod_info -> isNothing $ homeModInfoByteCode mod_info ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -8,6 +8,12 @@ module GHC.Unit.Module.Graph , nodeDependencies , emptyMG , mkModuleGraph + , mkModuleGraphChecked + + -- * Invariant checking + , checkModuleGraph + , ModuleGraphInvariantError(..) + , extendMG , extendMGInst , extendMG' @@ -22,6 +28,7 @@ module GHC.Unit.Module.Graph , mgHomeModuleMap , showModMsg , moduleGraphNodeModule + , mgNodeIsModule , moduleGraphNodeModSum , moduleGraphModulesBelow , mgReachable @@ -38,46 +45,51 @@ module GHC.Unit.Module.Graph , ModNodeKey , mkNodeKey , msKey - + , mnKey , moduleGraphNodeUnitId , ModNodeKeyWithUid(..) + , mnkToModule + , mnkIsBoot + + , ModuleNodeInfo(..) + , moduleNodeInfoModule + , moduleNodeInfoModuleName + , moduleNodeInfoModNodeKeyWithUid + , moduleNodeInfoHscSource + , moduleNodeInfoLocation + , isBootModuleNodeInfo ) where -import GHC.Prelude -import GHC.Platform - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.Maybe +import Data.Bifunctor +import Data.Either +import Data.Function +import Data.List (sort) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) import GHC.Data.Graph.Directed import GHC.Data.Graph.Directed.Reachability - +import GHC.Data.List.SetOps +import GHC.Data.Maybe import GHC.Driver.Backend import GHC.Driver.DynFlags - -import GHC.Types.SourceFile ( hscSourceString, isHsigFile ) - -import GHC.Unit.Module.ModSummary -import GHC.Unit.Types +import qualified GHC.LanguageExtensions as LangExt +import GHC.Linker.Static.Utils +import GHC.Platform +import GHC.Prelude +import GHC.Stack +import GHC.Types.SourceFile (HscSource (..), hscSourceString, isHsigFile) +import GHC.Types.Unique.DSet +import GHC.Utils.Misc (partitionWith) import GHC.Utils.Outputable -import GHC.Utils.Misc ( partitionWith ) - import System.FilePath -import qualified Data.Map as Map -import GHC.Types.Unique.DSet -import qualified Data.Set as Set -import Data.Set (Set) -import GHC.Unit.Module -import GHC.Linker.Static.Utils -import Data.Bifunctor -import Data.Function -import Data.List (sort) -import GHC.Data.List.SetOps -import GHC.Stack +import GHC.Unit.Module +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types -- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. -- Edges between nodes mark dependencies arising from module imports @@ -86,30 +98,166 @@ data ModuleGraphNode -- | Instantiation nodes track the instantiation of other units -- (backpack dependencies) with the holes (signatures) of the current package. = InstantiationNode UnitId InstantiatedUnit - -- | There is a module summary node for each module, signature, and boot module being built. - | ModuleNode [NodeKey] ModSummary + -- | There is a module node for each module being built. + -- A node is either fixed or can be compiled. + -- - Fixed modules are not compiled, the artifacts are just loaded from disk. + -- It is up to you to make sure the artifacts are up to date and available. + -- - Compile modules are compiled from source if needed. + | ModuleNode [NodeKey] ModuleNodeInfo -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. | LinkNode [NodeKey] UnitId + +data ModuleGraphInvariantError = + FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey] + | DuplicateModuleNodeKey NodeKey + | DependencyNotInGraph NodeKey [NodeKey] + deriving (Eq, Ord) + +instance Outputable ModuleGraphInvariantError where + ppr = \case + FixedNodeDependsOnCompileNode key bad_deps -> + text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps + DuplicateModuleNodeKey k -> + text "Duplicate module node key" <+> ppr k + DependencyNotInGraph from to -> + text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to + +-- Used for invariant checking. Is a NodeKey fixed or compilable? +data ModuleNodeType = MN_Fixed | MN_Compile + +instance Outputable ModuleNodeType where + ppr = \case + MN_Fixed -> text "Fixed" + MN_Compile -> text "Compile" + +moduleNodeType :: ModuleGraphNode -> ModuleNodeType +moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile +moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed +moduleNodeType _ = MN_Compile + +checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError] +checkModuleGraph ModuleGraph{..} = + mapMaybe (checkFixedModuleInvariant node_types) mg_mss + ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss + ++ duplicate_errs + where + duplicate_errs = rights (Map.elems node_types) + + node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] + where + go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + go k _ _ = Right (DuplicateModuleNodeKey k) + +checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkAllDependenciesInGraph node_types node = + let nodeKey = mkNodeKey node + deps = nodeDependencies False node + missingDeps = filter (\dep -> not (Map.member dep node_types)) deps + in if null missingDeps + then Nothing + else Just (DependencyNotInGraph nodeKey missingDeps) + +checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkFixedModuleInvariant node_types node = case node of + ModuleNode deps (ModuleNodeFixed key _) -> + let check_node dep = case Map.lookup dep node_types of + Just (Left MN_Compile) -> Just dep + _ -> Nothing + bad_deps = mapMaybe check_node deps + in if null bad_deps + then Nothing + else Just (FixedNodeDependsOnCompileNode key bad_deps) + _ -> Nothing + + +{- Note [Module Types in the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules can be one of two different types in the module graph. + +1. ModuleNodeCompile, modules with source files we can compile. +2. ModuleNodeFixed, modules which we presume are already compiled and available. + +The ModuleGraph can contain a combination of these two types of nodes but must +obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant +can be checked by the `checkModuleGraph` function, but it's +the responsibility of the code constructing the ModuleGraph to ensure it is upheld. + +At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes. + +In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know +information about the module graph still (for example, getLinkDeps). + +In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and +there is a simple test in FixedNodes, which can be extended in future to cover +any missing cases. + +-} +data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation + | ModuleNodeCompile ModSummary + +-- | Extract the Module from a ModuleNodeInfo +moduleNodeInfoModule :: ModuleNodeInfo -> Module +moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key +moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms + +-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo +moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid +moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key +moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms + +-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it. +moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource +moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing +moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms) + +-- | Extract the ModLocation from a ModuleNodeInfo +moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation +moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc +moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms + +-- | Extract the IsBootInterface from a ModuleNodeInfo +isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface +isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib +isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms + +-- | Extract the ModuleName from a ModuleNodeInfo +moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName +moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) + moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName -moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn) +moduleGraphNodeModule mgn = moduleNodeInfoModuleName <$> (mgNodeIsModule mgn) moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary moduleGraphNodeModSum (InstantiationNode {}) = Nothing moduleGraphNodeModSum (LinkNode {}) = Nothing -moduleGraphNodeModSum (ModuleNode _ ms) = Just ms +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeCompile ms)) = Just ms +moduleGraphNodeModSum (ModuleNode _ (ModuleNodeFixed {})) = Nothing + +mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo +mgNodeIsModule (InstantiationNode {}) = Nothing +mgNodeIsModule (LinkNode {}) = Nothing +mgNodeIsModule (ModuleNode _ ms) = Just ms moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId moduleGraphNodeUnitId mgn = case mgn of InstantiationNode uid _iud -> uid - ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms)) + ModuleNode _ ms -> toUnitId (moduleUnit (moduleNodeInfoModule ms)) LinkNode _ uid -> uid instance Outputable ModuleGraphNode where ppr = \case InstantiationNode _ iuid -> ppr iuid - ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks + ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks LinkNode uid _ -> text "LN:" <+> ppr uid instance Eq ModuleGraphNode where @@ -146,6 +294,12 @@ data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsB instance Outputable ModNodeKeyWithUid where ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + +mnkToModule :: ModNodeKeyWithUid -> Module +mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) + -- | A '@ModuleGraph@' contains all the nodes from the home package (only). See -- '@ModuleGraphNode@' for information about the nodes. -- @@ -181,7 +335,8 @@ mapMG f mg@ModuleGraph{..} = mg flip fmap mg_mss $ \case InstantiationNode uid iuid -> InstantiationNode uid iuid LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph unionMG a b = @@ -201,30 +356,30 @@ mkHomeModuleMap nodes = where provider_map = Map.fromListWith Set.union - [ (ms_mod_name ms, Set.singleton (ms_unitid ms)) + [ (moduleNodeInfoModuleName ms, Set.singleton (toUnitId (moduleUnit (moduleNodeInfoModule ms)))) | ModuleNode _ ms <- nodes ] complete_units = Set.fromList - [ ms_unitid ms + [ toUnitId (moduleUnit (moduleNodeInfoModule ms)) | ModuleNode _ ms <- nodes ] mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] +mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ] mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] mgModSummaries' = mg_mss --- | Look up a ModSummary in the ModuleGraph --- Looks up the non-boot ModSummary +-- | Look up a ModuleNodeInfo in the ModuleGraph +-- Looks up the non-boot module -- Linear in the size of the module graph -mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss where go (ModuleNode _ ms) - | NotBoot <- isBootSummary ms - , ms_mod ms == m + | NotBoot <- isBootModuleNodeInfo ms + , moduleNodeInfoModule ms == m = Just ms go _ = Nothing @@ -261,7 +416,7 @@ extendMG ModuleGraph{..} deps ms = ModuleGraph , mg_has_holes = False } where - new_mss = ModuleNode deps ms : mg_mss + new_mss = ModuleNode deps (ModuleNodeCompile ms) : mg_mss extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph extendMGInst mg uid depUnitId = mg @@ -274,18 +429,32 @@ extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg } extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph extendMG' mg = \case InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId - ModuleNode deps ms -> extendMG mg deps ms + ModuleNode deps (ModuleNodeCompile ms) -> extendMG mg deps ms + ModuleNode deps mni -> mg + { mg_mss = ModuleNode deps mni : mg_mss mg + , mg_graph = mkTransDeps (ModuleNode deps mni : mg_mss mg) + , mg_home_map = mkHomeModuleMap (ModuleNode deps mni : mg_mss mg) + , mg_has_holes = mg_has_holes mg || maybe False isHsigFile (moduleNodeInfoHscSource mni) + } LinkNode deps uid -> extendMGLink mg uid deps mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph mkModuleGraph = foldr (flip extendMG') emptyMG +-- | A version of mkModuleGraph that checks the module graph for invariants. +mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph +mkModuleGraphChecked nodes = + let mg = mkModuleGraph nodes + in case checkModuleGraph mg of + [] -> Right mg + errors -> Left errors + -- | This function filters out all the instantiation nodes from each SCC of a -- topological sort. Use this with care, as the resulting "strongly connected components" -- may not really be strongly connected in a direct way, as instantiations have been -- removed. It would probably be best to eliminate uses of this function where possible. filterToposortToModules - :: [SCC ModuleGraphNode] -> [SCC ModSummary] + :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo] filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case InstantiationNode _ _ -> Nothing LinkNode{} -> Nothing @@ -314,28 +483,43 @@ showModMsg dflags _ (LinkNode {}) = in text exe_file showModMsg _ _ (InstantiationNode _uid indef_unit) = ppr $ instUnitInstanceOf indef_unit -showModMsg dflags recomp (ModuleNode _ mod_summary) = +showModMsg dflags recomp (ModuleNode _ mni) = if gopt Opt_HideSourcePaths dflags then text mod_str else hsep $ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') , char '(' - , text (op $ msHsFilePath mod_summary) <> char ',' - , message, char ')' ] - + , text (moduleNodeInfoSource mni) <> char ',' + , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ] where - op = normalise - mod_str = moduleNameString (moduleName (ms_mod mod_summary)) ++ - hscSourceString (ms_hsc_src mod_summary) - dyn_file = op $ msDynObjFilePath mod_summary - obj_file = op $ msObjFilePath mod_summary - files = [ obj_file ] - ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] - ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] - message = case backendSpecialModuleSource (backend dflags) recomp of - Just special -> text special - Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) - + mod_str = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++ + moduleNodeInfoBootString mni + +-- | Extra information about a 'ModuleNodeInfo' to display in the progress message. +moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc +moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) = + let dyn_file = normalise $ msDynObjFilePath mod_summary + obj_file = normalise $ msObjFilePath mod_summary + files = [ obj_file ] + ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] + in case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) +moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed" + +-- | The source location of the module node to show to the user. +moduleNodeInfoSource :: ModuleNodeInfo -> FilePath +moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms +moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc + +-- | The extra info about a module [boot] or [sig] to display. +moduleNodeInfoBootString :: ModuleNodeInfo -> String +moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms) +moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = + hscSourceString (case isBootModuleNodeInfo mn of + IsBoot -> HsBootFile + NotBoot -> HsSrcFile) type SummaryNode = Node Int ModuleGraphNode @@ -384,14 +568,14 @@ moduleGraphNodes drop_hs_boot_nodes summaries = where go (s, key) = case s of - ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes + ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes -- Using nodeDependencies here converts dependencies on other -- boot files to dependencies on dependencies on non-boot files. - -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s) + -> Left (moduleNodeInfoModule ms, nodeDependencies drop_hs_boot_nodes s) _ -> normal_case where normal_case = - let lkup_key = ms_mod <$> moduleGraphNodeModSum s + let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s extra = (lkup_key >>= \key -> Map.lookup key boot_summaries) in Right $ DigraphNode s key $ out_edge_keys $ @@ -423,12 +607,16 @@ newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } mkNodeKey :: ModuleGraphNode -> NodeKey mkNodeKey = \case InstantiationNode _ iu -> NodeKey_Unit iu - ModuleNode _ x -> NodeKey_Module $ msKey x + ModuleNode _ x -> NodeKey_Module $ mnKey x LinkNode _ uid -> NodeKey_Link uid msKey :: ModSummary -> ModNodeKeyWithUid msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) +mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid +mnKey (ModuleNodeFixed key _) = key +mnKey (ModuleNodeCompile ms) = msKey ms + type ModNodeKey = ModuleNameWithIsBoot ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -1401,10 +1401,11 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ text "loading package database" <+> OsPath.pprOsPath db_path - forM_ (Set.toList override_set) $ \pkg -> - debugTraceMsg logger 2 $ - text "package" <+> ppr pkg <+> - text "overrides a previously defined package" + when (log_verbosity (logFlags logger) >= 2) $ + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg logger 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" return (pkg_map', prec_map') where db_map = mk_pkg_map db @@ -2382,4 +2383,3 @@ implicitPackageDeps dflags = [thUnitId | xopt TemplateHaskellQuotes dflags] -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but -- it is possible to not depend on base (for example, see `ghc-prim`) - ===================================== ghc/GHCi/UI.hs ===================================== @@ -61,7 +61,7 @@ import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, GetDocsFailure(..), pushLogHookM, - getModuleGraph, handleSourceError, ms_mod ) + getModuleGraph, handleSourceError ) import GHC.Driver.Main (hscParseModuleWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp import GHC.Hs @@ -1753,7 +1753,7 @@ editFile str = -- of those. chooseEditFile :: GHC.GhcMonad m => m String chooseEditFile = - do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModSummary x + do let hasFailed (GHC.ModuleNode _deps x) = fmap not $ isLoadedModuleNode x hasFailed _ = return False graph <- GHC.getModuleGraph @@ -1762,7 +1762,7 @@ chooseEditFile = let order g = flattenSCCs $ filterToposortToModules $ GHC.topSortModuleGraph True g Nothing pick xs = case xs of - x : _ -> GHC.ml_hs_file (GHC.ms_location x) + x : _ -> GHC.ml_hs_file (GHC.moduleNodeInfoLocation x) _ -> Nothing case pick (order failed_graph) of @@ -2205,7 +2205,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do (m:_) -> load_this m where - is_loaded (GHC.ModuleNode _ ms) = isLoadedModSummary ms + is_loaded (GHC.ModuleNode _ ms) = isLoadedModuleNode ms is_loaded _ = return False findTarget mds t @@ -2214,13 +2214,13 @@ setContextAfterLoad keep_ctxt (Just graph) = do (m:_) -> Just m (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetModule m } - = if GHC.ms_mod_name summary == m then Just summary else Nothing + = if GHC.moduleNodeInfoModuleName summary == m then Just summary else Nothing (GHC.ModuleNode _ summary) `matches` Target { targetId = TargetFile f _ } - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = + | Just f' <- GHC.ml_hs_file (GHC.moduleNodeInfoLocation summary) = if f == f' then Just summary else Nothing _ `matches` _ = Nothing - load_this summary | m <- GHC.ms_mod summary = do + load_this summary | m <- GHC.moduleNodeInfoModule summary = do is_interp <- GHC.moduleIsInterpreted m dflags <- getDynFlags let star_ok = is_interp && not (safeLanguageOn dflags) @@ -2270,7 +2270,7 @@ keepPackageImports = filterM is_pkg_import -modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> LoadType -> m () +modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModuleNodeInfo] -> LoadType -> m () modulesLoadedMsg ok mods load_type = do dflags <- getDynFlags when (verbosity dflags > 0) $ do @@ -2307,11 +2307,11 @@ modulesLoadedMsg ok mods load_type = do | otherwise = "Failed" mod_name mod = do - is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod + is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable (GHC.moduleNodeInfoModule mod) pure $ if is_interpreted - then ppr (GHC.ms_mod mod) - else ppr (GHC.ms_mod mod) - <+> parens (text $ normalise $ msObjFilePath mod) + then ppr (GHC.moduleNodeInfoModule mod) + else ppr (GHC.moduleNodeInfoModule mod) + <+> parens (text $ normalise $ (ml_obj_file (GHC.moduleNodeInfoLocation mod))) -- Fix #9887 -- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors @@ -3376,10 +3376,10 @@ showModules = do let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m) mapM_ show_one loaded_mods -getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary] +getLoadedModules :: GHC.GhcMonad m => m [GHC.ModuleNodeInfo] getLoadedModules = do graph <- GHC.getModuleGraph - filterM isLoadedModSummary (GHC.mgModSummaries graph) + filterM isLoadedModuleNode (mapMaybe GHC.mgNodeIsModule (GHC.mgModSummaries' graph)) showBindings :: GHC.GhcMonad m => m () showBindings = do @@ -3407,8 +3407,10 @@ showBindings = do printTyThing :: GHC.GhcMonad m => TyThing -> m () printTyThing tyth = printForUser (pprTyThing showToHeader tyth) -isLoadedModSummary :: GHC.GhcMonad m => ModSummary -> m Bool -isLoadedModSummary ms = GHC.isLoadedModule (ms_unitid ms) (ms_mod_name ms) +isLoadedModuleNode :: GHC.GhcMonad m => GHC.ModuleNodeInfo -> m Bool +isLoadedModuleNode ms = + let m = GHC.moduleNodeInfoModule ms + in GHC.isLoadedModule (moduleUnitId m) (moduleName m) {- Note [Filter bindings] @@ -3697,7 +3699,7 @@ completeModule = wrapIdentCompleterMod $ \w -> do hsc_env <- GHC.getSession query <- liftIO $ hscUnitIndexQuery hsc_env let pkg_mods = allVisibleModules (hsc_units hsc_env) query - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods @@ -3710,7 +3712,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do return $ map iiModuleName imports _ -> do let pkg_mods = allVisibleModules (hsc_units hsc_env) query - loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules + loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules @@ -4360,11 +4362,11 @@ listModuleLine modl line = do graph <- GHC.getModuleGraph let this = GHC.mgLookupModule graph modl case this of - Nothing -> panic "listModuleLine" - Just summ -> do + Just (GHC.ModuleNodeCompile summ) -> do let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ)) loc = mkRealSrcLoc (mkFastString (filename)) line 0 listAround (realSrcLocSpan loc) False + _ -> panic "listModuleLine" -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit bca637b3738490fed62f228ae4c90834a72de552 +Subproject commit 2bf01c6a9dcf6ec54f5ce99b16a411d4b13f5be9 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a1c0d246ec2ac4a21571e4a1b6ded… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2a1c0d246ec2ac4a21571e4a1b6ded… You're receiving this email because of your account on gitlab.haskell.org.

1 0