April 2025 - ghc-commits

[Git][ghc/ghc][wip/splice-imports-2025] Fix IsBoot instance
by Matthew Pickering (＠mpickering) 16 Apr '25

16 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: 1e1422c8 by Matthew Pickering at 2025-04-16T21:35:09+01:00 Fix IsBoot instance - - - - - 1 changed file: - compiler/GHC/Utils/Binary.hs Changes: ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1080,10 +1080,13 @@ instance Enum a => Binary (EnumBinary a) where deriving via (EnumBinary ImportLevel) instance Binary ImportLevel instance Binary IsBootInterface where - put_ bh IsBoot = put_ bh False - put_ bh NotBoot = put_ bh True + put_ bh ib = put_ bh (case ib of + IsBoot -> True + NotBoot -> False) get bh = do x <- get bh - return $ if x then IsBoot else NotBoot + return $ case x of + True -> IsBoot + False -> NotBoot {- Finally - a reasonable portable Integer instance. @@ -2161,4 +2164,4 @@ instance Binary a => Binary (FingerprintWithValue a) where instance NFData a => NFData (FingerprintWithValue a) where rnf (FingerprintWithValue fp mflags) - = rnf fp `seq` rnf mflags `seq` () \ No newline at end of file + = rnf fp `seq` rnf mflags `seq` () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e1422c8a8e163070028b4b064544e6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1e1422c8a8e163070028b4b064544e6… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Use a strict map for macro defines
by Alan Zimmerman (＠alanz) 16 Apr '25

16 Apr '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 6ff34ae9 by Alan Zimmerman at 2025-04-16T20:10:15+01:00 Use a strict map for macro defines - - - - - 3 changed files: - compiler/GHC/Parser/PreProcess/State.hs - + utils/check-cpp/Example12.hs - + utils/check-cpp/Example13.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/State.hs ===================================== @@ -32,8 +32,8 @@ module GHC.Parser.PreProcess.State ( import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty qualified as NonEmpty -import Data.Map (Map) -import Data.Map qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Maybe (isJust) import GHC.Base import GHC.Data.StringBuffer @@ -317,7 +317,7 @@ addDefine name def = do addDefine' :: PpState -> MacroName -> MacroDef -> PpState addDefine' s name def = - s{pp_defines = insertMacroDef name def (pp_defines s)} + s{ pp_defines = insertMacroDef name def (pp_defines s)} ppDefine :: MacroName -> MacroDef -> PP () ppDefine name val = addDefine name val ===================================== utils/check-cpp/Example12.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE + GHC_CPP + , DeriveGeneric +#-} + +module Example12 where ===================================== utils/check-cpp/Example13.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE GHC_CPP #-} +-- {-# OPTIONS -ddump-ghc-cpp -dkeep-comments #-} +module Example13 where + +foo = +#if MIN_VERSION_GLASGOW_HASKELL(19,13,20250101,0) + 'a' +#else + 'b' +#endif View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ff34ae924b99fa7abe1f96b1741924… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ff34ae924b99fa7abe1f96b1741924… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/splice-imports-2025] missing files
by Matthew Pickering (＠mpickering) 16 Apr '25

16 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: 109a58bf by Matthew Pickering at 2025-04-16T19:21:28+01:00 missing files - - - - - 2 changed files: - + compiler/Language/Haskell/Syntax/ImpExp/ImportLevel.hs - + compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs Changes: ===================================== compiler/Language/Haskell/Syntax/ImpExp/ImportLevel.hs ===================================== @@ -0,0 +1,10 @@ +-- | A module to define 'ImportLevel' so it can be given an Outputable instance +-- without introducing module loops. +module Language.Haskell.Syntax.ImpExp.ImportLevel ( ImportLevel(..) ) where + + +import Prelude (Eq, Ord, Show, Enum) +import Data.Data (Data) + +data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum) + ===================================== compiler/Language/Haskell/Syntax/ImpExp/IsBoot.hs ===================================== @@ -0,0 +1,15 @@ +module Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) where + +import Prelude (Eq, Ord, Show) +import Data.Data (Data) +import Control.DeepSeq (NFData(..), rwhnf) + +-- | Indicates whether a module name is referring to a boot interface (hs-boot +-- file) or regular module (hs file). We need to treat boot modules specially +-- when building compilation graphs, since they break cycles. Regular source +-- files and signature files are treated equivalently. +data IsBootInterface = NotBoot | IsBoot + deriving (Eq, Ord, Show, Data) + +instance NFData IsBootInterface where + rnf = rwhnf \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/109a58bf52f76ffaefc12b73a769106… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/109a58bf52f76ffaefc12b73a769106… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: base: remove .Internal modules (e.g. GHC.TypeLits)
by Marge Bot (＠marge-bot) 16 Apr '25

16 Apr '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 395e0ad1 by sheaf at 2025-04-16T12:33:26-04:00 base: remove .Internal modules (e.g. GHC.TypeLits) This commit removes the following internal modules from base, as per CLC proposal 217: - GHC.TypeNats.Internal - GHC.TypeLits.Internal - GHC.ExecutionStack.Internal Fixes #25007 - - - - - 2bc537ad by Sylvain Henry at 2025-04-16T13:06:44-04:00 RTS: remove target info and fix host info (#24058) The RTS isn't a compiler, hence it doesn't have a target and we remove the reported target info displayed by "+RTS --info". We also fix the host info displayed by "+RTS --info": the host of the RTS is the RTS-building compiler's target, not the compiler's host (wrong when doing cross-compilation). - - - - - c043a4f8 by Sylvain Henry at 2025-04-16T13:06:44-04:00 RTS: remove build info As per the discussion in !13967, there is no reason to tag the RTS with information about the build platform. - - - - - e08a689a by Patrick at 2025-04-16T13:06:49-04:00 Refactor Handling of Multiple Default Declarations Fixes: #25912, #25914, #25934 Previously, GHC discarded all loaded defaults (tcg_default) when local defaults were encountered during typechecking. According to the exportable-named-default proposal (sections 2.4.2 and 2.4.3), local defaults should be merged into tcg_default, retaining any defaults already present while overriding where necessary. Key Changes: * Introduce DefaultProvenance to track the origin of default declarations (local, imported, or built-in), replacing the original cd_module in ClassDefaults with cd_provenance :: DefaultProvenance. * Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only converting renamed class defaults into ClassDefaults. * Add extendDefaultEnvWithLocalDefaults to merge local defaults into the environment, with proper duplication checks: - Duplicate local defaults for a class trigger an error. - Local defaults override imported or built-in defaults. * Update and add related notes: Note [Builtin class defaults], Note [DefaultProvenance]. * Add regression tests: T25912, T25914, T25934. Thanks sam and simon for the help on this patch. Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - 30 changed files: - compiler/GHC/Driver/Session.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Default.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Types/DefaultEnv.hs - hadrian/src/Settings/Packages.hs - libraries/base/base.cabal.in - libraries/base/changelog.md - − libraries/base/src/GHC/ExecutionStack/Internal.hs - − libraries/base/src/GHC/TypeLits/Internal.hs - − libraries/base/src/GHC/TypeNats/Internal.hs - rts/RtsUtils.c - testsuite/ghc-config/ghc-config.hs - + testsuite/tests/default/T25912.hs - + testsuite/tests/default/T25912.stdout - + testsuite/tests/default/T25912_helper.hs - + testsuite/tests/default/T25914.hs - + testsuite/tests/default/T25934.hs - testsuite/tests/default/all.T - testsuite/tests/default/default-fail03.stderr - 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/linters/notes.stdout - testsuite/tests/module/mod58.stderr Changes: ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -236,6 +236,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile +import GHC.Platform.ArchOS import GHC.Unit.Types import GHC.Unit.Parser @@ -3455,6 +3456,9 @@ compilerInfo dflags ("Build platform", cBuildPlatformString), ("Host platform", cHostPlatformString), ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("target os string", stringEncodeOS (platformOS (targetPlatform dflags))), + ("target arch string", stringEncodeArch (platformArch (targetPlatform dflags))), + ("target word size in bits", show (platformWordSizeInBits (targetPlatform dflags))), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), ("Have native code generator", showBool $ platformNcgSupported platform), ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -118,7 +118,7 @@ import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv ) +import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info @@ -1333,7 +1333,7 @@ tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name ; let warn = fmap fromIfaceWarningTxt iface_warn ; return ClassDefaults { cd_class = cls , cd_types = tys' - , cd_module = Just this_mod + , cd_provenance = DP_Imported this_mod , cd_warn = warn } } where tyThingConClass :: TyThing -> Class ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -85,7 +85,7 @@ import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Types.TH import GHC.Tc.Utils.TcType -import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_module)) +import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..)) import GHC.Types.Error import GHC.Types.Error.Codes import GHC.Types.Hint @@ -582,11 +582,19 @@ instance Diagnostic TcRnMessage where TcRnMultipleDefaultDeclarations cls dup_things -> mkSimpleDecorated $ hang (text "Multiple default declarations for class" <+> quotes (ppr cls)) - 2 (vcat (map pp dup_things)) + 2 (pp dup_things) where - pp :: LDefaultDecl GhcRn -> SDoc - pp (L locn DefaultDecl {}) - = text "here was another default declaration" <+> ppr (locA locn) + pp :: ClassDefaults -> SDoc + pp (ClassDefaults { cd_provenance = prov }) + = case prov of + DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 } + -> let + what = + if isH98 + then text "default declaration" + else text "named default declaration" + in text "conflicting" <+> what <+> text "at:" <+> ppr loc + _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults TcRnBadDefaultType ty deflt_clss -> mkSimpleDecorated $ hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") @@ -7139,7 +7147,7 @@ pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs = -------------------------------------------------------------------------------- defaultTypesAndImport :: ClassDefaults -> SDoc -defaultTypesAndImport ClassDefaults{cd_types, cd_module = Just cdm} = +defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} = hang (parens $ pprWithCommas ppr cd_types) 2 (text "imported from" <+> ppr cdm) defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types) ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -1504,7 +1504,7 @@ data TcRnMessage where Text cases: module/mod58 -} - TcRnMultipleDefaultDeclarations :: Class -> [LDefaultDecl GhcRn] -> TcRnMessage + TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports more than one default declaration for the same class, and they are not all ===================================== compiler/GHC/Tc/Gen/Default.hs ===================================== @@ -5,9 +5,10 @@ -} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} -- | Typechecking @default@ declarations -module GHC.Tc.Gen.Default ( tcDefaults ) where +module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where import GHC.Prelude import GHC.Hs @@ -16,7 +17,7 @@ import GHC.Builtin.Names import GHC.Core.Class import GHC.Core.Predicate ( Pred (..), classifyPredType ) -import GHC.Data.Maybe ( firstJusts ) +import GHC.Data.Maybe ( firstJusts, maybeToList ) import GHC.Tc.Errors.Types import GHC.Tc.Gen.HsType @@ -30,20 +31,17 @@ import GHC.Tc.Utils.TcMType ( newWanted ) import GHC.Tc.Utils.TcType import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), defaultEnv ) +import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) ) import GHC.Types.SrcLoc -import GHC.Unit.Types (Module, ghcInternalUnit, moduleUnit) +import GHC.Unit.Types (ghcInternalUnit, moduleUnit) -import GHC.Utils.Misc (fstOf3, sndOf3) import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt -import Data.Function (on) -import Data.List.NonEmpty ( NonEmpty (..), groupBy ) +import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) import Data.Traversable ( for ) {- Note [Named default declarations] @@ -86,7 +84,7 @@ The moving parts are as follows: * The `DefaultEnv` of all defaults in scope in a module is kept in the `tcg_default` field of `TcGblEnv`. -* This field is populated by `GHC.Tc.Gen.Default.tcDefaults` which typechecks +* This field is populated by `GHC.Tc.Gen.Default.tcDefaultDecls` which typechecks any local or imported `default` declarations. * Only a single default declaration can be in effect in any single module for @@ -103,7 +101,7 @@ The moving parts are as follows: in effect be `default Num (Integer, Double)` as specified by Haskell Language Report. - See Note [Default class defaults] in GHC.Tc.Utils.Env + See Note [Builtin class defaults] in GHC.Tc.Utils.Env * Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings` extensions also affect the traditional `default` declarations that don't name @@ -120,61 +118,54 @@ The moving parts are as follows: tracked separately from `ImportAvails`, and returned separately from them by `GHC.Rename.Names.rnImports`. -* Class defaults are exported explicitly, as the example above shows. A module's - exported defaults are tracked in `tcg_default_exports`, which are then - transferred to `mg_defaults`, `md_defaults`, and `mi_defaults_`. +* Class defaults are exported explicitly. + For example, + module M( ..., default C, ... ) + exports the defaults for class C. + + A module's exported defaults are computed by exports_from_avail, + tracked in tcg_default_exports, which are then transferred to mg_defaults, + md_defaults, and mi_defaults_. + + Only defaults explicitly exported are actually exported. + (i.e. No defaults are exported in a module header like: + module M where ...) + See Note [Default exports] in GHC.Tc.Gen.Export * Since the class defaults merely help the solver infer the correct types, they leave no trace in Haskell Core. -} --- See Note [Named default declarations] -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM DefaultEnv -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. - -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys - -tcDefaults decls - = do { tcg_env <- getGblEnv - ; let - here = tcg_mod tcg_env - is_internal_unit = moduleUnit here == ghcInternalUnit - ; case (is_internal_unit, decls) of - -- Some internal GHC modules contain @default ()@ to declare that no defaults can take place - -- in the module. - -- We shortcut the treatment of such a default declaration with no class nor types: we won't - -- try to point 'cd_class' to 'Num' since it may not even exist yet. - { (True, [L _ (DefaultDecl _ Nothing [])]) - -> return $ defaultEnv [] - -- Otherwise we take apart the declaration into the class constructor and its default types. - ; _ -> - do { h2010_dflt_clss <- getH2010DefaultClasses - ; decls' <- mapMaybeM (declarationParts h2010_dflt_clss) decls - ; let - -- Find duplicate default declarations - decl_tag (mb_cls, _, _) = - case mb_cls of - Nothing -> Nothing - Just cls -> if cls `elem` h2010_dflt_clss - then Nothing - else Just cls - decl_groups = groupBy ((==) `on` decl_tag) decls' - ; decls_without_dups <- mapM (reportDuplicates here h2010_dflt_clss) decl_groups - ; return $ defaultEnv (concat decls_without_dups) - } } } +-- | Typecheck a collection of default declarations. These can be either: +-- +-- - Haskell 98 default declarations, of the form @default (Float, Double)@ +-- - Named default declarations, of the form @default Cls(Int, Char)@. +-- See Note [Named default declarations] +tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] +tcDefaultDecls decls = + do + tcg_env <- getGblEnv + let here = tcg_mod tcg_env + is_internal_unit = moduleUnit here == ghcInternalUnit + case (is_internal_unit, decls) of + -- No default declarations + (_, []) -> return [] + -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults], + -- some modules in ghc-internal include an empty `default ()` declaration, in order + -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`), + -- but we must still make sure not to error if we fail to look up e.g. the 'Num' + -- typeclass when typechecking such a default declaration. To do this, we wrap + -- calls of 'tcLookupClass' in 'tryTc'. + (True, [L _ (DefaultDecl _ Nothing [])]) -> do + h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames + case NE.nonEmpty h2010_dflt_clss of + Nothing -> return [] + Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls + -- Otherwise we take apart the declaration into the class constructor and its default types. + _ -> do + h2010_dflt_clss <- getH2010DefaultClasses + toClassDefaults h2010_dflt_clss decls where getH2010DefaultClasses :: TcM (NonEmpty Class) -- All the classes subject to defaulting with a Haskell 2010 default @@ -186,18 +177,18 @@ tcDefaults decls -- No extensions: Num -- OverloadedStrings: add IsString -- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable - getH2010DefaultClasses - = do { num_cls <- tcLookupClass numClassName - ; ovl_str <- xoptM LangExt.OverloadedStrings + getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames + getH2010DefaultNames + = do { ovl_str <- xoptM LangExt.OverloadedStrings ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules - ; deflt_str <- if ovl_str - then mapM tcLookupClass [isStringClassName] - else return [] - ; deflt_interactive <- if ext_deflt - then mapM tcLookupClass interactiveClassNames - else return [] - ; let extra_clss = deflt_str ++ deflt_interactive - ; return $ num_cls :| extra_clss + ; let deflt_str = if ovl_str + then [isStringClassName] + else [] + ; let deflt_interactive = if ext_deflt + then interactiveClassNames + else [] + ; let extra_clss_names = deflt_str ++ deflt_interactive + ; return $ numClassName :| extra_clss_names } declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type])) declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys)) @@ -220,20 +211,49 @@ tcDefaults decls ; return (Just cls, decl, tau_tys) } } - reportDuplicates :: Module -> NonEmpty Class -> NonEmpty (Maybe Class, LDefaultDecl GhcRn, [Type]) -> TcM [ClassDefaults] - reportDuplicates here h2010_dflt_clss ((mb_cls, _, tys) :| []) - = pure [ ClassDefaults{cd_class = c, cd_types = tys, cd_module = Just here, cd_warn = Nothing } - | c <- case mb_cls of - Nothing -> NE.toList h2010_dflt_clss - Just cls -> [cls] - ] - -- Report an error on multiple default declarations for the same class in the same module. - -- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module - reportDuplicates _ (num_cls :| _) decls@((_, L locn _, _) :| _) - = setSrcSpan (locA locn) (addErrTc $ dupDefaultDeclErr cls (sndOf3 <$> decls)) - >> pure [] + toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] + toClassDefaults h2010_dflt_clss dfs = do + dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs + return $ concatMap (go False) dfs where - cls = fromMaybe num_cls $ firstJusts (fmap fstOf3 decls) + go h98 = \case + (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss] + (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)] + +-- | Extend the default environment with the local default declarations +-- and do the action in the extended environment. +extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a +extendDefaultEnvWithLocalDefaults decls action = do + tcg_env <- getGblEnv + let default_env = tcg_default tcg_env + new_default_env <- insertDefaultDecls default_env decls + updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action + +-- | Insert local default declarations into the default environment. +-- +-- See 'insertDefaultDecl'. +insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv +insertDefaultDecls = foldrM insertDefaultDecl +-- | Insert a local default declaration into the default environment. +-- +-- If the class already has a local default declaration in the DefaultEnv, +-- report an error and return the original DefaultEnv. Otherwise, override +-- any existing default declarations (e.g. imported default declarations). +-- +-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module +insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv +insertDefaultDecl (L decl_loc new_cls_defaults ) default_env = + case lookupDefaultEnv default_env (className cls) of + Just cls_defaults + | DP_Local {} <- cd_provenance cls_defaults + -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults) + ; return default_env } + _ -> return $ insertDefaultEnv new_cls_defaults default_env + -- NB: this overrides imported and built-in default declarations + -- for this class, if there were any. + where + cls = cd_class new_cls_defaults + -- | Check that the type is an instance of at least one of the default classes. -- @@ -289,10 +309,6 @@ simplifyDefault cls dflt_ty@(L l _) -> Nothing } -dupDefaultDeclErr :: Class -> NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage -dupDefaultDeclErr cls (L _ DefaultDecl {} :| dup_things) - = TcRnMultipleDefaultDeclarations cls dup_things - {- Note [Instance check for default declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see a named default declaration, such as: @@ -327,4 +343,4 @@ whether each type is an instance of: - ... or the IsString class, with -XOverloadedStrings - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes, with -XExtendedDefaultRules --} \ No newline at end of file +-} ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -282,7 +282,7 @@ example, would import the above `default IsString (Text, String)` declaration into the importing module. -The `cd_module` field of `ClassDefaults` tracks the module whence the default was +The `cd_provenance` field of `ClassDefaults` tracks the module whence the default was imported from, for the purpose of warning reports. The said warning report may be triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to the default export. In the latter case the warning text is stored in the ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -383,6 +383,7 @@ the actual contents of the module are wired in to GHC. -} {- Note [Disambiguation of multiple default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Note [Named default declarations] in GHC.Tc.Gen.Default @@ -1811,9 +1812,8 @@ tcTyClsInstDecls tycl_decls deriv_decls default_decls binds -- -- But only after we've typechecked 'default' declarations. -- See Note [Typechecking default declarations] - defaults <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = defaults }) $ do { - + defaults <- tcDefaultDecls default_decls + ; extendDefaultEnvWithLocalDefaults defaults $ do { -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ===================================== compiler/GHC/Tc/Utils/Env.hs ===================================== @@ -128,8 +128,7 @@ import GHC.Types.SourceFile import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..), - defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv ) +import GHC.Types.DefaultEnv import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) @@ -971,21 +970,28 @@ isBrackStage _other = False ************************************************************************ -} -{- Note [Default class defaults] +{- Note [Builtin class defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In absence of user-defined `default` declarations, the set of class defaults in -effect (i.e. `DefaultEnv`) is determined by the absence or -presence of the `ExtendedDefaultRules` and `OverloadedStrings` extensions. In their -absence, the only rule in effect is `default Num (Integer, Double)` as specified by -Haskell Language Report. - -In GHC's internal packages `DefaultEnv` is empty to minimize cross-module dependencies: -the `Num` class or `Integer` type may not even be available in low-level modules. If -you don't do this, attempted defaulting in package ghc-prim causes an actual crash -(attempting to look up the `Integer` type). - -A user-defined `default` declaration overrides the defaults for the specified class, -and only for that class. +In the absence of user-defined `default` declarations, the set of class defaults in +effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and +`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect +is `default Num (Integer, Double)`, as specified by the Haskell 2010 report. + +Remark [No built-in defaults in ghc-internal] + + When typechecking the ghc-internal package, we **do not** include any built-in + defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may + not even be available (they haven't been typechecked yet). + +Remark [default () in ghc-internal] + + Historically, modules inside ghc-internal have used a single default declaration, + of the form `default ()`, to work around the problem described in + Remark [No built-in defaults in ghc-internal]. + + When we typecheck such a default declaration, we must also make sure not to fail + if e.g. 'Num' is not in scope. We thus have special treatment for this case, + in 'GHC.Tc.Gen.Default.tcDefaultDecls'. -} tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types @@ -997,7 +1003,7 @@ tcGetDefaultTys -- See also #1974 builtinDefaults cls tys = ClassDefaults{ cd_class = cls , cd_types = tys - , cd_module = Nothing + , cd_provenance = DP_Builtin , cd_warn = Nothing } -- see Note [Named default declarations] in GHC.Tc.Gen.Default @@ -1005,7 +1011,8 @@ tcGetDefaultTys ; this_module <- tcg_mod <$> getGblEnv ; let this_unit = moduleUnit this_module ; if this_unit == ghcInternalUnit - -- see Note [Default class defaults] + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env then return (defaults, extended_defaults) else do -- not one of the built-in units @@ -1037,6 +1044,8 @@ tcGetDefaultTys } -- The Num class is already user-defaulted, no need to construct the builtin default _ -> pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults + -- override them. ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ] ; return (deflt_tys, extended_defaults) } } ===================================== compiler/GHC/Types/DefaultEnv.hs ===================================== @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} module GHC.Types.DefaultEnv ( ClassDefaults (..) + , DefaultProvenance (..) , DefaultEnv , emptyDefaultEnv , isEmptyDefaultEnv @@ -12,6 +14,8 @@ module GHC.Types.DefaultEnv , defaultList , plusDefaultEnv , mkDefaultEnv + , insertDefaultEnv + , isHaskell2010Default ) where @@ -22,6 +26,7 @@ import GHC.Tc.Utils.TcType (Type) import GHC.Types.Name (Name, nameUnique, stableNameCmp) import GHC.Types.Name.Env import GHC.Types.Unique.FM (lookupUFM_Directly) +import GHC.Types.SrcLoc (SrcSpan) import GHC.Unit.Module.Warnings (WarningTxt) import GHC.Unit.Types (Module) import GHC.Utils.Outputable @@ -37,13 +42,73 @@ import Data.Function (on) -- NB: this includes Haskell98 default declarations, at the 'Num' key. type DefaultEnv = NameEnv ClassDefaults +{- Note [DefaultProvenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each `ClassDefault` is annotated with its `DefaultProvenance`, which +says where the default came from. Specifically +* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module + being compiled, at location `loc`, and the boolean `h98` indicates whether + it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`). +* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`. +* `DP_Builtin`: the default was automatically provided by GHC. + see Note [Builtin class defaults] in GHC.Tc.Utils.Env + +These annotations are used to disambiguate multiple defaults for the same class. +For example, consider the following modules: + + module M( default C ) where { default C( ... ) } + module M2( default C) where { import M } + module N( default C () where { default C(... ) } + + module A where { import M2 } + module B where { import M2; import N } + module A1 where { import N; default C ( ... ) } + module B2 where { default C ( ... ); default C ( ... ) } + +When compiling N, the default for C is annotated with DP_Local loc. +When compiling M2, the default for C is annotated with DP_Local M. +When compiling A, the default for C is annotated with DP_Imported M2. + +Cases we needed to disambiguate: + * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N. + * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc. + * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2. + +For how we disambiguate these cases, +See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module. +-} + +-- | The provenance of a collection of default types for a class. +-- see Note [DefaultProvenance] for more details +data DefaultProvenance + -- | A locally defined default declaration. + = DP_Local + { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration + , defaultDeclH98 :: Bool -- ^ Is this a Haskell 98 default declaration? + } + -- | Built-in class defaults. + | DP_Builtin + -- | Imported class defaults. + | DP_Imported Module -- ^ The module from which the defaults were imported + deriving (Eq, Data) + +instance Outputable DefaultProvenance where + ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty) + ppr DP_Builtin = text "built-in" + ppr (DP_Imported mod) = ppr mod + +isHaskell2010Default :: DefaultProvenance -> Bool +isHaskell2010Default = \case + DP_Local { defaultDeclH98 = isH98 } -> isH98 + DP_Builtin -> True + DP_Imported {} -> False + -- | Defaulting type assignments for the given class. data ClassDefaults = ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined , cd_types :: [Type] - , cd_module :: Maybe Module - -- ^ @Nothing@ for built-in, - -- @Just@ the current module or the module whence the default was imported + , cd_provenance :: DefaultProvenance + -- ^ Where the defaults came from -- see Note [Default exports] in GHC.Tc.Gen.Export , cd_warn :: Maybe (WarningTxt GhcRn) -- ^ Warning emitted when the default is used @@ -70,6 +135,9 @@ defaultList :: DefaultEnv -> [ClassDefaults] defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts -- sortBy recovers determinism +insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv +insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d + lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults lookupDefaultEnv env = lookupUFM_Directly env . nameUnique ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -286,10 +286,6 @@ ghcInternalArgs = package ghcInternal ? do rtsPackageArgs :: Args rtsPackageArgs = package rts ? do projectVersion <- getSetting ProjectVersion - hostPlatform <- queryHost targetPlatformTriple - hostArch <- queryHost queryArch - hostOs <- queryHost queryOS - hostVendor <- queryHost queryVendor buildPlatform <- queryBuild targetPlatformTriple buildArch <- queryBuild queryArch buildOs <- queryBuild queryOS @@ -371,18 +367,16 @@ rtsPackageArgs = package rts ? do , input "**/RtsUtils.c" ? pure [ "-DProjectVersion=" ++ show projectVersion - , "-DHostPlatform=" ++ show hostPlatform - , "-DHostArch=" ++ show hostArch - , "-DHostOS=" ++ show hostOs - , "-DHostVendor=" ++ show hostVendor + -- the RTS' host is the compiler's target (the target should be + -- per stage ideally...) + , "-DHostPlatform=" ++ show targetPlatform + , "-DHostArch=" ++ show targetArch + , "-DHostOS=" ++ show targetOs + , "-DHostVendor=" ++ show targetVendor , "-DBuildPlatform=" ++ show buildPlatform , "-DBuildArch=" ++ show buildArch , "-DBuildOS=" ++ show buildOs , "-DBuildVendor=" ++ show buildVendor - , "-DTargetPlatform=" ++ show targetPlatform - , "-DTargetArch=" ++ show targetArch - , "-DTargetOS=" ++ show targetOs - , "-DTargetVendor=" ++ show targetVendor , "-DGhcUnregisterised=" ++ show (yesNo ghcUnreg) , "-DTablesNextToCode=" ++ show (yesNo ghcEnableTNC) , "-DRtsWay=\"rts_" ++ show way ++ "\"" ===================================== libraries/base/base.cabal.in ===================================== @@ -170,7 +170,6 @@ Library , GHC.Exception , GHC.Exception.Type , GHC.ExecutionStack - , GHC.ExecutionStack.Internal , GHC.Exts , GHC.Fingerprint , GHC.Fingerprint.Type @@ -247,9 +246,7 @@ Library , GHC.TopHandler , GHC.TypeError , GHC.TypeLits - , GHC.TypeLits.Internal , GHC.TypeNats - , GHC.TypeNats.Internal , GHC.Unicode , GHC.Weak , GHC.Weak.Finalize ===================================== libraries/base/changelog.md ===================================== @@ -17,6 +17,10 @@ * `Control.Concurrent.threadWaitWriteSTM` * `System.Timeout.timeout` * `GHC.Conc.Signal.runHandlers` + * The following internal modules have been removed from `base`, as per [CLC #217](https://github.com/haskell/core-libraries-committee/issues/217): + * `GHC.TypeLits.Internal` + * `GHC.TypeNats.Internal` + * `GHC.ExecutionStack.Internal`. ## 4.21.0.0 *TBA* * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55)) ===================================== libraries/base/src/GHC/ExecutionStack/Internal.hs deleted ===================================== @@ -1,31 +0,0 @@ --- | --- Module : GHC.Internal.ExecutionStack.Internal --- Copyright : (c) The University of Glasgow 2013-2015 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Internals of the "GHC.ExecutionStack" module. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- --- @since 4.9.0.0 - -module GHC.ExecutionStack.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} ( - -- * Internal - Location (..) - , SrcLoc (..) - , StackTrace - , stackFrames - , stackDepth - , collectStackTrace - , showStackFrames - , invalidateDebugCache - ) where - -import GHC.Internal.ExecutionStack.Internal ===================================== libraries/base/src/GHC/TypeLits/Internal.hs deleted ===================================== @@ -1,35 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | --- --- Module : GHC.TypeLits.Internal --- Copyright : (c) The University of Glasgow, 1994-2000 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- __Do not use this module.__ Use "GHC.TypeLits" instead. --- --- This module is internal-only and was exposed by accident. It may be --- removed without warning in a future version. --- --- /The API of this module is unstable and is tightly coupled to GHC's internals./ --- If depend on it, make sure to use a tight upper bound, e.g., @base < 4.X@ rather --- than @base < 5@, because the interface can change rapidly without much warning. --- --- The technical reason for this module's existence is that it is needed --- to prevent module cycles while still allowing these identifiers to be --- imported in "Data.Type.Ord". --- --- @since 4.16.0.0 - -module GHC.TypeLits.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} - (Symbol, - CmpSymbol, - CmpChar - ) where - -import GHC.Internal.TypeLits.Internal ===================================== libraries/base/src/GHC/TypeNats/Internal.hs deleted ===================================== @@ -1,9 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - -module GHC.TypeNats.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} - (Natural, - CmpNat - ) where - -import GHC.Internal.TypeNats.Internal ===================================== rts/RtsUtils.c ===================================== @@ -364,18 +364,10 @@ void printRtsInfo(const RtsConfig rts_config) { printf(" [(\"GHC RTS\", \"YES\")\n"); mkRtsInfoPair("GHC version", ProjectVersion); mkRtsInfoPair("RTS way", RtsWay); - mkRtsInfoPair("Build platform", BuildPlatform); - mkRtsInfoPair("Build architecture", BuildArch); - mkRtsInfoPair("Build OS", BuildOS); - mkRtsInfoPair("Build vendor", BuildVendor); mkRtsInfoPair("Host platform", HostPlatform); mkRtsInfoPair("Host architecture", HostArch); mkRtsInfoPair("Host OS", HostOS); mkRtsInfoPair("Host vendor", HostVendor); - mkRtsInfoPair("Target platform", TargetPlatform); - mkRtsInfoPair("Target architecture", TargetArch); - mkRtsInfoPair("Target OS", TargetOS); - mkRtsInfoPair("Target vendor", TargetVendor); mkRtsInfoPair("Word size", TOSTRING(WORD_SIZE_IN_BITS)); // TODO(@Ericson2314) This is a joint property of the RTS and generated // code. The compiler will soon be multi-target so it doesn't make sense to ===================================== testsuite/ghc-config/ghc-config.hs ===================================== @@ -1,6 +1,7 @@ import System.Environment import System.Process import Data.Maybe +import Control.Monad main :: IO () main = do @@ -9,15 +10,25 @@ main = do info <- readProcess ghc ["+RTS", "--info"] "" let fields = read info :: [(String,String)] getGhcFieldOrFail fields "HostOS" "Host OS" - getGhcFieldOrFail fields "WORDSIZE" "Word size" - getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" - getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" - getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" getGhcFieldOrFail fields "RTSWay" "RTS way" + -- support for old GHCs (pre 9.13): infer target platform by querying the rts... + let query_rts = isJust (lookup "Target platform" fields) + when query_rts $ do + getGhcFieldOrFail fields "WORDSIZE" "Word size" + getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform" + getGhcFieldOrFail fields "TargetOS_CPP" "Target OS" + getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture" + info <- readProcess ghc ["--info"] "" let fields = read info :: [(String,String)] + unless query_rts $ do + getGhcFieldOrFail fields "WORDSIZE" "target word size in bits" + getGhcFieldOrFail fields "TARGETPLATFORM" "target platform string" + getGhcFieldOrFail fields "TargetOS_CPP" "target os string" + getGhcFieldOrFail fields "TargetARCH_CPP" "target arch string" + getGhcFieldOrFail fields "GhcStage" "Stage" getGhcFieldOrFail fields "GhcDebugAssertions" "Debug on" getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator" ===================================== testsuite/tests/default/T25912.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE NamedDefaults #-} + +module Main where + +import T25912_helper + +-- now we declare the default instances +-- for the classes C again to check that +-- it won't hide the default instances for class B +default C (String) + +main :: IO () +main = do + print b ===================================== testsuite/tests/default/T25912.stdout ===================================== @@ -0,0 +1 @@ +"String" ===================================== testsuite/tests/default/T25912_helper.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE NamedDefaults #-} + +module T25912_helper ( default C, C(c), default B, b ) where + +class C a where + c :: a +instance C Int where + c = 1 +instance C String where + c = "String" +default C (String) + +class B a where + b :: a +instance B String where + b = "String" +default B (String) ===================================== testsuite/tests/default/T25914.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE NamedDefaults, OverloadedStrings #-} +module NamedDefaultsNum where +import Data.String +default Num () +foo = "abc" ===================================== testsuite/tests/default/T25934.hs ===================================== @@ -0,0 +1,5 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE NamedDefaults #-} +module T25934 where +default Num (Int) +default Show (Int) ===================================== testsuite/tests/default/all.T ===================================== @@ -39,3 +39,6 @@ test('T25858v2', [extra_files(['T25858v2_helper.hs'])], multimod_compile_and_run test('T25858v3', [extra_files(['T25858v3_helper.hs'])], multimod_compile_and_run, ['T25858v3', '']) test('T25858v4', normal, compile_and_run, ['']) test('T25882', normal, compile, ['']) +test('T25912', [extra_files(['T25912_helper.hs'])], multimod_compile_and_run, ['T25912', '']) +test('T25914', normal, compile, ['']) +test('T25934', normal, compile, ['']) ===================================== testsuite/tests/default/default-fail03.stderr ===================================== @@ -1,3 +1,4 @@ -default-fail03.hs:4:1: [GHC-99565] +default-fail03.hs:4:1: error: [GHC-99565] Multiple default declarations for class ‘Num’ - here was another default declaration default-fail03.hs:3:1-29 + conflicting named default declaration at: default-fail03.hs:3:1-29 + ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -5365,20 +5365,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9672,15 +9658,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9727,13 +9704,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -5337,20 +5337,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -12718,15 +12704,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -12773,13 +12750,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -5505,20 +5505,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9890,15 +9876,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9945,13 +9922,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -5365,20 +5365,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9672,15 +9658,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9727,13 +9704,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -8,7 +8,7 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-boun ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode] ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease] ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating] -ref compiler/GHC/Driver/DynFlags.hs:1216:52: Note [Eta-reduction in -O0] +ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0] ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc] ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices] ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice] @@ -18,10 +18,8 @@ ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice] ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families] ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation] -ref compiler/GHC/Tc/Gen/Default.hs:87:6: Note [Disambiguation of multiple default declarations] -ref compiler/GHC/Tc/Gen/Default.hs:193:11: Note [Disambiguation of multiple default declarations] ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention] -ref compiler/GHC/Tc/Gen/HsType.hs:2693:7: Note [Matching a kind signature with a declaration] +ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration] ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings] ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns] ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures] @@ -30,8 +28,6 @@ ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice] ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled] ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances] -ref compiler/GHC/Tc/Module.hs:385:3: Note [Disambiguation of multiple default declarations] -ref compiler/GHC/Tc/Module.hs:420:7: Note [Disambiguation of multiple default declarations] ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting] ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics] ===================================== testsuite/tests/module/mod58.stderr ===================================== @@ -1,4 +1,4 @@ - mod58.hs:4:1: error: [GHC-99565] Multiple default declarations for class ‘Num’ - here was another default declaration mod58.hs:3:1-21 + conflicting default declaration at: mod58.hs:3:1-21 + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65470211952668cee67c06e0ebca8d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/65470211952668cee67c06e0ebca8d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] base: remove .Internal modules (e.g. GHC.TypeLits)
by Marge Bot (＠marge-bot) 16 Apr '25

16 Apr '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 395e0ad1 by sheaf at 2025-04-16T12:33:26-04:00 base: remove .Internal modules (e.g. GHC.TypeLits) This commit removes the following internal modules from base, as per CLC proposal 217: - GHC.TypeNats.Internal - GHC.TypeLits.Internal - GHC.ExecutionStack.Internal Fixes #25007 - - - - - 9 changed files: - libraries/base/base.cabal.in - libraries/base/changelog.md - − libraries/base/src/GHC/ExecutionStack/Internal.hs - − libraries/base/src/GHC/TypeLits/Internal.hs - − libraries/base/src/GHC/TypeNats/Internal.hs - 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 Changes: ===================================== libraries/base/base.cabal.in ===================================== @@ -170,7 +170,6 @@ Library , GHC.Exception , GHC.Exception.Type , GHC.ExecutionStack - , GHC.ExecutionStack.Internal , GHC.Exts , GHC.Fingerprint , GHC.Fingerprint.Type @@ -247,9 +246,7 @@ Library , GHC.TopHandler , GHC.TypeError , GHC.TypeLits - , GHC.TypeLits.Internal , GHC.TypeNats - , GHC.TypeNats.Internal , GHC.Unicode , GHC.Weak , GHC.Weak.Finalize ===================================== libraries/base/changelog.md ===================================== @@ -17,6 +17,10 @@ * `Control.Concurrent.threadWaitWriteSTM` * `System.Timeout.timeout` * `GHC.Conc.Signal.runHandlers` + * The following internal modules have been removed from `base`, as per [CLC #217](https://github.com/haskell/core-libraries-committee/issues/217): + * `GHC.TypeLits.Internal` + * `GHC.TypeNats.Internal` + * `GHC.ExecutionStack.Internal`. ## 4.21.0.0 *TBA* * Change `SrcLoc` to be a strict and unboxed (finishing [CLC proposal #55](https://github.com/haskell/core-libraries-committee/issues/55)) ===================================== libraries/base/src/GHC/ExecutionStack/Internal.hs deleted ===================================== @@ -1,31 +0,0 @@ --- | --- Module : GHC.Internal.ExecutionStack.Internal --- Copyright : (c) The University of Glasgow 2013-2015 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- Internals of the "GHC.ExecutionStack" module. --- --- /The API of this module is unstable and not meant to be consumed by the general public./ --- If you absolutely must depend on it, make sure to use a tight upper --- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can --- change rapidly without much warning. --- --- @since 4.9.0.0 - -module GHC.ExecutionStack.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} ( - -- * Internal - Location (..) - , SrcLoc (..) - , StackTrace - , stackFrames - , stackDepth - , collectStackTrace - , showStackFrames - , invalidateDebugCache - ) where - -import GHC.Internal.ExecutionStack.Internal ===================================== libraries/base/src/GHC/TypeLits/Internal.hs deleted ===================================== @@ -1,35 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | --- --- Module : GHC.TypeLits.Internal --- Copyright : (c) The University of Glasgow, 1994-2000 --- License : see libraries/base/LICENSE --- --- Maintainer : ghc-devs(a)haskell.org --- Stability : internal --- Portability : non-portable (GHC extensions) --- --- __Do not use this module.__ Use "GHC.TypeLits" instead. --- --- This module is internal-only and was exposed by accident. It may be --- removed without warning in a future version. --- --- /The API of this module is unstable and is tightly coupled to GHC's internals./ --- If depend on it, make sure to use a tight upper bound, e.g., @base < 4.X@ rather --- than @base < 5@, because the interface can change rapidly without much warning. --- --- The technical reason for this module's existence is that it is needed --- to prevent module cycles while still allowing these identifiers to be --- imported in "Data.Type.Ord". --- --- @since 4.16.0.0 - -module GHC.TypeLits.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} - (Symbol, - CmpSymbol, - CmpChar - ) where - -import GHC.Internal.TypeLits.Internal ===================================== libraries/base/src/GHC/TypeNats/Internal.hs deleted ===================================== @@ -1,9 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# OPTIONS_HADDOCK not-home #-} - -module GHC.TypeNats.Internal {-# DEPRECATED "This module will be removed from base in the next version (v4.22)" #-} - (Natural, - CmpNat - ) where - -import GHC.Internal.TypeNats.Internal ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -5365,20 +5365,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9672,15 +9658,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9727,13 +9704,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -5337,20 +5337,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -12718,15 +12704,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -12773,13 +12750,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -5505,20 +5505,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9890,15 +9876,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9945,13 +9922,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -5365,20 +5365,6 @@ module GHC.ExecutionStack where getStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe [Location]) showStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String) -module GHC.ExecutionStack.Internal where - -- Safety: None - type Location :: * - data Location = Location {objectName :: GHC.Internal.Base.String, functionName :: GHC.Internal.Base.String, srcLoc :: GHC.Internal.Maybe.Maybe SrcLoc} - type SrcLoc :: * - data SrcLoc = SrcLoc {sourceFile :: GHC.Internal.Base.String, sourceLine :: GHC.Internal.Types.Int, sourceColumn :: GHC.Internal.Types.Int} - type StackTrace :: * - newtype StackTrace = ... - collectStackTrace :: GHC.Internal.Types.IO (GHC.Internal.Maybe.Maybe StackTrace) - invalidateDebugCache :: GHC.Internal.Types.IO () - showStackFrames :: [Location] -> GHC.Internal.Show.ShowS - stackDepth :: StackTrace -> GHC.Internal.Types.Int - stackFrames :: StackTrace -> GHC.Internal.Maybe.Maybe [Location] - module GHC.Exts where -- Safety: None (*#) :: Int# -> Int# -> Int# @@ -9672,15 +9658,6 @@ module GHC.TypeLits where withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Bignum.Integer.Integer -> (forall (n :: Nat). GHC.Internal.Maybe.Maybe (SNat n) -> r) -> r withSomeSSymbol :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). GHC.Internal.Base.String -> (forall (s :: Symbol). SSymbol s -> r) -> r -module GHC.TypeLits.Internal where - -- Safety: Safe - type CmpChar :: GHC.Internal.Types.Char -> GHC.Internal.Types.Char -> GHC.Internal.Types.Ordering - type family CmpChar a b - type CmpSymbol :: Symbol -> Symbol -> GHC.Internal.Types.Ordering - type family CmpSymbol a b - type Symbol :: * - data Symbol - module GHC.TypeNats where -- Safety: Safe type (*) :: Natural -> Natural -> Natural @@ -9727,13 +9704,6 @@ module GHC.TypeNats where withKnownNat :: forall (n :: Nat) (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). SNat n -> (KnownNat n => r) -> r withSomeSNat :: forall (rep :: GHC.Internal.Types.RuntimeRep) (r :: TYPE rep). Natural -> (forall (n :: Nat). SNat n -> r) -> r -module GHC.TypeNats.Internal where - -- Safety: Safe - type CmpNat :: Natural -> Natural -> GHC.Internal.Types.Ordering - type family CmpNat a b - type Natural :: * - data Natural = ... - module GHC.Unicode where -- Safety: Safe type GeneralCategory :: * View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395e0ad17c0d309637f079a05dbdc23… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/395e0ad17c0d309637f079a05dbdc23… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/splice-imports-2025] 4 commits: base: remove .Internal modules (e.g. GHC.TypeLits)
by Matthew Pickering (＠mpickering) 16 Apr '25

16 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: 395e0ad1 by sheaf at 2025-04-16T12:33:26-04:00 base: remove .Internal modules (e.g. GHC.TypeLits) This commit removes the following internal modules from base, as per CLC proposal 217: - GHC.TypeNats.Internal - GHC.TypeLits.Internal - GHC.ExecutionStack.Internal Fixes #25007 - - - - - 670a7274 by Matthew Pickering at 2025-04-16T17:34:09+01:00 Move -fno-code note into Downsweep module This note was left behind when all the code which referred to it was moved into the GHC.Driver.Downsweep module - - - - - 03572517 by Matthew Pickering at 2025-04-16T17:34:10+01:00 Implement Explicit Level Imports for Template Haskell This commit introduces the `ExplicitLevelImports` and `ImplicitStagePersistence` language extensions as proposed in GHC Proposal #682. Key Features ------------ - `ExplicitLevelImports` adds two new import modifiers - `splice` and `quote` - allowing precise control over the level at which imported identifiers are available - `ImplicitStagePersistence` (enabled by default) preserves existing path-based cross-stage persistence behavior - `NoImplicitStagePersistence` disables implicit cross-stage persistence, requiring explicit level imports Benefits -------- - Improved compilation performance by reducing unnecessary code generation - Enhanced IDE experience with faster feedback in `-fno-code` mode - Better dependency tracking by distinguishing compile-time and runtime dependencies - Foundation for future cross-compilation improvements This implementation enables the separation of modules needed at compile-time from those needed at runtime, allowing for more efficient compilation pipelines and clearer code organization in projects using Template Haskell. Implementation Notes -------------------- The level which a name is availble at is stored in the 'GRE', in the normal GlobalRdrEnv. The function `greLevels` returns the levels which a specific GRE is imported at. The level information for a 'Name' is computed by `getStageAndBindLevel`. The level validity is checked by `checkCrossStageLifting`. Instances are checked by `checkWellStagedDFun`, which computes the level an instance by calling `checkWellStagedInstanceWhat`, which sees what is available at by looking at the module graph. Modifications to downsweep -------------------------- Code generation is now only enabled for modules which are needed at compile time. See the Note [-fno-code mode] for more information. Uniform error messages for level errors --------------------------------------- All error messages to do with levels are now reported uniformly using the `TcRnBadlyStaged` constructor. Lift derivation changed ----------------------- Derived lift instances will now not generate code with expression quotations. Before: ``` data A = A Int deriving Lift => lift (A x) = [| A $(lift x) |] ``` After: ``` lift (A x) = conE 'A `appE` (lift x) ``` This is because if you attempt to derive `Lift` in a module where `NoImplicitStagePersistence` is enabled, you would get an infinite loop where a constructor was attempted to be persisted using the instance you are currently defining. GHC API Changes --------------- The ModuleGraph now contains additional information about the type of the edges (normal, quote or splice) between modules. This is abstracted using the `ModuleGraphEdge` data type. Fixes #25828 - - - - - 7bc1c1de by Matthew Pickering at 2025-04-16T17:34:10+01:00 Start on docs - - - - - 218 changed files: - compiler/GHC.hs - compiler/GHC/Data/Graph/Directed/Reachability.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Imported.hs - compiler/GHC/Unit/Module/ModSummary.hs - + compiler/GHC/Unit/Module/Stage.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/ghc.cabal.in - docs/users_guide/exts/control.rst - docs/users_guide/exts/template_haskell.rst - libraries/base/base.cabal.in - libraries/base/changelog.md - − libraries/base/src/GHC/ExecutionStack/Internal.hs - − libraries/base/src/GHC/TypeLits/Internal.hs - − libraries/base/src/GHC/TypeNats/Internal.hs - libraries/base/tests/IO/Makefile - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - testsuite/tests/ado/ado004.stderr - testsuite/tests/annotations/should_fail/annfail03.stderr - testsuite/tests/annotations/should_fail/annfail04.stderr - testsuite/tests/annotations/should_fail/annfail06.stderr - testsuite/tests/annotations/should_fail/annfail09.stderr - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/dependent/should_compile/T14729.stderr - testsuite/tests/dependent/should_compile/T15743.stderr - testsuite/tests/dependent/should_compile/T15743e.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/determinism/determ021/determ021.stdout - + testsuite/tests/driver/T4437.stdout - testsuite/tests/driver/json2.stderr - testsuite/tests/gadt/T19847a.stderr - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/indexed-types/should_compile/T15711.stderr - testsuite/tests/indexed-types/should_compile/T15852.stderr - testsuite/tests/indexed-types/should_compile/T3017.stderr - 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/interface-stability/template-haskell-exports.stdout - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/partial-sigs/should_compile/ADT.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr - testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr - testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr - testsuite/tests/partial-sigs/should_compile/Either.stderr - testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr - testsuite/tests/partial-sigs/should_compile/Every.stderr - testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr - testsuite/tests/partial-sigs/should_compile/Forall1.stderr - testsuite/tests/partial-sigs/should_compile/GenNamed.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr - testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr - testsuite/tests/partial-sigs/should_compile/Meltdown.stderr - testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr - testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr - testsuite/tests/partial-sigs/should_compile/PatBind.stderr - testsuite/tests/partial-sigs/should_compile/PatBind2.stderr - testsuite/tests/partial-sigs/should_compile/PatternSig.stderr - testsuite/tests/partial-sigs/should_compile/Recursive.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr - testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr - testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr - testsuite/tests/partial-sigs/should_compile/SkipMany.stderr - testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr - testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Uncurry.stderr - testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr - testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr - testsuite/tests/polykinds/T15592.stderr - testsuite/tests/polykinds/T15592b.stderr - testsuite/tests/printer/T18052a.stderr - testsuite/tests/quasiquotation/qq001/qq001.stderr - testsuite/tests/quasiquotation/qq002/qq002.stderr - testsuite/tests/quasiquotation/qq003/qq003.stderr - testsuite/tests/quasiquotation/qq004/qq004.stderr - + testsuite/tests/quotes/T5721.stderr - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/HaddockIssue849.stdout - testsuite/tests/showIface/HaddockOpts.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/LanguageExts.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/showIface/PragmaDocs.stdout - testsuite/tests/showIface/ReExports.stdout - + testsuite/tests/splice-imports/ClassA.hs - + testsuite/tests/splice-imports/InstanceA.hs - + testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/SI01.hs - + testsuite/tests/splice-imports/SI01A.hs - + testsuite/tests/splice-imports/SI02.hs - + testsuite/tests/splice-imports/SI03.hs - + testsuite/tests/splice-imports/SI03.stderr - + testsuite/tests/splice-imports/SI04.hs - + testsuite/tests/splice-imports/SI05.hs - + testsuite/tests/splice-imports/SI05.stderr - + testsuite/tests/splice-imports/SI05A.hs - + testsuite/tests/splice-imports/SI06.hs - + testsuite/tests/splice-imports/SI07.hs - + testsuite/tests/splice-imports/SI07.stderr - + testsuite/tests/splice-imports/SI07A.hs - + testsuite/tests/splice-imports/SI08.hs - + testsuite/tests/splice-imports/SI08.stderr - + testsuite/tests/splice-imports/SI08_oneshot.stderr - + testsuite/tests/splice-imports/SI09.hs - + testsuite/tests/splice-imports/SI10.hs - + testsuite/tests/splice-imports/SI13.hs - + testsuite/tests/splice-imports/SI14.hs - + testsuite/tests/splice-imports/SI14.stderr - + testsuite/tests/splice-imports/SI15.hs - + testsuite/tests/splice-imports/SI15.stderr - + testsuite/tests/splice-imports/SI16.hs - + testsuite/tests/splice-imports/SI16.stderr - + testsuite/tests/splice-imports/SI17.hs - + testsuite/tests/splice-imports/SI18.hs - + testsuite/tests/splice-imports/SI18.stderr - + testsuite/tests/splice-imports/SI19.hs - + testsuite/tests/splice-imports/SI19A.hs - + testsuite/tests/splice-imports/SI20.hs - + testsuite/tests/splice-imports/SI20.stderr - + testsuite/tests/splice-imports/SI21.hs - + testsuite/tests/splice-imports/SI21.stderr - + testsuite/tests/splice-imports/SI22.hs - + testsuite/tests/splice-imports/SI22.stderr - + testsuite/tests/splice-imports/SI23.hs - + testsuite/tests/splice-imports/SI23A.hs - + testsuite/tests/splice-imports/SI24.hs - + testsuite/tests/splice-imports/all.T - testsuite/tests/th/T16976z.stderr - testsuite/tests/th/T17820a.stderr - testsuite/tests/th/T17820b.stderr - testsuite/tests/th/T17820c.stderr - testsuite/tests/th/T17820d.stderr - testsuite/tests/th/T17820e.stderr - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T23829_hasty.stderr - testsuite/tests/th/T23829_hasty_b.stderr - testsuite/tests/th/T23829_tardy.ghc.stderr - testsuite/tests/th/T5795.stderr - testsuite/tests/th/TH_Roles2.stderr - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/T21023.stderr - utils/check-exact/ExactPrint.hs - utils/count-deps/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75cb7d70b8fd85b221e07b996e93ec… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75cb7d70b8fd85b221e07b996e93ec… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/splice-imports-2025] 3 commits: Move -fno-code note into Downsweep module
by Matthew Pickering (＠mpickering) 16 Apr '25

16 Apr '25

Matthew Pickering pushed to branch wip/splice-imports-2025 at Glasgow Haskell Compiler / GHC Commits: 6e59256e by Matthew Pickering at 2025-04-16T16:26:54+01:00 Move -fno-code note into Downsweep module This note was left behind when all the code which referred to it was moved into the GHC.Driver.Downsweep module - - - - - c8365be9 by Matthew Pickering at 2025-04-16T16:30:03+01:00 Implement Explicit Level Imports for Template Haskell This commit introduces the `ExplicitLevelImports` and `ImplicitStagePersistence` language extensions as proposed in GHC Proposal #682. Key Features ------------ - `ExplicitLevelImports` adds two new import modifiers - `splice` and `quote` - allowing precise control over the level at which imported identifiers are available - `ImplicitStagePersistence` (enabled by default) preserves existing path-based cross-stage persistence behavior - `NoImplicitStagePersistence` disables implicit cross-stage persistence, requiring explicit level imports Benefits -------- - Improved compilation performance by reducing unnecessary code generation - Enhanced IDE experience with faster feedback in `-fno-code` mode - Better dependency tracking by distinguishing compile-time and runtime dependencies - Foundation for future cross-compilation improvements This implementation enables the separation of modules needed at compile-time from those needed at runtime, allowing for more efficient compilation pipelines and clearer code organization in projects using Template Haskell. Implementation Notes -------------------- The level which a name is availble at is stored in the 'GRE', in the normal GlobalRdrEnv. The function `greLevels` returns the levels which a specific GRE is imported at. The level information for a 'Name' is computed by `getStageAndBindLevel`. The level validity is checked by `checkCrossStageLifting`. Instances are checked by `checkWellStagedDFun`, which computes the level an instance by calling `checkWellStagedInstanceWhat`, which sees what is available at by looking at the module graph. Modifications to downsweep -------------------------- Code generation is now only enabled for modules which are needed at compile time. See the Note [-fno-code mode] for more information. Uniform error messages for level errors --------------------------------------- All error messages to do with levels are now reported uniformly using the `TcRnBadlyStaged` constructor. Lift derivation changed ----------------------- Derived lift instances will now not generate code with expression quotations. Before: ``` data A = A Int deriving Lift => lift (A x) = [| A $(lift x) |] ``` After: ``` lift (A x) = conE 'A `appE` (lift x) ``` This is because if you attempt to derive `Lift` in a module where `NoImplicitStagePersistence` is enabled, you would get an infinite loop where a constructor was attempted to be persisted using the instance you are currently defining. GHC API Changes --------------- The ModuleGraph now contains additional information about the type of the edges (normal, quote or splice) between modules. This is abstracted using the `ModuleGraphEdge` data type. Fixes #25828 - - - - - 75cb7d70 by Matthew Pickering at 2025-04-16T17:33:46+01:00 Start on docs - - - - - 209 changed files: - compiler/GHC.hs - compiler/GHC/Data/Graph/Directed/Reachability.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeFile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Rename/Env.hs - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Splice.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Tc/Utils/Env.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Unit/Home/PackageTable.hs - compiler/GHC/Unit/Module/Deps.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/Imported.hs - compiler/GHC/Unit/Module/ModSummary.hs - + compiler/GHC/Unit/Module/Stage.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/ImpExp.hs - compiler/ghc.cabal.in - docs/users_guide/exts/control.rst - docs/users_guide/exts/template_haskell.rst - libraries/base/tests/IO/Makefile - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - testsuite/tests/ado/ado004.stderr - testsuite/tests/annotations/should_fail/annfail03.stderr - testsuite/tests/annotations/should_fail/annfail04.stderr - testsuite/tests/annotations/should_fail/annfail06.stderr - testsuite/tests/annotations/should_fail/annfail09.stderr - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/dependent/should_compile/T14729.stderr - testsuite/tests/dependent/should_compile/T15743.stderr - testsuite/tests/dependent/should_compile/T15743e.stderr - testsuite/tests/deriving/should_compile/T14682.stderr - testsuite/tests/determinism/determ021/determ021.stdout - + testsuite/tests/driver/T4437.stdout - testsuite/tests/driver/json2.stderr - testsuite/tests/gadt/T19847a.stderr - testsuite/tests/ghc-api/fixed-nodes/FixedNodes.hs - testsuite/tests/ghc-api/fixed-nodes/ModuleGraphInvariants.hs - testsuite/tests/indexed-types/should_compile/T15711.stderr - testsuite/tests/indexed-types/should_compile/T15852.stderr - testsuite/tests/indexed-types/should_compile/T3017.stderr - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/module/mod185.stderr - testsuite/tests/parser/should_compile/DumpParsedAst.stderr - testsuite/tests/parser/should_compile/DumpRenamedAst.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/parser/should_compile/KindSigs.stderr - testsuite/tests/parser/should_compile/T14189.stderr - testsuite/tests/partial-sigs/should_compile/ADT.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr1.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr2.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr3.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr4.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr5.stderr - testsuite/tests/partial-sigs/should_compile/AddAndOr6.stderr - testsuite/tests/partial-sigs/should_compile/BoolToBool.stderr - testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting1MROn.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr - testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr - testsuite/tests/partial-sigs/should_compile/Either.stderr - testsuite/tests/partial-sigs/should_compile/EqualityConstraint.stderr - testsuite/tests/partial-sigs/should_compile/Every.stderr - testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSig.stderr - testsuite/tests/partial-sigs/should_compile/ExpressionSigNamed.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints1.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints2.stderr - testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROff.stderr - testsuite/tests/partial-sigs/should_compile/ExtraNumAMROn.stderr - testsuite/tests/partial-sigs/should_compile/Forall1.stderr - testsuite/tests/partial-sigs/should_compile/GenNamed.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank1.stderr - testsuite/tests/partial-sigs/should_compile/HigherRank2.stderr - testsuite/tests/partial-sigs/should_compile/LocalDefinitionBug.stderr - testsuite/tests/partial-sigs/should_compile/Meltdown.stderr - testsuite/tests/partial-sigs/should_compile/MonoLocalBinds.stderr - testsuite/tests/partial-sigs/should_compile/NamedTyVar.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInDataFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/NamedWildcardInTypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/ParensAroundContext.stderr - testsuite/tests/partial-sigs/should_compile/PatBind.stderr - testsuite/tests/partial-sigs/should_compile/PatBind2.stderr - testsuite/tests/partial-sigs/should_compile/PatternSig.stderr - testsuite/tests/partial-sigs/should_compile/Recursive.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcards.stderr - testsuite/tests/partial-sigs/should_compile/ScopedNamedWildcardsGood.stderr - testsuite/tests/partial-sigs/should_compile/ShowNamed.stderr - testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr - testsuite/tests/partial-sigs/should_compile/SkipMany.stderr - testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr - testsuite/tests/partial-sigs/should_compile/TypeFamilyInstanceLHS.stderr - testsuite/tests/partial-sigs/should_compile/Uncurry.stderr - testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr - testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr - testsuite/tests/polykinds/T15592.stderr - testsuite/tests/polykinds/T15592b.stderr - testsuite/tests/printer/T18052a.stderr - testsuite/tests/quasiquotation/qq001/qq001.stderr - testsuite/tests/quasiquotation/qq002/qq002.stderr - testsuite/tests/quasiquotation/qq003/qq003.stderr - testsuite/tests/quasiquotation/qq004/qq004.stderr - + testsuite/tests/quotes/T5721.stderr - testsuite/tests/roles/should_compile/Roles1.stderr - testsuite/tests/roles/should_compile/Roles14.stderr - testsuite/tests/roles/should_compile/Roles2.stderr - testsuite/tests/roles/should_compile/Roles3.stderr - testsuite/tests/roles/should_compile/Roles4.stderr - testsuite/tests/roles/should_compile/T8958.stderr - testsuite/tests/showIface/DocsInHiFile1.stdout - testsuite/tests/showIface/DocsInHiFileTH.stdout - testsuite/tests/showIface/HaddockIssue849.stdout - testsuite/tests/showIface/HaddockOpts.stdout - testsuite/tests/showIface/HaddockSpanIssueT24378.stdout - testsuite/tests/showIface/LanguageExts.stdout - testsuite/tests/showIface/MagicHashInHaddocks.stdout - testsuite/tests/showIface/NoExportList.stdout - testsuite/tests/showIface/PragmaDocs.stdout - testsuite/tests/showIface/ReExports.stdout - + testsuite/tests/splice-imports/ClassA.hs - + testsuite/tests/splice-imports/InstanceA.hs - + testsuite/tests/splice-imports/Makefile - + testsuite/tests/splice-imports/SI01.hs - + testsuite/tests/splice-imports/SI01A.hs - + testsuite/tests/splice-imports/SI02.hs - + testsuite/tests/splice-imports/SI03.hs - + testsuite/tests/splice-imports/SI03.stderr - + testsuite/tests/splice-imports/SI04.hs - + testsuite/tests/splice-imports/SI05.hs - + testsuite/tests/splice-imports/SI05.stderr - + testsuite/tests/splice-imports/SI05A.hs - + testsuite/tests/splice-imports/SI06.hs - + testsuite/tests/splice-imports/SI07.hs - + testsuite/tests/splice-imports/SI07.stderr - + testsuite/tests/splice-imports/SI07A.hs - + testsuite/tests/splice-imports/SI08.hs - + testsuite/tests/splice-imports/SI08.stderr - + testsuite/tests/splice-imports/SI08_oneshot.stderr - + testsuite/tests/splice-imports/SI09.hs - + testsuite/tests/splice-imports/SI10.hs - + testsuite/tests/splice-imports/SI13.hs - + testsuite/tests/splice-imports/SI14.hs - + testsuite/tests/splice-imports/SI14.stderr - + testsuite/tests/splice-imports/SI15.hs - + testsuite/tests/splice-imports/SI15.stderr - + testsuite/tests/splice-imports/SI16.hs - + testsuite/tests/splice-imports/SI16.stderr - + testsuite/tests/splice-imports/SI17.hs - + testsuite/tests/splice-imports/SI18.hs - + testsuite/tests/splice-imports/SI18.stderr - + testsuite/tests/splice-imports/SI19.hs - + testsuite/tests/splice-imports/SI19A.hs - + testsuite/tests/splice-imports/SI20.hs - + testsuite/tests/splice-imports/SI20.stderr - + testsuite/tests/splice-imports/SI21.hs - + testsuite/tests/splice-imports/SI21.stderr - + testsuite/tests/splice-imports/SI22.hs - + testsuite/tests/splice-imports/SI22.stderr - + testsuite/tests/splice-imports/SI23.hs - + testsuite/tests/splice-imports/SI23A.hs - + testsuite/tests/splice-imports/SI24.hs - + testsuite/tests/splice-imports/all.T - testsuite/tests/th/T16976z.stderr - testsuite/tests/th/T17820a.stderr - testsuite/tests/th/T17820b.stderr - testsuite/tests/th/T17820c.stderr - testsuite/tests/th/T17820d.stderr - testsuite/tests/th/T17820e.stderr - testsuite/tests/th/T21547.stderr - testsuite/tests/th/T23829_hasty.stderr - testsuite/tests/th/T23829_hasty_b.stderr - testsuite/tests/th/T23829_tardy.ghc.stderr - testsuite/tests/th/T5795.stderr - testsuite/tests/th/TH_Roles2.stderr - testsuite/tests/typecheck/should_compile/T12763.stderr - testsuite/tests/typecheck/should_compile/T18406b.stderr - testsuite/tests/typecheck/should_compile/T18529.stderr - testsuite/tests/typecheck/should_compile/T21023.stderr - utils/check-exact/ExactPrint.hs - utils/count-deps/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5dd13cba474d8c4a089d5706b827f2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5dd13cba474d8c4a089d5706b827f2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] driver: Use ModuleGraph for oneshot and --make mode
by Marge Bot (＠marge-bot) 16 Apr '25

16 Apr '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d47bf776 by Matthew Pickering at 2025-04-14T16:44:41+01:00 driver: Use ModuleGraph for oneshot and --make mode This patch uses the `hsc_mod_graph` field for both oneshot and --make mode. Therefore, if part of the compiler requires usage of the module graph, you do so in a uniform way for the two different modes. The `ModuleGraph` describes the relationship between the modules in the home package and units in external packages. The `ModuleGraph` can be queried when information about the transitive closure of a package is needed. For example, the primary use of the ModuleGraph from within the compiler is in the loader, which needs to know the transitive closure of a module so it can load all the relevant objects for evaluation. In --make mode, downsweep computes the ModuleGraph before any compilation starts. In oneshot mode, a thunk is created at the start of compilation, which when forced will compute the module graph beneath the current module. The thunk is only forced at the moment when the user uses Template Haskell. Finally, there are some situations where we need to discover what dependencies to load but haven't loaded a module graph at all. In this case, there is a fallback which computes the transitive closure on the fly and doesn't cache the result. Presumably if you are going to call getLinkDeps a lot, you would compute the right ModuleGraph before you started. Importantly, this removes the ExternalModuleGraph abstraction. This was quite awkward to work with since it stored information about the home package inside the EPS. This patch will also be very useful when implementing explicit level imports, which requires more significant use of the module graph in order to determine which level instances are available at. Towards #25795 ------------------------- Metric Decrease: MultiLayerModulesTH_Make MultiLayerModulesTH_OneShot ------------------------- - - - - - 26 changed files: - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Driver/Env/Types.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Driver/Errors/Types.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/MakeAction.hs - + compiler/GHC/Driver/Messager.hs - compiler/GHC/Driver/Pipeline.hs-boot - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Loader.hs - compiler/GHC/Unit/External.hs - compiler/GHC/Unit/Finder.hs - − compiler/GHC/Unit/Module/External/Graph.hs - compiler/GHC/Unit/Module/Graph.hs - compiler/GHC/Unit/Module/ModNodeKey.hs - compiler/ghc.cabal.in - + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs - + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.stdout - testsuite/tests/ghc-api/fixed-nodes/all.T - testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs Changes: ===================================== compiler/GHC/Driver/Downsweep.hs ===================================== @@ -10,9 +10,14 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Driver.Downsweep ( downsweep + , downsweepThunk + , downsweepInstalledModules + , downsweepFromRootNodes + , DownsweepMode(..) -- * Summary functions , summariseModule , summariseFile + , summariseModuleInterface , SummariseResult(..) -- * Helper functions , instantiationNodes @@ -21,33 +26,37 @@ module GHC.Driver.Downsweep import GHC.Prelude -import GHC.Tc.Utils.Backpack - - import GHC.Platform.Ways import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) import GHC.Driver.Phases -import GHC.Driver.Pipeline +import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess) 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.Messager import GHC.Driver.MakeSem import GHC.Driver.MakeAction +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Ppr -import GHC.Parser.Header +import GHC.Iface.Load +import GHC.Parser.Header +import GHC.Rename.Names +import GHC.Tc.Utils.Backpack import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) +import qualified GHC.Data.Maybe as M import GHC.Data.OsPath ( unsafeEncodeUtf ) import GHC.Data.StringBuffer +import GHC.Data.Graph.Directed.Reachability import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Exception ( throwIO, SomeAsyncException ) @@ -58,6 +67,7 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Fingerprint import GHC.Utils.TmpFs +import GHC.Utils.Constants import GHC.Types.Error import GHC.Types.Target @@ -71,7 +81,10 @@ 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 GHC.Unit.Module.Deps +import qualified GHC.Unit.Home.Graph as HUG import Data.Either ( rights, partitionEithers, lefts ) import qualified Data.Map as Map @@ -82,6 +95,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.Maybe +import Data.List (partition) import Data.Time import Data.List (unfoldr) import Data.Bifunctor (first) @@ -91,19 +105,45 @@ import System.FilePath import Control.Monad.Trans.Reader import qualified Data.Map.Strict as M import Control.Monad.Trans.Class -import GHC.Rename.Names -import GHC.Utils.Constants +import System.IO.Unsafe (unsafeInterleaveIO) -import GHC.Data.Graph.Directed.Reachability -import qualified GHC.Unit.Home.Graph as HUG +{- +Note [Downsweep and the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModuleGraph stores the relationship between all the modules, units, and +instantiations in the current session. + +When we do downsweep, we build up a new ModuleGraph, starting from the root +modules. By following all the dependencies we construct a graph which allows +us to answer questions about the transitive closure of the imports. + +The module graph is accessible in the HscEnv. + +When is this graph constructed? + +1. In `--make` mode, we construct the graph before starting to do any compilation. + +2. In `-c` (oneshot) mode, we construct the graph when we have calculated the + ModSummary for the module we are compiling. The `ModuleGraph` is stored in a + thunk, so it is only constructed when it is needed. This avoids reading + the interface files of the whole transitive closure unless they are needed. + +3. In some situations (such as loading plugins) we may need to construct the + graph without having a ModSummary. In this case we use the `downsweepInstalledModules` + function. + +The result is having a uniform graph available for the whole compilation pipeline. + +-} -- This caches the answer to the question, if we are in this unit, what does -- an import of this module mean. -type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] +type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] ----------------------------------------------------------------------------- -- --- | Downsweep (dependency analysis) +-- | Downsweep (dependency analysis) for --make mode -- -- Chase downwards from the specified root set, returning summaries -- for all home modules encountered. Only follow source-import @@ -113,9 +153,15 @@ type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either Driv -- cache to avoid recalculating a module summary if the source is -- unchanged. -- --- The returned list of [ModSummary] nodes has one node for each home-package +-- The returned ModuleGraph has one node for each home-package -- module, plus one for any hs-boot files. The imports of these nodes -- are all there, including the imports of non-home-package modules. +-- +-- This function is intendned for use by --make mode and will also insert +-- LinkNodes and InstantiationNodes for any home units. +-- +-- It will also turn on code generation for any modules that need it by calling +-- 'enableCodeGenForTH'. downsweep :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager @@ -132,8 +178,31 @@ downsweep :: HscEnv -- which case there can be repeats downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) - new <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary - downsweep_imports hsc_env old_summary_map excl_mods allow_dup_roots new + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + let closure_errs = checkHomeUnitsClosed unit_env + unit_env = hsc_unit_env hsc_env + + all_errs = closure_errs ++ root_errs + + case all_errs of + [] -> do + (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + + let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + + let all_nodes = downsweep_nodes ++ unit_nodes + let all_errs = downsweep_errs ++ other_errs + + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes + + return (all_errs, th_configured_nodes) + _ -> return (all_errs, emptyMG) where summary = getRootSummary excl_mods old_summary_map @@ -146,47 +215,102 @@ downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] -downsweep_imports :: HscEnv + -- Dependencies arising on a unit (backpack and module linking deps) + unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] + unitModuleNodes summaries uid hue = + maybeToList (linkNodes summaries uid hue) + +-- | Calculate the module graph starting from a single ModSummary. The result is a +-- thunk, which when forced will perform the downsweep. This is useful in oneshot +-- mode where the module graph may never be needed. +-- If downsweep fails, then the resulting errors are just thrown. +downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph +downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." + ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + return (mkModuleGraph mg) + +-- | Create a module graph from a list of installed modules. +-- This is used by the loader when we need to load modules but there +-- isn't already an existing module graph. For example, when loading plugins +-- during initialisation. +-- +-- If you call this function, then if the `Module` you request to downsweep can't +-- be found then this function will throw errors. +-- If you need to use this function elsewhere, then it would make sense to make it +-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit. +-- At the moment, it is overfitted for what `get_reachable_nodes` needs. +downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph +downsweepInstalledModules hsc_env mods = do + let + (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods + installed_mods = map (fst . getModuleInstantiation) home_mods + external_uids = map moduleUnitId external_mods + + process :: InstalledModule -> IO ModuleNodeInfo + process i = do + res <- findExactModule hsc_env i NotBoot + case res of + InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc + -- It is an internal-ish error if this happens, since we any call to this function should + -- already know that we can find the modules we need to load. + _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i + + nodes <- mapM process installed_mods + (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids + + -- Similarly here, we should really not get any errors, but print them out if we do. + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + + return (mkModuleGraph mg) + + + +-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used +-- by --make mode, and fixed nodes by oneshot mode. +-- +-- See Note [Module Types in the ModuleGraph] for the difference between the two. +data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed + +-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root +-- 'UnitId's. +-- This function will start at the given roots, and traverse downwards to find +-- all the dependencies, all the way to the leaf units. +downsweepFromRootNodes :: HscEnv -> M.Map (UnitId, FilePath) ModSummary -> [ModuleName] -> Bool - -> ([(UnitId, DriverMessages)], [ModSummary]) - -> IO ([DriverMessages], ModuleGraph) -downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, rootSummariesOk) + -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies + -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo + -> [UnitId] -- ^ The starting units + -> IO ([DriverMessages], [ModuleGraphNode]) +downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids = do - let root_map = mkRootMap rootSummariesOk + let root_map = mkRootMap root_nodes checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) + (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let all_deps = loopUnit hsc_env module_deps root_uids + let all_instantiations = getHomeUnitInstantiations hsc_env - let deps' = loopInstantiations all_instantiations deps - let closure_errs = checkHomeUnitsClosed unit_env - unit_env = hsc_unit_env hsc_env - tmpfs = hsc_tmpfs hsc_env + let deps' = loopInstantiations all_instantiations all_deps downsweep_errs = lefts $ concat $ M.elems map0 downsweep_nodes = M.elems deps' - (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) - all_nodes = downsweep_nodes ++ unit_nodes - all_errs = all_root_errs ++ downsweep_errs ++ other_errs - all_root_errs = closure_errs ++ map snd root_errs - - -- if we have been passed -fno-code, we enable code generation - -- for dependencies of modules that have -XTemplateHaskell, - -- otherwise those modules will fail to compile. - -- See Note [-fno-code mode] #8025 - th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes - if null all_root_errs - then return (all_errs, th_enabled_nodes) - else pure $ (all_root_errs, emptyMG) + return (downsweep_errs, downsweep_nodes) where getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) - -- Dependencies arising on a unit (backpack and module linking deps) - unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] - unitModuleNodes summaries uid hue = - maybeToList (linkNodes summaries uid hue) calcDeps ms = -- Add a dependency on the HsBoot file if it exists @@ -195,8 +319,6 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ] - logger = hsc_logger hsc_env - -- In a root module, the filename is allowed to diverge from the module -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently @@ -209,7 +331,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root | otherwise = pure () where - dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights (M.elems root_map) loopInstantiations :: [(UnitId, InstantiatedUnit)] @@ -250,6 +372,102 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro | otherwise = Nothing + loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) + loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + + loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> IO (M.Map NodeKey ModuleGraphNode, DownsweepCache) + loopModuleNodeInfo mod_node_info (done, summarised) = do + case mod_node_info of + ModuleNodeCompile ms -> do + loopSummaries [ms] (done, summarised) + ModuleNodeFixed mod ml -> do + done' <- loopFixedModule mod ml done + return (done', summarised) + + -- NB: loopFixedModule does not take a downsweep cache, because if you + -- ever reach a Fixed node, everything under that also must be fixed. + loopFixedModule :: ModNodeKeyWithUid -> ModLocation + -> M.Map NodeKey ModuleGraphNode + -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedModule key loc done = do + let nk = NodeKey_Module key + case M.lookup nk done of + Just {} -> return done + Nothing -> do + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map (either NodeKey_Module NodeKey_ExternalUnit) node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) node_deps + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + return done + + loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedNodeKey _ done (Left key) = do + loopFixedImports [key] done + loopFixedNodeKey home_uid done (Right uid) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + + + ifaceDeps :: Dependencies -> [Either ModNodeKeyWithUid UnitId] + ifaceDeps deps = + [ Left (ModNodeKeyWithUid dep uid) + | (uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right uid + | uid <- Set.toList (dep_direct_pkgs deps) + ] + + -- Like loopImports, but we already know exactly which module we are looking for. + loopFixedImports :: [ModNodeKeyWithUid] + -> M.Map NodeKey ModuleGraphNode + -> IO (M.Map NodeKey ModuleGraphNode) + loopFixedImports [] done = pure done + loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + done' <- loopFixedModule key loc done + loopFixedImports keys done' + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + loopFixedImports keys done + + downsweepSummarise :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult + downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + case mode of + DownsweepUseCompile -> summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover -- a new module by doing this. @@ -268,7 +486,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro | Just summs <- M.lookup cache_key summarised = case summs of [Right ms] -> do - let nk = NodeKey_Module (msKey ms) + let nk = NodeKey_Module (mnKey ms) (rest, summarised', done') <- loopImports ss done summarised return (nk: rest, summarised', done') [Left _err] -> @@ -277,7 +495,7 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro loopImports ss done summarised | otherwise = do - mb_s <- summariseModule hsc_env home_unit old_summaries + mb_s <- downsweepSummarise hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg Nothing excl_mods case mb_s of @@ -295,11 +513,11 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) FoundHome s -> do (done', summarised') <- - loopSummaries [s] (done, Map.insert cache_key [Right s] summarised) + loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) + return (NodeKey_Module (mnKey s) : other_deps, final_done, final_summarised) where cache_key = (home_uid, mb_pkg, unLoc <$> gwib) home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) @@ -316,17 +534,17 @@ downsweep_imports hsc_env old_summaries excl_mods allow_dup_roots (root_errs, ro Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) -multiRootsErr :: [ModSummary] -> IO () +multiRootsErr :: [ModuleNodeInfo] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwOneError $ fmap GhcDriverMessage $ mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files where - mod = ms_mod summ1 - files = map (expectJust . ml_hs_file . ms_location) summs + mod = moduleNodeInfoModule summ1 + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs -moduleNotFoundErr :: ModuleName -> DriverMessages -moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod) +moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages +moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. -- These are used to represent the type checking that is done after @@ -380,18 +598,17 @@ getRootSummary :: M.Map (UnitId, FilePath) ModSummary -> HscEnv -> Target -> - IO (Either (UnitId, DriverMessages) ModSummary) + IO (Either DriverMessages ModSummary) getRootSummary excl_mods old_summary_map hsc_env target | TargetFile file mb_phase <- targetId = do let offset_file = augmentByWorkingDirectory dflags file exists <- liftIO $ doesFileExist offset_file if exists || isJust maybe_buf - then first (uid,) <$> - summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase maybe_buf else - return $ Left $ (uid,) $ singleMessage $ + return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) | TargetModule modl <- targetId = do @@ -399,9 +616,9 @@ getRootSummary excl_mods old_summary_map hsc_env target (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) maybe_buf excl_mods pure case maybe_summary of - FoundHome s -> Right s - FoundHomeWithError err -> Left err - _ -> Left (uid, moduleNotFoundErr modl) + FoundHome (ModuleNodeCompile s) -> Right s + FoundHomeWithError err -> Left (snd err) + _ -> Left (moduleNotFoundErr uid modl) where Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) @@ -426,8 +643,8 @@ rootSummariesParallel :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> - (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) -> - IO ([(UnitId, DriverMessages)], [ModSummary]) + (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> + IO ([DriverMessages], [ModSummary]) rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) runPipelines n_jobs hsc_env diag_wrapper msg actions @@ -732,10 +949,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do -- | Populate the Downsweep cache with the root modules. mkRootMap - :: [ModSummary] + :: [ModuleNodeInfo] -> DownsweepCache mkRootMap summaries = Map.fromListWith (flip (++)) - [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ] + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] ----------------------------------------------------------------------------- -- Summarising modules @@ -863,26 +1080,64 @@ checkSummaryHash data SummariseResult = FoundInstantiation InstantiatedUnit | FoundHomeWithError (UnitId, DriverMessages) - | FoundHome ModSummary + | FoundHome ModuleNodeInfo | External UnitId | NotThere +-- | summariseModule finds the location of the source file for the given module. +-- This version always returns a ModuleNodeCompile node, it is useful for +-- --make mode. +summariseModule :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult +summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf + + +-- | Like summariseModule but for interface files that we don't want to compile. +-- This version always returns a ModuleNodeFixed node. +summariseModuleInterface :: HscEnv + -> HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> [ModuleName] + -> IO SummariseResult +summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k _hsc_env loc mod = do + -- The finder will return a path to the .hi-boot even if it doesn't actually + -- exist. So check if it exists first before concluding it's there. + does_exist <- doesFileExist (ml_hi_file loc) + if does_exist + then let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + else return NotThere + + + -- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv +summariseModuleDispatch + :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. + -> HscEnv -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary - -- ^ Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Located ModuleName -- Imported module to be summarised -> PkgQual - -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude -> IO SummariseResult -summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg - maybe_buf excl_mods +summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods | wanted_mod `elem` excl_mods = return NotThere | otherwise = find_it @@ -890,7 +1145,6 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p -- Temporarily change the currently active home unit so all operations -- happen relative to it hsc_env = hscSetActiveHomeUnit home_unit hsc_env' - dflags = hsc_dflags hsc_env find_it :: IO SummariseResult @@ -898,9 +1152,9 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg case found of Found location mod - | isJust (ml_hs_file location) -> + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> -- Home package - just_found location mod + k hsc_env location mod | VirtUnit iud <- moduleUnit mod , not (isHomeModule home_unit mod) -> return $ FoundInstantiation iud @@ -910,9 +1164,22 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p -- (If it is TRULY not found at all, we'll -- error when we actually try to compile) - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so + +-- | The continuation to summarise a home module if we want to find the source file +-- for it and potentially compile it. +summariseModuleWithSource + :: HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -- ^ Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Maybe (StringBuffer, UTCTime) + -> HscEnv + -> ModLocation + -> Module + -> IO SummariseResult +summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so let src_fn = expectJust (ml_hs_file location) -- Check that it exists @@ -926,8 +1193,10 @@ summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_p fresult <- new_summary_cache_check location mod src_fn h return $ case fresult of Left err -> FoundHomeWithError (moduleUnitId mod, err) - Right ms -> FoundHome ms + Right ms -> FoundHome (ModuleNodeCompile ms) + where + dflags = hsc_dflags hsc_env new_summary_cache_check loc mod src_fn h | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = @@ -1061,4 +1330,4 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) let pi_srcimps = rn_imps pi_srcimps' let pi_theimps = rn_imps pi_theimps' - return PreprocessedImports {..} \ No newline at end of file + return PreprocessedImports {..} ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -27,6 +27,7 @@ module GHC.Driver.Env , discardIC , lookupType , lookupIfaceByModule + , lookupIfaceByModuleHsc , mainModIs , hugRulesBelow @@ -249,6 +250,11 @@ hugInstancesBelow hsc_env uid mnwib = do -- -- Note: Don't expose this function. This is a footgun if exposed! hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] +-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk +-- These things are currently stored in the EPS for home packages. (See #25795 for +-- progress in removing these kind of checks) +-- See Note [Downsweep and the ModuleGraph] +hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn = let hug = hsc_HUG hsc_env mg = hsc_mod_graph hsc_env @@ -345,6 +351,11 @@ lookupIfaceByModule hug pit mod -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc hsc_env mod = do + eps <- hscEPS hsc_env + lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod + mainModIs :: HomeUnitEnv -> Module mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) ===================================== compiler/GHC/Driver/Env/Types.hs ===================================== @@ -67,6 +67,7 @@ data HscEnv hsc_mod_graph :: ModuleGraph, -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements ===================================== compiler/GHC/Driver/Errors/Ppr.hs ===================================== @@ -155,7 +155,7 @@ instance Diagnostic DriverMessage where text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) - DriverModuleNotFound mod + DriverModuleNotFound _uid mod -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally") DriverFileModuleNameMismatch actual expected -> mkSimpleDecorated $ ===================================== compiler/GHC/Driver/Errors/Types.hs ===================================== @@ -187,7 +187,7 @@ data DriverMessage where Test cases: None. -} - DriverModuleNotFound :: !ModuleName -> DriverMessage + DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name. The first field is the name written in the source code; the second argument is the name extracted ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -118,6 +118,7 @@ import GHC.Driver.Backend import GHC.Driver.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Errors +import GHC.Driver.Messager import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) @@ -220,7 +221,6 @@ import GHC.Cmm.UniqueRenamer import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder -import GHC.Unit.External import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface @@ -814,7 +814,6 @@ This is the only thing that isn't caught by the type-system. -} -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () -- | Do the recompilation avoidance checks for both one-shot and --make modes -- This function is the *only* place in the compiler where we decide whether to @@ -1476,46 +1475,6 @@ genModDetails hsc_env old_iface dumpIfaceStats hsc_env return new_details --------------------------------------------------------------- --- Progress displayers. --------------------------------------------------------------- - -oneShotMsg :: Logger -> RecompileRequired -> IO () -oneShotMsg logger recomp = - case recomp of - UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" - NeedsRecompile _ -> return () - -batchMsg :: Messager -batchMsg = batchMsgWith (\_ _ _ _ -> empty) -batchMultiMsg :: Messager -batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) - -batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager -batchMsgWith extra hsc_env_start mod_index recomp node = - case recomp of - UpToDate - | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty - | otherwise -> return () - NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of - MustCompile -> empty - (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - where - herald = case node of - LinkNode {} -> "Linking" - InstantiationNode {} -> "Instantiating" - ModuleNode {} -> "Compiling" - UnitNode {} -> "Loading" - hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - state = hsc_units hsc_env - showMsg msg reason = - compilationProgressMsg logger $ - (showModuleIndex mod_index <> - msg <+> showModMsg dflags (recompileRequired recomp) node) - <> extra hsc_env mod_index recomp node - <> reason -------------------------------------------------------------- -- Safe Haskell @@ -1803,10 +1762,7 @@ hscCheckSafe' m l = do lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do hsc_env <- getHscEnv - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - hug = hsc_HUG hsc_env - iface <- liftIO $ lookupIfaceByModule hug pkgIfaceT m + iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk @@ -2954,18 +2910,6 @@ dumpIfaceStats hsc_env = do logDumpMsg logger "Interface statistics" (ifaceStats eps) -{- ********************************************************************** -%* * - Progress Messages: Module i of n -%* * -%********************************************************************* -} - -showModuleIndex :: (Int, Int) -> SDoc -showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " - where - -- compute the length of x > 0 in base 10 - len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) - pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -41,6 +41,7 @@ module GHC.Driver.Make ( -- * Re-exports from Downsweep checkHomeUnitsClosed, summariseModule, + summariseModuleInterface, SummariseResult(..), summariseFile, @@ -648,7 +649,7 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do | otherwise = do throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ GhcDriverMessage - $ DriverModuleNotFound (moduleName m) + $ DriverModuleNotFound (moduleUnit m) (moduleName m) checkHowMuch how_much $ do @@ -1667,7 +1668,7 @@ executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc = wrapAction diag_wrapper hsc_env $ do forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc)) - read_result <- readIface (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) + read_result <- readIface (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) case read_result of M.Failed interface_err -> let mn = mnkModuleName mod ===================================== compiler/GHC/Driver/MakeAction.hs ===================================== @@ -25,7 +25,7 @@ import GHC.Driver.DynFlags import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors.Types -import GHC.Driver.Main +import GHC.Driver.Messager import GHC.Driver.MakeSem import GHC.Utils.Logger ===================================== compiler/GHC/Driver/Messager.hs ===================================== @@ -0,0 +1,66 @@ +module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where + +import GHC.Prelude +import GHC.Driver.Env +import GHC.Unit.Module.Graph +import GHC.Iface.Recomp +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Unit.State + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = + case recomp of + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + NeedsRecompile _ -> return () + +batchMsg :: Messager +batchMsg = batchMsgWith (\_ _ _ _ -> empty) +batchMultiMsg :: Messager +batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) + +batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager +batchMsgWith extra hsc_env_start mod_index recomp node = + case recomp of + UpToDate + | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of + MustCompile -> empty + (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + where + herald = case node of + LinkNode {} -> "Linking" + InstantiationNode {} -> "Instantiating" + ModuleNode {} -> "Compiling" + UnitNode {} -> "Loading" + hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + state = hsc_units hsc_env + showMsg msg reason = + compilationProgressMsg logger $ + (showModuleIndex mod_index <> + msg <+> showModMsg dflags (recompileRequired recomp) node) + <> extra hsc_env mod_index recomp node + <> reason + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> SDoc +showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " + where + -- compute the length of x > 0 in base 10 + len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) + pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr \ No newline at end of file ===================================== compiler/GHC/Driver/Pipeline.hs-boot ===================================== @@ -3,12 +3,22 @@ module GHC.Driver.Pipeline where import GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang ) -import GHC.Prelude (FilePath, IO) +import GHC.Prelude (FilePath, IO, Maybe, Either) import GHC.Unit.Module.Location (ModLocation) import GHC.Driver.Session (DynFlags) +import GHC.Driver.Phases (Phase) +import GHC.Driver.Errors.Types (DriverMessages) +import GHC.Types.Target (InputFileBuffer) import Language.Haskell.Syntax.Module.Name -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () + +preprocess :: HscEnv + -> FilePath + -> Maybe InputFileBuffer + -> Maybe Phase + -> IO (Either DriverMessages (DynFlags, FilePath)) + ===================================== compiler/GHC/Driver/Pipeline/Execute.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Unit.Module.ModSummary import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc import GHC.Driver.Main +import GHC.Driver.Downsweep import GHC.Tc.Types import GHC.Types.Error import GHC.Driver.Errors.Types @@ -760,11 +761,17 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + -- A lazy module graph thunk, don't force it unless you need it! + mg <- downsweepThunk hsc_env mod_summary + -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) + , hsc_mod_graph = mg } + + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -25,7 +25,6 @@ module GHC.Iface.Load ( -- IfM functions loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, - loadExternalGraphBelow, findAndReadIface, readIface, writeIface, flagsToIfCompression, moduleFreeHolesPrecise, @@ -49,7 +48,6 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.DynFlags @@ -110,7 +108,6 @@ import GHC.Unit.Home import GHC.Unit.Home.PackageTable import GHC.Unit.Finder import GHC.Unit.Env -import GHC.Unit.Module.External.Graph import GHC.Data.Maybe @@ -122,7 +119,6 @@ import GHC.Driver.Env.KnotVars import {-# source #-} GHC.Driver.Main (loadIfaceByteCode) import GHC.Iface.Errors.Types import Data.Function ((&)) -import qualified Data.Set as Set import GHC.Unit.Module.Graph import qualified GHC.Unit.Home.Graph as HUG @@ -413,112 +409,6 @@ loadInterfaceWithException doc mod_name where_from let ctx = initSDocContext dflags defaultUserStyle withIfaceErr ctx (loadInterface doc mod_name where_from) --- | Load the part of the external module graph which is transitively reachable --- from the given modules. --- --- This operation is used just before TH splices are run (in 'getLinkDeps'). --- --- A field in the EPS tracks which home modules are already fully loaded, which we use --- here to avoid trying to load them a second time. --- --- The function takes a set of keys which are currently in the process of being loaded. --- This is used to avoid duplicating work by loading keys twice if they appear along multiple --- paths in the transitive closure. Once the interface and all its dependencies are --- loaded, the key is added to the "fully loaded" set, so we know that it and it's --- transitive closure are present in the graph. --- --- Note that being "in progress" is different from being "fully loaded", consider if there --- is an exception during `loadExternalGraphBelow`, then an "in progress" item may fail --- to become fully loaded. -loadExternalGraphBelow :: (Module -> SDoc) -> Maybe HomeUnit {-^ The current home unit -} - -> Set.Set ExternalKey -> [Module] -> IfM lcl (Set.Set ExternalKey) -loadExternalGraphBelow _ Nothing _ _ = panic "loadExternalGraphBelow: No home unit" -loadExternalGraphBelow msg (Just home_unit) in_progress mods = - foldM (loadExternalGraphModule msg home_unit) in_progress mods - --- | Load the interface for a module, and all its transitive dependencies but --- only if we haven't fully loaded the module already or are in the process of fully loading it. -loadExternalGraphModule :: (Module -> SDoc) -> HomeUnit - -> Set.Set ExternalKey - -> Module - -> IfM lcl (Set.Set ExternalKey) -loadExternalGraphModule msg home_unit in_progress mod - | homeUnitId home_unit /= moduleUnitId mod = do - loadExternalPackageBelow in_progress (moduleUnitId mod) - | otherwise = do - - let key = ExternalModuleKey $ ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnitId mod) - graph <- eps_module_graph <$> getEps - - if (not (isFullyLoadedModule key graph || Set.member key in_progress)) - then actuallyLoadExternalGraphModule msg home_unit in_progress key mod - else return in_progress - --- | Load the interface for a module, and all its transitive dependenices. -actuallyLoadExternalGraphModule - :: (Module -> SDoc) - -> HomeUnit - -> Set.Set ExternalKey - -> ExternalKey - -> Module - -> IOEnv (Env IfGblEnv lcl) (Set.Set ExternalKey) -actuallyLoadExternalGraphModule msg home_unit in_progress key mod = do - dflags <- getDynFlags - let ctx = initSDocContext dflags defaultUserStyle - iface <- withIfaceErr ctx $ - loadInterface (msg mod) mod (ImportByUser NotBoot) - - let deps = mi_deps iface - mod_deps = dep_direct_mods deps - pkg_deps = dep_direct_pkgs deps - - -- Do not attempt to load the same key again when traversing - let in_progress' = Set.insert key in_progress - - -- Load all direct dependencies that are in the home package - cache_mods <- loadExternalGraphBelow msg (Just home_unit) in_progress' - $ map (\(uid, GWIB mn _) -> mkModule (RealUnit (Definite uid)) mn) - $ Set.toList mod_deps - - -- Load all the package nodes, and packages beneath them. - cache_pkgs <- foldM loadExternalPackageBelow cache_mods (Set.toList pkg_deps) - - registerFullyLoaded key - return cache_pkgs - -registerFullyLoaded :: ExternalKey -> IfM lcl () -registerFullyLoaded key = do - -- Update the external graph with this module being fully loaded. - logger <- getLogger - liftIO $ trace_if logger (text "Fully loaded:" <+> ppr key) - updateEps_ $ \eps -> - eps{eps_module_graph = setFullyLoadedModule key (eps_module_graph eps)} - -loadExternalPackageBelow :: Set.Set ExternalKey -> UnitId -> IfM lcl (Set.Set ExternalKey) -loadExternalPackageBelow in_progress uid = do - graph <- eps_module_graph <$> getEps - us <- hsc_units <$> getTopEnv - let key = ExternalPackageKey uid - if not (isFullyLoadedModule key graph || Set.member key in_progress) - then do - let in_progress' = Set.insert key in_progress - case unitDepends <$> lookupUnitId us uid of - Just dep_uids -> do - loadPackageIntoEPSGraph uid dep_uids - final_cache <- foldM loadExternalPackageBelow in_progress' dep_uids - registerFullyLoaded key - return final_cache - Nothing -> pprPanic "loadExternalPackagesBelow: missing" (ppr uid) - else - return in_progress - -loadPackageIntoEPSGraph :: UnitId -> [UnitId] -> IfM lcl () -loadPackageIntoEPSGraph uid dep_uids = - updateEps_ $ \eps -> - eps { eps_module_graph = - extendExternalModuleGraph (NodeExternalPackage uid - (Set.fromList dep_uids)) (eps_module_graph eps) } - ------------------ loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr MissingInterfaceError ModIface) @@ -628,15 +518,6 @@ loadInterface doc_str mod from ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) ; purged_hsc_env <- getTopEnv - ; let direct_deps = map (uncurry (flip ModNodeKeyWithUid)) $ (Set.toList (dep_direct_mods $ mi_deps iface)) - ; let direct_pkg_deps = Set.toList $ dep_direct_pkgs $ mi_deps iface - ; let !module_graph_key = - if moduleUnitId mod `elem` hsc_all_home_unit_ids hsc_env - --- ^ home unit mods in eps can only happen in oneshot mode - then Just $ NodeHomePackage (miKey iface) (map ExternalModuleKey direct_deps - ++ map ExternalPackageKey direct_pkg_deps) - else Nothing - ; let final_iface = iface & set_mi_decls (panic "No mi_decls in PIT") & set_mi_insts (panic "No mi_insts in PIT") @@ -678,11 +559,6 @@ loadInterface doc_str mod from eps_iface_bytecode = add_bytecode (eps_iface_bytecode eps), eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, - eps_module_graph = - let eps_graph' = case module_graph_key of - Just k -> extendExternalModuleGraph k (eps_module_graph eps) - Nothing -> eps_module_graph eps - in eps_graph', eps_complete_matches = eps_complete_matches eps ++ new_eps_complete_matches, eps_inst_env = extendInstEnvList (eps_inst_env eps) @@ -792,6 +668,9 @@ dontLeakTheHUG thing_inside = do -- tweak. old_unit_env = hsc_unit_env hsc_env keepFor20509 + -- oneshot mode does not support backpack + -- and we want to avoid prodding the hsc_mod_graph thunk + | isOneShot (ghcMode (hsc_dflags hsc_env)) = False | mgHasHoles (hsc_mod_graph hsc_env) = True | otherwise = False pruneHomeUnitEnv hme = do @@ -1012,12 +891,10 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let profile = targetProfile dflags unit_state = hsc_units hsc_env - fc = hsc_FC hsc_env name_cache = hsc_NC hsc_env mhome_unit = hsc_home_unit_maybe hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) trace_if logger (sep [hsep [text "Reading", @@ -1036,9 +913,8 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do let iface = getGhcPrimIface hsc_env return (Succeeded (iface, panic "GHC.Prim ModLocation (findAndReadIface)")) else do - let fopts = initFinderOpts dflags -- Look for the file - mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod hi_boot_file) + mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) case mb_found of InstalledFound loc -> do -- See Note [Home module load error] @@ -1101,7 +977,6 @@ read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) read_file logger name_cache unit_state dflags wanted_mod file_path = do - trace_if logger (text "readIFace" <+> text file_path) -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -1112,7 +987,7 @@ read_file logger name_cache unit_state dflags wanted_mod file_path = do (_, Just indef_mod) -> instModuleToModule unit_state (uninstantiateInstantiatedModule indef_mod) - read_result <- readIface dflags name_cache wanted_mod' file_path + read_result <- readIface logger dflags name_cache wanted_mod' file_path case read_result of Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) @@ -1139,12 +1014,14 @@ flagsToIfCompression dflags -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed readIface - :: DynFlags + :: Logger + -> DynFlags -> NameCache -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError ModIface) -readIface dflags name_cache wanted_mod file_path = do +readIface logger dflags name_cache wanted_mod file_path = do + trace_if logger (text "readIFace" <+> text file_path) let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path case res of ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -23,7 +23,6 @@ import GHC.Prelude import GHC.Data.FastString import GHC.Driver.Backend -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.DynFlags import GHC.Driver.Ppr @@ -303,7 +302,7 @@ check_old_iface hsc_env mod_summary maybe_iface loadIface read_dflags iface_path = do let ncu = hsc_NC hsc_env - read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path + read_result <- readIface logger read_dflags ncu (ms_mod mod_summary) iface_path case read_result of Failed err -> do let msg = readInterfaceErrorDiagnostic err @@ -635,7 +634,7 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface = do res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) + res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod) (ms_plugin_imps summary) case sequence (res_normal ++ res_plugin) of Left recomp -> return $ NeedsRecompile recomp Right es -> do @@ -657,13 +656,8 @@ checkDependencies hsc_env summary iface let reason = ModuleChanged mod in classify reason <$> find_import mod mb_pkg) imports - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags logger = hsc_logger hsc_env - fc = hsc_FC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env all_home_units = hsc_all_home_unit_ids hsc_env - units = hsc_units hsc_env prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) (dep_plugin_pkgs (mi_deps iface))) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -228,31 +228,6 @@ See Note [Home module build products] for some more information about that. The only other place where the flag is consulted is when enabling code generation with `-fno-code`, which does so to anticipate what decision we will make at the splice point about what we would prefer. - -Note [Reachability in One-shot mode vs Make mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why are there two code paths in `get_reachable_nodes`? (ldOneShotMode vs otherwise) - -In one-shot mode, the home package modules are loaded into the EPS, -whereas for --make mode, the home package modules are in the HUG/HPT. - -For both of these cases, we cache the calculation of transitive -dependencies in a 'ModuleGraph'. For the --make case, the relevant -'ModuleGraph' is in the EPS, the other case uses the 'ModuleGraph' -for the home modules. - -The home modules graph is known statically after downsweep. -On the contrary, the EPS module graph is only extended when a -module is loaded into the EPS -- which is done lazily as needed. -Therefore, for get_link_deps, we need to force the transitive -closure to be loaded before querying the graph for the reachable -link dependencies -- done in the call to 'loadExternalGraphBelow'. -Because we cache the transitive closure, this work is only done once. - -After forcing the modules with the call to 'loadExternalGraphBelow' in -'get_reachable_nodes', the external module graph has all edges needed to -compute the full transitive closure so we can proceed just like we do in the -second path with a normal module graph. -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -76,12 +76,10 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Unit.Env -import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.External (ExternalPackageState (..)) import GHC.Unit.Module import GHC.Unit.Module.ModNodeKey -import GHC.Unit.Module.External.Graph import GHC.Unit.Module.Graph import GHC.Unit.Module.ModIface import GHC.Unit.State as Packages @@ -119,6 +117,9 @@ import System.Win32.Info (getSystemDirectory) import GHC.Utils.Exception import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Driver.Downsweep + + -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -615,89 +616,53 @@ initLinkDepsOpts hsc_env = opts dflags = hsc_dflags hsc_env ldLoadByteCode mod = do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) + mod ImportBySystem EPS {eps_iface_bytecode} <- hscEPS hsc_env sequence (lookupModuleEnv eps_iface_bytecode mod) --- See Note [Reachability in One-shot mode vs Make mode] get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) get_reachable_nodes hsc_env mods - -- Reachability on 'ExternalModuleGraph' (for one shot mode) - | isOneShot (ghcMode dflags) + -- Fallback case if the ModuleGraph has not been initialised by the user. + -- This can happen if is the user is loading plugins or doing something else very + -- early in the compiler pipeline. + | isEmptyMG (hsc_mod_graph hsc_env) = do - initIfaceCheck (text "loader") hsc_env - $ void $ loadExternalGraphBelow msg (hsc_home_unit_maybe hsc_env) Set.empty mods - -- Read the EPS only after `loadExternalGraphBelow` - eps <- hscEPS hsc_env - let - emg = eps_module_graph eps - get_mod_info_eps (ModNodeKeyWithUid gwib uid) - | uid == homeUnitId (ue_unsafeHomeUnit unit_env) - = case lookupModuleEnv (eps_PIT eps) (Module (RealUnit $ Definite uid) (gwib_mod gwib)) of - Just iface -> return $ Just iface - Nothing -> moduleNotLoaded "(in EPS)" gwib uid - | otherwise - = return Nothing - - get_mod_key m - | moduleUnitId m == homeUnitId (ue_unsafeHomeUnit unit_env) - = ExternalModuleKey (mkModuleNk m) - | otherwise = ExternalPackageKey (moduleUnitId m) - - go get_mod_key emgNodeKey (emgReachableLoopMany emg) (map emgProject) get_mod_info_eps + mg <- downsweepInstalledModules hsc_env mods + go mg - -- Reachability on 'ModuleGraph' (for --make mode) | otherwise - = go hmgModKey mkNodeKey (mgReachableLoop hmGraph) (catMaybes . map hmgProject) get_mod_info_hug + = go (hsc_mod_graph hsc_env) where - dflags = hsc_dflags hsc_env unit_env = hsc_unit_env hsc_env mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) - msg mod = - text "need to link module" <+> ppr mod <+> - text "and the modules below it, due to use of Template Haskell" - - hmGraph = hsc_mod_graph hsc_env - hmgModKey m + hmgModKey mg m | let k = NodeKey_Module (mkModuleNk m) - , mgMember hmGraph k = k + , mgMember mg k = k | otherwise = NodeKey_ExternalUnit (moduleUnitId m) - hmgProject = \case - NodeKey_Module with_uid -> Just $ Left with_uid - NodeKey_ExternalUnit uid -> Just $ Right uid - _ -> Nothing - - emgProject = \case - ExternalModuleKey with_uid -> Left with_uid - ExternalPackageKey uid -> Right uid - -- The main driver for getting dependencies, which calls the given -- functions to compute the reachable nodes. - go :: (Module -> key) - -> (node -> key) - -> ([key] -> [node]) - -> ([key] -> [Either ModNodeKeyWithUid UnitId]) - -> (ModNodeKeyWithUid -> IO (Maybe ModIface)) - -> IO ([Module], UniqDSet UnitId) - go modKey nodeKey manyReachable project get_mod_info - | let mod_keys = map modKey mods - = do - let (all_home_mods, pkgs_s) = partitionEithers $ project $ mod_keys ++ map nodeKey (manyReachable mod_keys) - ifaces <- mapMaybeM get_mod_info all_home_mods - let mods_s = map mi_module ifaces + go :: ModuleGraph -> IO ([Module], UniqDSet UnitId) + go mg = do + let mod_keys = map (hmgModKey mg) mods + all_reachable = mod_keys ++ map mkNodeKey (mgReachableLoop mg mod_keys) + (mods_s, pkgs_s) <- partitionEithers <$> mapMaybeM get_mod_info all_reachable return (mods_s, mkUniqDSet pkgs_s) - get_mod_info_hug (ModNodeKeyWithUid gwib uid) = + get_mod_info :: NodeKey -> IO (Maybe (Either Module UnitId)) + get_mod_info (NodeKey_Module m@(ModNodeKeyWithUid gwib uid)) = lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) >>= \case - Just hmi -> return $ Just (hm_iface hmi) - Nothing -> moduleNotLoaded "(in HUG)" gwib uid + Just hmi -> return $ Just (Left (mi_module (hm_iface hmi))) + Nothing -> return (Just (Left (mnkToModule m))) + get_mod_info (NodeKey_ExternalUnit uid) = return (Just (Right uid)) + get_mod_info _ = return Nothing - moduleNotLoaded m gwib uid = throwGhcExceptionIO $ ProgramError $ showSDoc dflags $ - text "getLinkDeps: Home module not loaded" <+> text m <+> ppr (gwib_mod gwib) <+> ppr uid {- ********************************************************************** ===================================== compiler/GHC/Runtime/Loader.hs ===================================== @@ -56,7 +56,6 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) -import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface @@ -343,13 +342,8 @@ lookupRdrNameInModuleForPlugins :: HasDebugCallStack -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let unit_env = hsc_unit_env hsc_env - let unit_state = ue_homeUnitState unit_env - let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name + found_module <- findPluginModule hsc_env mod_name case found_module of Found _ mod -> do -- Find the exports of the module ===================================== compiler/GHC/Unit/External.hs ===================================== @@ -33,7 +33,6 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.DSet import GHC.Linker.Types (Linkable) -import GHC.Unit.Module.External.Graph import Data.IORef @@ -72,7 +71,6 @@ initExternalPackageState = EPS , eps_PIT = emptyPackageIfaceTable , eps_free_holes = emptyInstalledModuleEnv , eps_PTE = emptyTypeEnv - , eps_module_graph = emptyExternalModuleGraph , eps_iface_bytecode = emptyModuleEnv , eps_inst_env = emptyInstEnv , eps_fam_inst_env = emptyFamInstEnv @@ -141,8 +139,6 @@ data ExternalPackageState -- for every import, so cache it here. When the PIT -- gets filled in we can drop these entries. - eps_module_graph :: ExternalModuleGraph, - eps_PTE :: !PackageTypeEnv, -- ^ Result of typechecking all the external package -- interface files we have sucked in. The domain of ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -66,7 +66,6 @@ import Control.Monad import Data.Time import qualified Data.Map as M import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) import GHC.Driver.Config.Finder import qualified Data.Set as Set import Data.List.NonEmpty ( NonEmpty (..) ) @@ -224,21 +223,26 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name -findPluginModule fc fopts units Nothing mod_name = +findPluginModuleNoHsc fc fopts units Nothing mod_name = findExposedPluginPackageModule fc fopts units mod_name --- | Locate a specific 'Module'. The purpose of this function is to --- create a 'ModLocation' for a given 'Module', that is to find out --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). -findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult -findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let mhome_unit = hsc_home_unit_maybe hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name + + +-- | A version of findExactModule which takes the exact parts of the HscEnv it needs +-- directly. +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do res <- case mhome_unit of Just home_unit | isHomeInstalledModule home_unit mod @@ -251,6 +255,21 @@ findExactModule fc fopts other_fopts unit_state mhome_unit mod is_boot = do _ -> return res +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). +findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModule hsc_env mod is_boot = do + let dflags = hsc_dflags hsc_env + let fc = hsc_FC hsc_env + let unit_state = hsc_units hsc_env + let home_unit = hsc_home_unit_maybe hsc_env + let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot + + -- ----------------------------------------------------------------------------- -- Helpers ===================================== compiler/GHC/Unit/Module/External/Graph.hs deleted ===================================== @@ -1,244 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} - --- | Like @'GHC.Unit.Module.Graph'@ but for the @'ExternalModuleGraph'@ which is --- stored in the EPS. -module GHC.Unit.Module.External.Graph - ( -- * External Module Graph - -- - -- | A module graph for the EPS. - ExternalModuleGraph, ExternalGraphNode(..) - , ExternalKey(..), emptyExternalModuleGraph - , emgNodeKey, emgNodeDeps, emgLookupKey - - -- * Extending - -- - -- | The @'ExternalModuleGraph'@ is a structure which is incrementally - -- updated as the 'ExternalPackageState' (EPS) is updated (when an iface is - -- loaded, in 'loadInterface'). - -- - -- Therefore, there is an operation for extending the 'ExternalModuleGraph', - -- unlike @'GHC.Unit.Module.Graph.ModuleGraph'@, which is constructed once - -- during downsweep and never altered (since all of the home units - -- dependencies are fully known then). - , extendExternalModuleGraph - - -- * Loading - -- - -- | As mentioned in the top-level haddocks for the - -- 'extendExternalModuleGraph', the external module graph is incrementally - -- updated as interfaces are loaded. This module graph keeps an additional - -- cache registering which modules have already been fully loaded. - -- - -- This cache is necessary to quickly check when a full-transitive-closure - -- reachability query would be valid for some module. - -- - -- Such a query may be invalid if ran on a module in the - -- 'ExternalModuleGraph' whose dependencies have /not yet/ been fully loaded - -- into the EPS. - -- (Recall that interfaces are lazily loaded, and the 'ExternalModuleGraph' - -- is only incrementally updated). - -- - -- To guarantee the full transitive closure of a given module is completely - -- loaded into the EPS (i.e. all interfaces of the modules below this one - -- are also loaded), see @'loadExternalGraphBelow'@ in - -- 'GHC.Iface.Load'. - , isFullyLoadedModule - , setFullyLoadedModule - - -- * Reachability - -- - -- | Fast reachability queries on the external module graph. Similar to - -- reachability queries on 'GHC.Unit.Module.Graph'. - , emgReachableLoop - , emgReachableLoopMany - ) where - -import GHC.Prelude -import GHC.Unit.Module.Graph -import GHC.Data.Graph.Directed.Reachability -import GHC.Data.Graph.Directed -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Bifunctor (first, bimap) -import Data.Maybe -import GHC.Utils.Outputable -import GHC.Unit.Types (UnitId, GenWithIsBoot(..), IsBootInterface(..), mkModule) -import GHC.Utils.Misc - - --------------------------------------------------------------------------------- --- * Main --------------------------------------------------------------------------------- - -data ExternalModuleGraph = ExternalModuleGraph - { external_nodes :: [ExternalGraphNode] - -- This transitive dependency query does not contain hs-boot nodes. - , external_trans :: (ReachabilityIndex ExternalNode, ExternalKey -> Maybe ExternalNode) - , external_fully_loaded :: !(S.Set ExternalKey) } - -type ExternalNode = Node Int ExternalGraphNode - -data ExternalGraphNode - -- | A node for a home package module that is inserted in the EPS. - -- - -- INVARIANT: This type of node can only ever exist if compiling in one-shot - -- mode. In --make mode, it is imperative that the EPS doesn't have any home - -- package modules ever. - = NodeHomePackage - { externalNodeKey :: ModNodeKeyWithUid - , externalNodeDeps :: [ExternalKey] } - -- | A node for packages with at least one module loaded in the EPS. - -- - -- Edge from A to NodeExternalPackage p when A has p as a direct package - -- dependency. - | NodeExternalPackage - { externalPkgKey :: UnitId - , externalPkgDeps :: S.Set UnitId - } - -data ExternalKey - = ExternalModuleKey ModNodeKeyWithUid - | ExternalPackageKey UnitId - deriving (Eq, Ord) - -emptyExternalModuleGraph :: ExternalModuleGraph -emptyExternalModuleGraph = ExternalModuleGraph [] (graphReachability emptyGraph, const Nothing) S.empty - --- | Get the dependencies of an 'ExternalNode' -emgNodeDeps :: Bool -> ExternalGraphNode -> [ExternalKey] -emgNodeDeps drop_hs_boot_nodes = \case - NodeHomePackage _ dps -> map drop_hs_boot dps - NodeExternalPackage _ dps -> map ExternalPackageKey $ S.toList dps - where - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature - | otherwise = IsBoot - - drop_hs_boot (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (ExternalModuleKey (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) - drop_hs_boot x = x - --- | The graph key for a given node -emgNodeKey :: ExternalGraphNode -> ExternalKey -emgNodeKey (NodeHomePackage k _) = ExternalModuleKey k -emgNodeKey (NodeExternalPackage k _) = ExternalPackageKey k - --- | Lookup a key in the EMG. -emgLookupKey :: ExternalKey -> ExternalModuleGraph -> Maybe ExternalGraphNode -emgLookupKey k emg = node_payload <$> (snd (external_trans emg)) k - --------------------------------------------------------------------------------- --- * Extending --------------------------------------------------------------------------------- - -extendExternalModuleGraph :: ExternalGraphNode -> ExternalModuleGraph -> ExternalModuleGraph -extendExternalModuleGraph node ExternalModuleGraph{..} = - ExternalModuleGraph - { external_fully_loaded = external_fully_loaded - , external_nodes = node : external_nodes - , external_trans = first cyclicGraphReachability $ - externalGraphNodes True (node : external_nodes) - } - --------------------------------------------------------------------------------- --- * Loading --------------------------------------------------------------------------------- - -isFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> Bool -isFullyLoadedModule key graph = S.member key (external_fully_loaded graph) - -setFullyLoadedModule :: ExternalKey -> ExternalModuleGraph -> ExternalModuleGraph -setFullyLoadedModule key graph = graph { external_fully_loaded = S.insert key (external_fully_loaded graph)} - --------------------------------------------------------------------------------- --- * Reachability --------------------------------------------------------------------------------- - --- | Return all nodes reachable from the given key, also known as its full --- transitive closure. --- --- @Nothing@ if the key couldn't be found in the graph. -emgReachableLoop :: ExternalModuleGraph -> ExternalKey -> Maybe [ExternalGraphNode] -emgReachableLoop mg nk = map node_payload <$> modules_below where - (td_map, lookup_node) = external_trans mg - modules_below = - allReachable td_map <$> lookup_node nk - --- | Return all nodes reachable from all of the given keys. -emgReachableLoopMany :: ExternalModuleGraph -> [ExternalKey] -> [ExternalGraphNode] -emgReachableLoopMany mg nk = map node_payload modules_below where - (td_map, lookup_node) = external_trans mg - modules_below = - allReachableMany td_map (mapMaybe lookup_node nk) - --------------------------------------------------------------------------------- --- * Internals --------------------------------------------------------------------------------- - --- | Turn a list of graph nodes into an efficient queriable graph. --- The first boolean parameter indicates whether nodes corresponding to hs-boot files --- should be collapsed into their relevant hs nodes. -externalGraphNodes :: Bool - -> [ExternalGraphNode] - -> (Graph ExternalNode, ExternalKey -> Maybe ExternalNode) -externalGraphNodes drop_hs_boot_nodes summaries = - (graphFromEdgedVerticesUniq nodes, lookup_node) - where - -- Map from module to extra boot summary dependencies which need to be merged in - (boot_summaries, nodes) = bimap M.fromList id $ partitionWith go numbered_summaries - - where - go (s, key) = - case s of - NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps | drop_hs_boot_nodes - -- Using emgNodeDeps here converts dependencies on other - -- boot files to dependencies on dependencies on non-boot files. - -> Left (mkModule uid mn, emgNodeDeps drop_hs_boot_nodes s) - _ -> normal_case - where - normal_case = - let lkup_key = - case s of - NodeHomePackage (ModNodeKeyWithUid (GWIB mn IsBoot) uid) _deps - -> Just $ mkModule uid mn - _ -> Nothing - - extra = (lkup_key >>= \key -> M.lookup key boot_summaries) - - in Right $ DigraphNode s key $ out_edge_keys $ - (fromMaybe [] extra - ++ emgNodeDeps drop_hs_boot_nodes s) - - numbered_summaries = zip summaries [1..] - - lookup_node :: ExternalKey -> Maybe ExternalNode - lookup_node key = M.lookup key node_map - - lookup_key :: ExternalKey -> Maybe Int - lookup_key = fmap node_key . lookup_node - - node_map :: M.Map ExternalKey ExternalNode - node_map = - M.fromList [ (emgNodeKey s, node) - | node <- nodes - , let s = node_payload node - ] - - out_edge_keys :: [ExternalKey] -> [Int] - out_edge_keys = mapMaybe lookup_key - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- IsBoot; else False - -instance Outputable ExternalGraphNode where - ppr = \case - NodeHomePackage mk ds -> text "NodeHomePackage" <+> ppr mk <+> ppr ds - NodeExternalPackage mk ds -> text "NodeExternalPackage" <+> ppr mk <+> ppr ds - -instance Outputable ExternalKey where - ppr = \case - ExternalModuleKey mk -> text "ExternalModuleKey" <+> ppr mk - ExternalPackageKey uid -> text "ExternalPackageKey" <+> ppr uid - -instance Outputable ExternalModuleGraph where - ppr ExternalModuleGraph{external_nodes, external_fully_loaded} - = text "ExternalModuleGraph" <+> ppr external_nodes <+> ppr external_fully_loaded ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -41,6 +41,8 @@ module GHC.Unit.Module.Graph , ModuleNodeInfo(..) , moduleNodeInfoModule + , moduleNodeInfoUnitId + , moduleNodeInfoMnwib , moduleNodeInfoModuleName , moduleNodeInfoModNodeKeyWithUid , moduleNodeInfoHscSource @@ -48,7 +50,7 @@ module GHC.Unit.Module.Graph , isBootModuleNodeInfo -- * Module graph operations , lengthMG - + , isEmptyMG -- ** 'ModSummary' operations -- -- | A couple of operations on the module graph allow access to the @@ -100,6 +102,10 @@ module GHC.Unit.Module.Graph , ModNodeKey , ModNodeKeyWithUid(..) , mnkToModule + , moduleToMnk + , mnkToInstalledModule + , installedModuleToMnk + , mnkIsBoot , msKey , mnKey , miKey @@ -310,7 +316,7 @@ checkFixedModuleInvariant node_types node = case node of _ -> Nothing -{- Note [Modules Types in the ModuleGraph] +{- Note [Module Types in the ModuleGraph] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Modules can be one of two different types in the module graph. @@ -365,6 +371,14 @@ isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) +moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId +moduleNodeInfoUnitId (ModuleNodeFixed key _) = mnkUnitId key +moduleNodeInfoUnitId (ModuleNodeCompile ms) = ms_unitid ms + +moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot +moduleNodeInfoMnwib (ModuleNodeFixed key _) = mnkModuleName key +moduleNodeInfoMnwib (ModuleNodeCompile ms) = ms_mnwib ms + -- | Collect the immediate dependencies of a ModuleGraphNode, -- optionally avoiding hs-boot dependencies. -- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is @@ -425,6 +439,9 @@ instance Ord ModuleGraphNode where lengthMG :: ModuleGraph -> Int lengthMG = length . mg_mss +isEmptyMG :: ModuleGraph -> Bool +isEmptyMG = null . mg_mss + -------------------------------------------------------------------------------- -- ** ModSummaries -------------------------------------------------------------------------------- ===================================== compiler/GHC/Unit/Module/ModNodeKey.hs ===================================== @@ -1,4 +1,11 @@ -module GHC.Unit.Module.ModNodeKey ( ModNodeKeyWithUid(..), mnkToModule, mnkIsBoot ) where +module GHC.Unit.Module.ModNodeKey + ( ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkIsBoot + , mnkToInstalledModule + , installedModuleToMnk + ) where import GHC.Prelude import GHC.Utils.Outputable @@ -7,12 +14,22 @@ import GHC.Unit.Types data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot , mnkUnitId :: !UnitId } deriving (Eq, Ord) -mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface -mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib - mnkToModule :: ModNodeKeyWithUid -> Module mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) +mnkToInstalledModule :: ModNodeKeyWithUid -> InstalledModule +mnkToInstalledModule (ModNodeKeyWithUid mnwib uid) = Module uid (gwib_mod mnwib) + +-- | Already InstalledModules are always NotBoot +installedModuleToMnk :: InstalledModule -> ModNodeKeyWithUid +installedModuleToMnk mod = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnit mod) + +moduleToMnk :: Module -> IsBootInterface -> ModNodeKeyWithUid +moduleToMnk mod is_boot = ModNodeKeyWithUid (GWIB (moduleName mod) is_boot) (moduleUnitId mod) + +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + instance Outputable ModNodeKeyWithUid where ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib ===================================== compiler/ghc.cabal.in ===================================== @@ -526,6 +526,7 @@ Library GHC.Driver.MakeSem GHC.Driver.Main GHC.Driver.Make + GHC.Driver.Messager GHC.Driver.MakeAction GHC.Driver.MakeFile GHC.Driver.Monad @@ -956,7 +957,6 @@ Library GHC.Unit.Module.Env GHC.Unit.Module.Graph GHC.Unit.Module.ModNodeKey - GHC.Unit.Module.External.Graph GHC.Unit.Module.Imported GHC.Unit.Module.Location GHC.Unit.Module.ModDetails ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs ===================================== @@ -0,0 +1,102 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import GHC +import GHC.Driver.Session +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Make (summariseFile) +import GHC.Driver.Downsweep +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Types.SourceFile +import System.Environment +import Control.Monad (void, when) +import Data.Maybe (fromJust) +import Control.Exception (ExceptionWithContext(..), SomeException) +import Control.Monad.Catch (handle, throwM) +import Control.Exception.Context +import GHC.Utils.Outputable +import Data.List +import GHC.Unit.Env +import GHC.Unit.State +import GHC.Tc.Utils.Monad +import GHC.Iface.Env +import GHC.Driver.Ppr +import GHC.Unit.Home + + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) $ handle (\(ExceptionWithContext c e :: ExceptionWithContext SomeException) -> + liftIO $ putStrLn (displayExceptionContext c) >> print e >> throwM e) $ do + + -- Set up session + dflags <- getSessionDynFlags + setSessionDynFlags (dflags { verbosity = 1 }) + hsc_env <- getSession + setSession $ hscSetActiveUnitId mainUnitId hsc_env + + -- Get ModSummaries for our test modules + msA <- getModSummaryFromTarget "T1A.hs" + msB <- getModSummaryFromTarget "T1B.hs" + msC <- getModSummaryFromTarget "T1C.hs" + + let targets = [ Target (TargetModule (ms_mod_name msA)) True (moduleUnitId $ ms_mod msA) Nothing + , Target (TargetModule (ms_mod_name msB)) True (moduleUnitId $ ms_mod msB) Nothing + , Target (TargetModule (ms_mod_name msC)) True (moduleUnitId $ ms_mod msC) Nothing + ] + + setTargets targets + + -- Compile interfaces for our modules + load LoadAllTargets + + hsc_env <- getSession + setSession $ hsc_env { hsc_dflags = (hsc_dflags hsc_env) { ghcMode = OneShot } } + hsc_env <- getSession + + + -- Create ModNodeKeys with unit IDs + let keyA = msKey msA + keyB = msKey msB + keyC = msKey msC + + let mkGraph s = do + ([], nodes) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed s [] + return $ mkModuleGraph nodes + + graph <- liftIO $ mkGraph [ModuleNodeCompile msC] + + liftIO $ putStrLn "loaded" + -- 1. Check that the module graph is valid + let invariantErrors = checkModuleGraph graph + + case invariantErrors of + [] -> liftIO $ putStrLn "PASS Test passed" + errors -> do + liftIO $ putStrLn "FAIL Test failed - invariant violations" + liftIO $ putStrLn $ showSDoc dflags $ vcat (map ppr errors) + + -- 2. Check that from the root, we can reach the "ghc-internal" package. + let ghcInternalPackage = NodeKey_ExternalUnit ghcInternalUnitId + let root = NodeKey_Module keyC + let reached = mgQuery graph root ghcInternalPackage + if not reached + then liftIO $ putStrLn "FAIL Test failed - cannot reach ghc-internal" + else liftIO $ putStrLn "PASS Test passed" + + + + where + + -- Helper to get ModSummary from a target file + getModSummaryFromTarget :: FilePath -> Ghc ModSummary + getModSummaryFromTarget file = do + hsc_env <- getSession + Right ms <- liftIO $ summariseFile hsc_env (DefiniteHomeUnit mainUnitId Nothing) mempty file Nothing Nothing + return ms ===================================== testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.stdout ===================================== @@ -0,0 +1,6 @@ +[1 of 3] Compiling T1A ( T1A.hs, T1A.o ) +[2 of 3] Compiling T1B ( T1B.hs, T1B.o ) +[3 of 3] Compiling T1C ( T1C.hs, T1C.o ) +loaded +PASS Test passed +PASS Test passed ===================================== testsuite/tests/ghc-api/fixed-nodes/all.T ===================================== @@ -13,3 +13,11 @@ test('ModuleGraphInvariants', ], compile_and_run, ['-package ghc']) + +test('InterfaceModuleGraph', + [extra_run_opts(f'"{config.libdir}"'), + extra_files(['T1A.hs', 'T1B.hs', 'T1C.hs']), + wasm_broken(25953) + ], + compile_and_run, + ['-package ghc']) ===================================== testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs ===================================== @@ -46,13 +46,8 @@ lookupModule :: ModuleName -- ^ Name of the module -> TcPluginM Module lookupModule mod_nm = do hsc_env <- getTopEnv - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let units = hsc_units hsc_env let home_unit = hsc_home_unit hsc_env - -- found_module <- findPluginModule fc fopts units home_unit mod_name - found_module <- tcPluginIO $ findPluginModule fc fopts units (Just home_unit) mod_nm + found_module <- tcPluginIO $ findPluginModule hsc_env mod_nm case found_module of FoundModule h -> return (fr_mod h) _ -> do View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d47bf7769758a1c8f65b66bb41b926c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d47bf7769758a1c8f65b66bb41b926c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T24782] template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
by Teo Camarasu (＠teo) 16 Apr '25

16 Apr '25

Teo Camarasu pushed to branch wip/T24782 at Glasgow Haskell Compiler / GHC Commits: bbc2f110 by Teo Camarasu at 2025-04-16T17:14:16+01:00 template-haskell: Remove `addrToByteArrayName` and `addrToByteArray` These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. Resolves #24782 - - - - - 3 changed files: - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - libraries/template-haskell/changelog.md - testsuite/tests/interface-stability/template-haskell-exports.stdout Changes: ===================================== libraries/template-haskell/Language/Haskell/TH/Syntax.hs ===================================== @@ -1,6 +1,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE UnboxedTuples #-} module Language.Haskell.TH.Syntax ( @@ -190,16 +190,11 @@ module Language.Haskell.TH.Syntax ( nothingName, rightName, trueName, - addrToByteArrayName, - addrToByteArray, ) where -import Data.Array.Byte import GHC.Boot.TH.Lift import GHC.Boot.TH.Syntax -import GHC.Exts -import GHC.ST import System.FilePath -- This module completely re-exports 'GHC.Boot.TH.Syntax', @@ -211,17 +206,3 @@ makeRelativeToProject fp | isRelative fp = do root <- getPackageRoot return (root </> fp) makeRelativeToProject fp = return fp - --- The following two defintions are copied from 'Data.Byte.Array' --- in order to preserve the old export list of 'TH.Syntax'. --- They will soon be removed as part of #24782. - -addrToByteArrayName :: Name -addrToByteArrayName = 'addrToByteArray - -addrToByteArray :: Int -> Addr# -> ByteArray -addrToByteArray (I# len) addr = runST $ ST $ - \s -> case newByteArray# len s of - (# s', mb #) -> case copyAddrToByteArray# addr mb 0# len s' of - s'' -> case unsafeFreezeByteArray# mb s'' of - (# s''', ret #) -> (# s''', ByteArray ret #) ===================================== libraries/template-haskell/changelog.md ===================================== @@ -13,6 +13,8 @@ * Remove the `Language.Haskell.TH.Lib.Internal` module. This module has long been deprecated, and exposes compiler internals. Users should use `Language.Haskell.TH.Lib` instead, which exposes a stable version of this API. + + * Remove `addrToByteArrayName` and `addrToByteArray` from `Language.Haskell.TH.Syntax`. These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage. ## 2.23.0.0 ===================================== testsuite/tests/interface-stability/template-haskell-exports.stdout ===================================== @@ -1369,7 +1369,7 @@ module Language.Haskell.TH.Quote where quoteFile :: QuasiQuoter -> QuasiQuoter module Language.Haskell.TH.Syntax where - -- Safety: Trustworthy + -- Safety: Safe type AnnLookup :: * data AnnLookup = AnnLookupModule Module | AnnLookupName Name type AnnTarget :: * @@ -1780,8 +1780,6 @@ module Language.Haskell.TH.Syntax where addModFinalizer :: Q () -> Q () addTempFile :: GHC.Internal.Base.String -> Q GHC.Internal.IO.FilePath addTopDecls :: [Dec] -> Q () - addrToByteArray :: GHC.Internal.Types.Int -> GHC.Internal.Prim.Addr# -> Data.Array.Byte.ByteArray - addrToByteArrayName :: Name badIO :: forall a. GHC.Internal.Base.String -> GHC.Internal.Types.IO a bindCode :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> (a -> Code m b) -> Code m b bindCode_ :: forall (m :: * -> *) a (r :: GHC.Internal.Types.RuntimeRep) (b :: TYPE r). GHC.Internal.Base.Monad m => m a -> Code m b -> Code m b View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbc2f11035915a3c29866af2e35f3b5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bbc2f11035915a3c29866af2e35f3b5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/T25965
by Simon Peyton Jones (＠simonpj) 16 Apr '25

16 Apr '25

Simon Peyton Jones pushed new branch wip/T25965 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/T25965 You're receiving this email because of your account on gitlab.haskell.org.

1 0