April 2026 - ghc-commits

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

22 Apr '26

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

1 0

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

22 Apr '26

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

1 0

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

22 Apr '26

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

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Spelling error [skip ci]
by Simon Peyton Jones (＠simonpj) 21 Apr '26

21 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: 699cbde1 by Simon Peyton Jones at 2026-04-22T00:17:12+01:00 Spelling error [skip ci] - - - - - 1 changed file: - compiler/GHC/Builtin.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -191,7 +191,7 @@ When do we use each of these? and then renames and typechecks them. These bindings refer to a myriad of identifiers, such as `(==)`, `(>)`, `inRange`, and so on. Again GHC does not need to know a statically-known unique for them, but it does need to find them - so it uses known-occ names for them. See lots ant lots of definitions like + so it uses known-occ names for them. See lots and lots of definitions like gunfold_RDR :: RdrName gunfold_RDR = knownVarOccRdrName "gunfold" in GHC.Builtin.KnownOccs. This definition constructs a known-occ RdrName; sse View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/699cbde1d2f4c2ddea2bd14de3905c1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/699cbde1d2f4c2ddea2bd14de3905c1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26989] 31 commits: Suppress desugaring warnings in the pattern match checker
by Simon Peyton Jones (＠simonpj) 21 Apr '26

21 Apr '26

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: d419e972 by Luite Stegeman at 2026-04-13T15:16:04-04:00 Suppress desugaring warnings in the pattern match checker Avoid duplicating warnings from the actual desugaring pass. fixes #25996 - - - - - c5b80dd0 by Phil de Joux at 2026-04-13T15:16:51-04:00 Typo ~/ghc/arch-os-version/environments - - - - - 71462fff by Luite Stegeman at 2026-04-13T15:17:38-04:00 add changelog entry for #26233 - - - - - d1ddfd4b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add test for #25636 The existing test behaviour of "T23146_liftedeq" changed because the simplifier now does a bit more inlining. We can restore the previous bad behavior by using an OPAQUE pragma. This test doubles as a test for #25636 when run in ghci, so we add it as such. - - - - - b9df40ee by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: protoBCOName is always a Name Simplifies the code by removing the unnecessary type argument to ProtoBCO which was always 'Name' - - - - - 5c2a179e by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Allocate static constructors for bytecode This commit adds support for static constructors when compiling and linking ByteCode objects. Top-level StgRhsCon get lowered to ProtoStaticCons rather than to ProtoBCOs. A ProtoStaticCon gets allocated directly as a data con application on the heap (using the new primop newConApp#). Previously, we would allocate a ProtoBCO which, when evaluated, would PACK and return the constructor. A few more details are given in Note [Static constructors in Bytecode]. Secondly, this commit also fixes issue #25636 which was caused by linking *unlifted* constructors in BCO instructions as - (1) a thunk indexing the array of BCOs in a module - (2) which evaluated to a BCO which still had to be evaluated to return the unlifted constructor proper. The (2) issue has been resolved by allocating the static constructors directly. The (1) issue can be resolved by ensuring that we allocate all unlifted top-level constructors eagerly, and leave the knot-tying for the lifted BCOs and top-level constructors only. The top-level unlifted constructors are never mutually recursive, so we can allocate them all in one go as long as we do it in topological order. Lifted fields of unlifted constructors can still be filled by the knot-tied lifted variables since in those fields it is fine to keep those thunks. See Note [Tying the knot in createBCOs] for more details. Fixes #25636 ------------------------- Metric Decrease: LinkableUsage01 ------------------------- - - - - - cde47053 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Revert "StgToByteCode: Assert that PUSH_G'd values are lifted" This reverts commit ec26c54d818e0cd328276196930313f66b780905. Ever since f7a22c0f4e9ae0dc767115d4c53fddbd8372b777, we now do support and will link top-level unlifted constructors into evaluated and properly tagged values which we can reference with PUSH_G. This assertion is no longer true and triggered a failure in T25636 - - - - - c7a7e5b8 by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 refactor: Tag more remote Ptrs as RemotePtr Pure refactor which improves the API of - GHC.ByteCode.Linker - GHC.Runtime.Interpreter - GHC.Runtime.Interpreter.Types.SymbolCache by using `RemotePtr` for more functions which used to return `Ptr`s that could potentially be in a foreign process. E.g. `lookupIE`, `lookupStaticPtr`, etc... - - - - - fc59494c by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 Add float# and subword tests for #25636 These tests cover that static constructors in bytecode work correctly for Float# and subword values (Word8#, Word16#) - - - - - 477f521b by Rodrigo Mesquita at 2026-04-14T18:41:12-04:00 test: Validate topoSort logic in createBCOs This test validates that the topological sorting and ordering of the unlifted constructors and lifted constructors in `createBCOs` is correct. See `Note [Tying the knot in createBCOs]` for why tying the knot for the created BCOs is slightly difficult and why the topological sorting is necessary. This test fails when `let topoSortedObjs = topSortObjs objs` is substituted by `let topoSortedObjs = zip [0..] objs`, thus witnessing the toposort logic is correct and necessary. The test calls the ghci `createBCOs` directly because it is currently impossible to construct in Source Haskell a situation where a top-level static unlifted constructor depends on another (we don't have top-level unlifted constructors except for nullary constructors like `Leaf :: (UTree :: UnliftedType)`). This is another test for fix for #25636 - - - - - 2d9c30be by Simon Jakobi at 2026-04-14T18:42:00-04:00 Improve tests for `elem` ...in order to simplify the work on #27096. * Improve T17752 by including the Core output in golden files, checking both -O1 and -O2. * Add tests for fusion and no-fusion cases. Fixes #27101. - - - - - 2dadf3b0 by sheaf at 2026-04-16T13:28:39-04:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. The most important change is that we revert the logic (added in 85b0aae2) that allowed ticks to be placed around coercions, which caused serious issues (e.g. #27121). It was just a mistake, as it doesn't make sense to put a tick around a coercion. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - a0d6f1f4 by Simon Jakobi at 2026-04-16T13:29:28-04:00 Add regression test for #9074 Closes #9074. - - - - - d178ee89 by Sylvain Henry at 2026-04-16T13:30:25-04:00 Add changelog for #15973 - - - - - e8a196c6 by sheaf at 2026-04-16T13:31:19-04:00 Deal with 'noSpec' in 'coreExprToPmLit' This commit makes two separate changes relating to 'GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit': 1. Commit 7124e4ad mistakenly marked deferred errors as non-canonical, which led to the introduction of 'nospec' wrappers in the generated Core. This reverts that accident by declaring deferred errors as being canonical, avoiding spurious 'nospec' wrapping. 2. Look through magic identity-like Ids such as 'nospec', 'inline' and 'lazy' in 'coreExprAsPmLit', just like Core Prep does. There might genuinely be incoherent evidence, but that shouldn't obstruct the pattern match checker. See test T27124a. Fixes #25926 #27124 ------------------------- Metric Decrease: T3294 ------------------------- - - - - - 8cb99552 by Sylvain Henry at 2026-04-16T19:22:43-04:00 hadrian: warn when package index is missing (#16484) Since cabal-install 3.0 we can query the path of remote-repo-cache and check if hackage package index is present. Fixes #16484 - - - - - d6ce7477 by Richard Eisenberg at 2026-04-16T19:23:25-04:00 Teach hadrian to --skip-test. Fixes #27188. This adds the --skip-test flag to `hadrian build`, as documented in the patch. - - - - - 7666f4a9 by Fendor at 2026-04-17T22:29:51-04:00 Migrate `ghc-pkg` to use `OsPath` and `file-io` `ghc-pkg` should use UNC paths as much as possible to avoid MAX_PATH issues on windows. `file-io` uses UNC Paths by default on windows, ensuring we use the correct APIs and that we finally are no longer plagued by MAX_PATH issues in CI and private machines. On top of it, the higher correctness of `OsPath` is appreciated in this small codebase. Also, we improve memory usage very slightly, due to the more efficient memory representation of `OsPath` over `FilePath` Adds `ghc-pkg` regression test for MAX_PATH on windows Make sure `ghc-pkg` behaves as expected when long paths (> 255) are involved on windows. Let's generate a testcase where we can actually observe that `ghc-pkg` behaves as epxected. See the documentation for windows on Maximum Path Length Limitation: * `https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation` Adds changelog entry for long path support in ghc-pkg. - - - - - 78434e8c by Simon Peyton Jones at 2026-04-17T22:30:38-04:00 Kill off the substitution in Lint Now that we have invariant (NoTypeShadowing) we no longer need Lint to carry an ambient substitution. This makes it simpler and faster. A really worthwhile refactor. There are some knock-on effects * Linting join points after worker/wrapper. See Note [Join points and beta redexes] * Running a type substitution after the desugarer. See Note [Substituting type-lets] in the new module GHC.Core.SubstTypeLets Implements #27078 Most perf tests don't use Lint so we won't see a perf incresae. But T1969, which uses -O0 and Lint, gets 1.3% worse because it has to run the SubstTypeLets pass which is a somewhat expensive no-op Overall though compile-time allocations are down 0.1%. Metric Increase: T1969 - - - - - 86ca6c2c by mangoiv at 2026-04-17T22:31:22-04:00 testsuite: inline elemCoreTest Some weird (probably python scoping) rule caused elemCoreTest, a regex being out of scope on ubuntu, presumably because of a newer python version. This patch just inlines the regex, which fixes the issue. Fixes #27193 - - - - - f57cf4ee by Simon Peyton Jones at 2026-04-21T14:46:38+01:00 Improve knownCon Eliminate simplInVar Just a refactoring to simplify the code - - - - - 7005504c by Simon Peyton Jones at 2026-04-21T14:46:38+01:00 Wibbles [skip ci] - - - - - 45ca65f8 by Simon Peyton Jones at 2026-04-21T14:46:39+01:00 Getting there [skip ci] - - - - - 4489af13 by Simon Peyton Jones at 2026-04-21T14:46:39+01:00 Wibbles [skip ci] - - - - - a0b2b7fc by Simon Peyton Jones at 2026-04-21T14:46:39+01:00 More wibbles This now works - - - - - 6e39b542 by Simon Peyton Jones at 2026-04-21T14:46:39+01:00 Wibble - - - - - 84e5846e by Simon Peyton Jones at 2026-04-21T14:46:39+01:00 Wibbles Better management of casts - - - - - 5b541cc8 by Simon Peyton Jones at 2026-04-21T15:00:01+01:00 Wibbles - - - - - 448012f0 by Simon Peyton Jones at 2026-04-21T15:00:05+01:00 More small wibbles The important change here is in preInlineUnconditionally - - - - - f3e54339 by Simon Peyton Jones at 2026-04-21T15:00:05+01:00 Wibble [skip ci] - - - - - 83b0a16c by Simon Peyton Jones at 2026-04-22T00:08:00+01:00 wibbles - - - - - 142 changed files: - + changelog.d/T15973 - + changelog.d/T25636 - + changelog.d/T27121.md - + changelog.d/T27124.md - + changelog.d/fix-duplicate-pmc-warnings - + changelog.d/fix-ghci-duplicate-warnings-26233 - + changelog.d/ghc-pkg-long-path-support - + changelog.d/hadrian-warn-missing-package-index-16484 - + changelog.d/skip-test - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Binary.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/ByteCode/Types.hs - compiler/GHC/Cmm/Liveness.hs - compiler/GHC/Core.hs - compiler/GHC/Core/Lint.hs - + compiler/GHC/Core/Lint/SubstTypeLets.hs - compiler/GHC/Core/Opt/FloatOut.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/HsToCore/Pmc/Desugar.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/StgToCmm/DataCon.hs - compiler/GHC/StgToCmm/Layout.hs - compiler/GHC/StgToCmm/Prim.hs - compiler/GHC/StgToJS/Prim.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Types/Tickish.hs - compiler/GHC/Unit/State.hs - compiler/ghc.cabal.in - docs/users_guide/packages.rst - hadrian/build-cabal - hadrian/build-cabal.bat - hadrian/doc/make.md - hadrian/doc/testsuite.md - hadrian/src/CommandLine.hs - hadrian/src/Settings/Builders/RunTest.hs - + libraries/base/tests/perf/ElemFusionUnknownList.hs - + libraries/base/tests/perf/ElemFusionUnknownList_O1.stderr - + libraries/base/tests/perf/ElemFusionUnknownList_O2.stderr - + libraries/base/tests/perf/ElemNoFusion.hs - + libraries/base/tests/perf/ElemNoFusion_O1.stderr - + libraries/base/tests/perf/ElemNoFusion_O2.stderr - − libraries/base/tests/perf/Makefile - libraries/base/tests/perf/T17752.hs - − libraries/base/tests/perf/T17752.stdout - + libraries/base/tests/perf/T17752_O1.stderr - + libraries/base/tests/perf/T17752_O2.stderr - libraries/base/tests/perf/all.T - libraries/ghc-boot/GHC/Unit/Database.hs - libraries/ghc-boot/ghc-boot.cabal.in - libraries/ghc-heap/tests/tso_and_stack_closures.hs - libraries/ghci/GHCi/CreateBCO.hs - libraries/ghci/GHCi/ResolvedBCO.hs - rts/Interpreter.c - rts/PrimOps.cmm - rts/RtsSymbols.c - rts/include/Rts.h - rts/include/rts/storage/ClosureMacros.h - rts/include/stg/MiscClosures.h - testsuite/driver/runtests.py - testsuite/driver/testglobals.py - testsuite/driver/testlib.py - testsuite/tests/cabal/Makefile - testsuite/tests/cabal/all.T - + testsuite/tests/cabal/ghcpkg10.stdout - testsuite/tests/codeGen/should_run/T23146/T23146_liftedeq.hs - + testsuite/tests/codeGen/should_run/T23146/T25636.script - + testsuite/tests/codeGen/should_run/T23146/T25636.stdout - testsuite/tests/codeGen/should_run/T23146/all.T - + testsuite/tests/codeGen/should_run/T25636a/T25636a.script - + testsuite/tests/codeGen/should_run/T25636a/T25636a.stdout - + testsuite/tests/codeGen/should_run/T25636a/all.T - + testsuite/tests/codeGen/should_run/T25636b/T25636b.script - + testsuite/tests/codeGen/should_run/T25636b/T25636b.stdout - + testsuite/tests/codeGen/should_run/T25636b/all.T - + testsuite/tests/codeGen/should_run/T25636c/T25636c.script - + testsuite/tests/codeGen/should_run/T25636c/T25636c.stdout - + testsuite/tests/codeGen/should_run/T25636c/all.T - + testsuite/tests/codeGen/should_run/T25636d/T25636d.script - + testsuite/tests/codeGen/should_run/T25636d/T25636d.stdout - + testsuite/tests/codeGen/should_run/T25636d/all.T - + testsuite/tests/codeGen/should_run/T25636e/T25636e.script - + testsuite/tests/codeGen/should_run/T25636e/T25636e.stdout - + testsuite/tests/codeGen/should_run/T25636e/all.T - testsuite/tests/corelint/LintEtaExpand.stderr - testsuite/tests/corelint/T21115b.stderr - + testsuite/tests/deSugar/should_compile/T25996.hs - + testsuite/tests/deSugar/should_compile/T25996.stderr - testsuite/tests/deSugar/should_compile/all.T - testsuite/tests/ghci.debugger/scripts/print034.stdout - + testsuite/tests/ghci/T9074/Makefile - + testsuite/tests/ghci/T9074/T9074.hs - + testsuite/tests/ghci/T9074/T9074.stdout - + testsuite/tests/ghci/T9074/T9074a.c - + testsuite/tests/ghci/T9074/T9074b.c - + testsuite/tests/ghci/T9074/all.T - + testsuite/tests/ghci/should_run/T25636f.hs - + testsuite/tests/ghci/should_run/T25636f.stdout - testsuite/tests/ghci/should_run/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/interface-stability/ghc-experimental-exports.stdout - testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32 - testsuite/tests/interface-stability/ghc-prim-exports.stdout - testsuite/tests/interface-stability/ghc-prim-exports.stdout-mingw32 - + testsuite/tests/overloadedstrings/should_fail/T25926.hs - + testsuite/tests/overloadedstrings/should_fail/T25926.stderr - + testsuite/tests/overloadedstrings/should_fail/T27124.hs - + testsuite/tests/overloadedstrings/should_fail/T27124.stderr - + testsuite/tests/overloadedstrings/should_fail/all.T - + testsuite/tests/overloadedstrings/should_run/T27124a.hs - testsuite/tests/overloadedstrings/should_run/all.T - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T - utils/deriveConstants/Main.hs - utils/ghc-pkg/Main.hs - utils/ghc-pkg/ghc-pkg.cabal.in The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f65671b7e3c99031375bdb76d05368… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f65671b7e3c99031375bdb76d05368… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base2] Small changes in response to reviews
by Simon Peyton Jones (＠simonpj) 21 Apr '26

21 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base2 at Glasgow Haskell Compiler / GHC Commits: c256a107 by Simon Peyton Jones at 2026-04-21T21:39:18+01:00 Small changes in response to reviews - - - - - 14 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/KnownKeys.hs - docs/users_guide/exts/rebindable_syntax.rst - libraries/base/src/Data/Array/Byte.hs - libraries/base/src/Data/Bool.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/Data/Functor/Compose.hs - libraries/base/src/Data/Functor/Product.hs - libraries/base/src/Data/Functor/Sum.hs - libraries/base/src/Prelude.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/ghc-internal/src/GHC/Internal/Base.hs - libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs - utils/genprimopcode/Main.hs Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -112,9 +112,9 @@ Here are more details. A "wired-in" entity: * Defined in GHC.Builtin.WiredIn.* - * Its Unique, OccName - * Its defining module - * Its data constructors etc + * GHC knows its Unique, OccName + * GHC knows its defining module + * GHC knows its data constructors etc So GHC knows /everything/ about it. See Note [Overview of wired-in things]. We try hard to avoid wired-in things; it's tricky to ensure that GHC's static @@ -123,20 +123,22 @@ A "wired-in" entity: A "known-key" entity: * Defined in GHC.Builtin.KnownKeys * Its Unique and OccName are baked into GHC. Its Unique is called a KnownKey. - * It is exported by base:GHC.KnownKeyNames + * It is exported by GHC.KnownKeyNames * But that's all that GHC knows about it In particular, GHC does /not/ know in which module the entity is defined. Example: the `Eq` class has OccName "Eq" and unique `eqClassKey`. It happens to be defined in ghc-internal:GHC.Internal.Classes, but GHC does not know that. + Every known-key entity is also a known-occ entity, but not vice versa. + See Note [Recipe for adding a known-key name] for how to add a known-key name to GHC. It's not hard. A "known-occ" entity: * Defined in GHC.Builtin.KnownOccs * Its OccName is baked into GHC -- we call it a KnownOcc - * It is exported by base:GHC.KnownKeyNames + * It is exported by GHC.KnownKeyNames * But that's all that GHC knows about it In particular, GHC does /not/ know in which module the entity is defined, nor its Unique. @@ -189,14 +191,22 @@ When do we use each of these? and then renames and typechecks them. These bindings refer to a myriad of identifiers, such as `(==)`, `(>)`, `inRange`, and so on. Again GHC does not need to know a statically-known unique for them, but it does need to find them - so it uses known + so it uses known-occ names for them. See lots ant lots of definitions like + gunfold_RDR :: RdrName + gunfold_RDR = knownVarOccRdrName "gunfold" + in GHC.Builtin.KnownOccs. This definition constructs a known-occ RdrName; sse + knownOccRdrName :: KnownOcc -> RdrName + in GHC.Types.Name.Reader * When desugaring, the desugarer wants to refer to a particular class, type, or function. It does this via (e.g.) + dsLookupKnownOccTyCon eitherTyConOcc + where dsLookupKnownOccTyCon :: KnownOcc -> DsM TyCon - or + + For known-key entities you can also use dsLookupKnownKeyTyCon :: KnownKey -> DsM TyCon - (It doesn't really matter which we use.) + by giving it the known key of the entity. To implement all this, here are the moving parts. @@ -209,7 +219,7 @@ How known-occ entities work this is not an onerous restriction. But see Note [Tricky known-occ cases] in GHC.Builtin.KnownOccs for some awkward cases. -* A special module `base:GHC.KnownKeyNames` exports all the known-key and known-occ +* A distinguished module `GHC.KnownKeyNames` exports all the known-key and known-occ entities names. There is nothing special about this module except that GHC knows its name and can import it. @@ -220,6 +230,9 @@ How known-occ entities work This is a big reason for (KnownEntityInvariant): an export list cannot have two entities with the same OccName. + When GHC wants to find GHC.KnownKeyNames, it just looks for it in the same + way as any other import. + * There are three flags that control the treatment of known entities: -frebindable-known-names -fdefines-known-names @@ -307,10 +320,10 @@ Known-key entities are * DEFINING. In the module that /defines/ a known-key name, such as the `Num` class in ghc-internal:GHC.Internal.Num - we must assign the correct Unique. So in GHC.Rename.Env.newTopVanillaSrcBinder - if -fdefines-known-key-names is set (Opt_DefinesKnownKeyNames), we check the - OccName against the list in `knownKeyTable`; if it appears there, we use the - Unique from the table. + we must assign the correct Unique at its definitino site. So in + `GHC.Rename.Env.newTopVanillaSrcBinder`, if -fdefines-known-key-names is set + (Opt_DefinesKnownKeyNames), we check the OccName against the list in `knownKeyTable`; + if it appears there, we use the Unique from the table. * SERIALISING. - When we serialise a known-key name into an interface file, we mark it as such. @@ -343,7 +356,7 @@ Wrinkles So we compile GHC.Internal.Data.Foldable with -fexclude-known-define=toList -(KN3) We don't need need to export wired-in entities from GHC.KnownKeyNames +(KN3) We don't need to export wired-in entities from GHC.KnownKeyNames because we (should) never look up a wired-in name via its key. That is, `GHC.Iface.Load.lookupKnownKeyName` should never be called on the key of a wired-in name. @@ -355,9 +368,9 @@ Wrinkles Note [Recipe for adding a known-occ name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To make `wombat` into a known-occ name, you must ensure that: +To make `wombat` into a known-occ name, you do the following: -* The module `GHC.KnownKeyNames` must export `wombat`. +* Ensure that the module `GHC.KnownKeyNames` exports `wombat`. * In any module in `base` or `ghc-internal` (which are compiled with -frebindable-known-names), in which `wombat` is needed, you must ensure @@ -373,14 +386,14 @@ To make `wombat` into a known-occ name, you must ensure that: Note [Recipe for adding a known-key name] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To make `wombat` into a known-key name, you must ensure that: +To make `wombat` into a known-key name, do the following. -* The module M that defines `wombat` is compiled with `-fdefines-known-names`. +* Ensure that the module M that defines `wombat` is compiled with `-fdefines-known-names`. -* If M.hs has an `M.hs-boot` file, it too must be compiled +* If M.hs has an `M.hs-boot` file, ensure that it too must be compiled with `-fdefines-known-names`. -* The module `GHC.KnownKeyNames` must export `wombat`. +* Ensure that the module `GHC.KnownKeyNames` exports `wombat`. * In GHC.Builtin.KnownKeys you must define a static unique wombatKey :: KnownKey ===================================== compiler/GHC/Builtin/KnownKeys.hs ===================================== @@ -1,9 +1,6 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[GHC.Builtin.KnownKeys]{Definitions of prelude modules and names} - - Nota Bene: all Names defined in here should come from the base package, the big-num package or (for plugins) the ghc package. ===================================== docs/users_guide/exts/rebindable_syntax.rst ===================================== @@ -78,16 +78,6 @@ not the Prelude versions: - An overloaded label "``#foo``" means "``fromLabel @"foo"``", rather than "``GHC.OverloadedLabels.fromLabel @"foo"``" (see :ref:`overloaded-labels`). -.. extension:: ImplicitKnownKeyNames - :shortdesc: Use module ``KnownKeyNames`` to find known-key names - - ToDo: needs proper documentation - -.. extension:: DefinesKnownKeyNames - :shortdesc: This modules defines one or more known-key names - - ToDo: needs proper documentation - :extension:`RebindableSyntax` implies :extension:`NoImplicitPrelude`. In all cases (apart from arrow notation), the static semantics should be ===================================== libraries/base/src/Data/Array/Byte.hs ===================================== @@ -15,15 +15,13 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We import Prelude, hence GHC.KnownKeyNames is available - module Data.Array.Byte ( ByteArray(..), MutableByteArray(..), ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import GHC.Internal.Data.Bits ((.&.), unsafeShiftR) import GHC.Internal.Data.Data (mkNoRepType, Data(..)) import GHC.Internal.Data.Typeable (Typeable) ===================================== libraries/base/src/Data/Bool.hs ===================================== @@ -1,8 +1,5 @@ {-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We import Prelude, hence GHC.KnownKeyNames is available - -- | -- -- Module : Data.Bool @@ -28,6 +25,7 @@ module Data.Bool ) where import Prelude ( Bool(..), (&&), (||), not, otherwise ) +import qualified GHC.KnownKeyNames as Rebindable -- $setup -- >>> import Prelude ===================================== libraries/base/src/Data/Fixed.hs ===================================== @@ -4,9 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We are importing Prelude, hence GHC.KnownKeyNames is available - ----------------------------------------------------------------------------- -- | -- Module : Data.Fixed @@ -90,6 +87,7 @@ module Data.Fixed ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import GHC.Internal.Data.Data import GHC.Internal.TypeLits (KnownNat, natVal) import GHC.Internal.Read ===================================== libraries/base/src/Data/Functor/Compose.hs ===================================== @@ -7,9 +7,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We import Prelude, hence GHC.KnownKeyNames is available - ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Compose @@ -30,6 +27,7 @@ module Data.Functor.Compose ( ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import Data.Functor.Classes import Control.Applicative import GHC.Internal.Data.Coerce (coerce) ===================================== libraries/base/src/Data/Functor/Product.hs ===================================== @@ -4,9 +4,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We import Prelude, hence GHC.KnownKeyNames is available - ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Product @@ -27,6 +24,7 @@ module Data.Functor.Product ( ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import Control.Applicative import GHC.Internal.Control.Monad (MonadPlus(..)) import GHC.Internal.Control.Monad.Fix (MonadFix(..)) ===================================== libraries/base/src/Data/Functor/Sum.hs ===================================== @@ -4,9 +4,6 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We are importing Prelude, hence GHC.KnownKeyNames is available - ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Sum @@ -27,6 +24,7 @@ module Data.Functor.Sum ( ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import Control.Applicative ((<|>)) import GHC.Internal.Data.Data (Data) import Data.Functor.Classes ===================================== libraries/base/src/Prelude.hs ===================================== @@ -164,11 +164,6 @@ module Prelude ( type (~) ) where -import GHC.KnownKeyNames () - -- Force a dependency on KnownKeyNames, so that any module that - -- imports Prelude can rely on KnownKeyNames existing, and hence - -- can be compiled without -frebindable-known-names - import GHC.Internal.Control.Monad import GHC.Internal.System.IO import GHC.Internal.System.IO.Error ===================================== libraries/base/src/System/Console/GetOpt.hs ===================================== @@ -1,7 +1,5 @@ {-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -fno-rebindable-known-names #-} - -- We are importing Prelude, hence GHC.KnownKeyNames is available ----------------------------------------------------------------------------- -- | -- Module : System.Console.GetOpt @@ -65,6 +63,7 @@ module System.Console.GetOpt ( ) where import Prelude +import qualified GHC.KnownKeyNames as Rebindable import GHC.Internal.Data.List ( isPrefixOf, find ) -- |What to do with options following non-options ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -468,10 +468,12 @@ Wrinkles: For modules high up in the hierarchy of `base`, a convenient way to do this is to say - import GHC.KnownKeyNames + import qualified GHC.KnownKeyNames as Rebindable + (Why `qualified` and `as Rebindable`? See (KN1) in + Note [Overview of known entities] in GHC.Builtin.) For modules not so high up, you can say - import GHC.Internal.Base + import qualified GHC.Internal.Base as Rebindable though you may also need GHC.Internal.Num when numerics are concerned. For `ghc-internal` modules below GHC.Internal.Base we have to be more selective. ===================================== libraries/ghc-internal/src/GHC/Internal/OverloadedLabels.hs ===================================== @@ -49,7 +49,8 @@ module GHC.Internal.OverloadedLabels ( IsLabel(..) ) where -import GHC.Internal.Base +import GHC.Internal.Types (Symbol) +import qualified GHC.Internal.Base as Rebindable class IsLabel (x :: Symbol) a where fromLabel :: a ===================================== utils/genprimopcode/Main.hs ===================================== @@ -313,11 +313,9 @@ gen_wrappers (Info _ entries) -- don't need the Prelude here so we add NoImplicitPrelude. ++ "{-# OPTIONS_GHC -Wno-deprecations -O0 -fno-do-eta-reduction #-}\n" -- Very important OPTIONS_GHC! See Note [OPTIONS_GHC in GHC.PrimopWrappers] - ++ "{-# OPTIONS_GHC -Wno-unused-imports #-}\n" - -- Don't warn about unused import of GHC.Internal.Base; needed for Typeable bindings ++ "module GHC.Internal.PrimopWrappers where\n" ++ "import qualified GHC.Internal.Prim\n" - ++ "import GHC.Internal.Base -- For Typeable bindings\n" + ++ "import qualified GHC.Internal.Base as Rebindable -- For Typeable bindings\n" ++ "import GHC.Internal.Tuple ()\n" ++ "import GHC.Internal.Prim (" ++ types ++ ")\n" ++ unlines (concatMap mk_wrapper wrappers) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c256a1075f20f6a83d0cda49843d252… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c256a1075f20f6a83d0cda49843d252… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add regression test for #10531
by Marge Bot (＠marge-bot) 21 Apr '26

21 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 915bba6f by Simon Jakobi at 2026-04-21T14:06:16-04:00 Add regression test for #10531 Closes #10531. - - - - - 5 changed files: - + testsuite/tests/driver/T10531/A.hs - + testsuite/tests/driver/T10531/B.hs - + testsuite/tests/driver/T10531/C.hs - + testsuite/tests/driver/T10531/Makefile - + testsuite/tests/driver/T10531/all.T Changes: ===================================== testsuite/tests/driver/T10531/A.hs ===================================== @@ -0,0 +1,4 @@ +module A where + +main :: IO () +main = putStrLn "A" ===================================== testsuite/tests/driver/T10531/B.hs ===================================== @@ -0,0 +1,6 @@ +module B where + +import A () + +main :: IO () +main = putStrLn "B" ===================================== testsuite/tests/driver/T10531/C.hs ===================================== @@ -0,0 +1,4 @@ +import B () + +main :: IO () +main = putStrLn "hi" ===================================== testsuite/tests/driver/T10531/Makefile ===================================== @@ -0,0 +1,14 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Test for #10531, a recompilation bug with '-main-is'. + +T10531: + '$(TEST_HC)' $(TEST_HC_OPTS) -Wall A.hs -main-is A.main -o a + '$(TEST_HC)' $(TEST_HC_OPTS) -Wall B.hs -main-is B.main -o b + '$(TEST_HC)' $(TEST_HC_OPTS) -Wall C.hs -o c + rm -f A.o + '$(TEST_HC)' $(TEST_HC_OPTS) -Wall A.hs -main-is A.main -o a + '$(TEST_HC)' $(TEST_HC_OPTS) -Wall B.hs -main-is B.main -o b + ./b$(exeext) ===================================== testsuite/tests/driver/T10531/all.T ===================================== @@ -0,0 +1 @@ +test('T10531', [extra_files(['A.hs', 'B.hs', 'C.hs']), ignore_stdout], makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/915bba6f1ee0f0f3719fcb0f1570e0c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/915bba6f1ee0f0f3719fcb0f1570e0c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: rts: add a few missing i386 relocations in the rts linker
by Marge Bot (＠marge-bot) 21 Apr '26

21 Apr '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 04d143c0 by Luite Stegeman at 2026-04-21T14:05:33-04:00 rts: add a few missing i386 relocations in the rts linker - - - - - 014087e7 by Luite Stegeman at 2026-04-21T14:05:34-04:00 CodeOutput: Fix finalizers on multiple platforms - ELF platforms: emit .fini_array section - wasm32/Darwin: emit initializer with __cxa_atexit call - Windows: use -Wl,--whole-archive to prevent dropping finalizer symbols - rts linker: fix crash/assertion failure unloading objects with finalizers fixes #27072 - - - - - 21 changed files: - + changelog.d/fix-finalizers-27072 - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Linker/Executable.hs - compiler/GHC/Types/ForeignStubs.hs - rts/Linker.c - rts/LinkerInternals.h - rts/linker/Elf.c - + testsuite/tests/codeGen/should_run/T27072d.hs - + testsuite/tests/codeGen/should_run/T27072d.stdout - + testsuite/tests/codeGen/should_run/T27072d_c.c - + testsuite/tests/codeGen/should_run/T27072d_check.c - + testsuite/tests/codeGen/should_run/T27072w.hs - + testsuite/tests/codeGen/should_run/T27072w.stdout - + testsuite/tests/codeGen/should_run/T27072w_c.c - testsuite/tests/codeGen/should_run/all.T - + testsuite/tests/rts/linker/T27072/Lib.c - + testsuite/tests/rts/linker/T27072/Makefile - + testsuite/tests/rts/linker/T27072/T27072.stdout - + testsuite/tests/rts/linker/T27072/all.T - + testsuite/tests/rts/linker/T27072/main.c - testsuite/tests/th/all.T Changes: ===================================== changelog.d/fix-finalizers-27072 ===================================== @@ -0,0 +1,10 @@ +section: codegen +synopsis: Fix module finalizers on multiple platforms +description: { + GHC-generated module finalizers (e.g. ``hs_spt_remove`` for the Static + Pointer Table) now run correctly on ELF platforms, darwin, wasm32 and + Windows. Also fixes running finalizers when unloading objects with the + RTS linker. +} +issues: #27072 +mrs: !15762 ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -119,6 +119,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g { a <- linted_cmm_stream ; let stubs = genForeignStubs a ; emitInitializerDecls this_mod stubs + ; emitFinalizerDecls this_mod stubs ; return (stubs, a) } ; let dus1 = newTagDUniqSupply CodeGenTag dus0 @@ -133,19 +134,23 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g } -- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details. -emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup () -emitInitializerDecls this_mod (ForeignStubs _ cstub) - | initializers <- getInitializers cstub - , not $ null initializers = - let init_array = CmmData sect statics - lbl = mkInitializerArrayLabel this_mod - sect = Section InitArray lbl +emitInitializerDecls, emitFinalizerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup () +emitInitializerDecls = emitInitFiniArrayDecls InitArray mkInitializerArrayLabel getInitializers +emitFinalizerDecls = emitInitFiniArrayDecls FiniArray mkFinalizerArrayLabel getFinalizers + +emitInitFiniArrayDecls :: SectionType -> (Module -> CLabel) -> (CStub -> [CLabel]) + -> Module -> ForeignStubs -> CgStream RawCmmGroup () +emitInitFiniArrayDecls sect_type mk_lbl get_labels this_mod (ForeignStubs _ cstub) + | labels <- get_labels cstub + , not $ null labels = + let lbl = mk_lbl this_mod + sect = Section sect_type lbl statics = CmmStaticsRaw lbl [ CmmStaticLit $ CmmLabel fn_name - | fn_name <- initializers + | fn_name <- labels ] - in Stream.yield [init_array] -emitInitializerDecls _ _ = return () + in Stream.yield [CmmData sect statics] +emitInitFiniArrayDecls _ _ _ _ _ = return () doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action ===================================== compiler/GHC/Linker/Executable.hs ===================================== @@ -300,7 +300,19 @@ linkExecutable logger tmpfs opts unit_env o_files dep_units = do then ["-Wl,--gc-sections"] else []) + -- On Windows, module .o files may be archives (see + -- Note [Object merging] in GHC.Driver.Pipeline.Execute). + -- Use --whole-archive to ensure all archive members are + -- included, especially those containing .ctors/.dtors + -- initializer/finalizer sections. See Note [Initializers and + -- finalizers in Cmm] in GHC.Cmm.InitFini. + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--whole-archive"] + else []) ++ o_files + ++ (if platformOS platform == OSMinGW32 + then ["-Wl,--no-whole-archive"] + else []) ++ lib_path_opts) ++ extra_ld_inputs ++ map GHC.SysTools.Option ( ===================================== compiler/GHC/Types/ForeignStubs.hs ===================================== @@ -59,11 +59,85 @@ initializerCStub platform clbl declarations body = -- | @finalizerCStub fn_nm decls body@ is a 'CStub' containing C finalizer -- function (e.g. an entry of the @.fini_array@ section) named -- @fn_nm@ with the given body and the given set of declarations. +-- +-- See Note [Finalizers via __cxa_atexit] finalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub -finalizerCStub platform clbl declarations body = - functionCStub platform clbl declarations body +finalizerCStub platform clbl declarations body + | ArchWasm32 <- platformArch platform + = -- See Note [Finalizers via __cxa_atexit] + cxaAtexitFinalizerCStub platform clbl declarations body +finalizerCStub platform clbl declarations body + | OSDarwin <- platformOS platform + = -- See Note [Finalizers via __cxa_atexit] + cxaAtexitFinalizerCStub platform clbl declarations body +finalizerCStub platform clbl declarations body + = functionCStub platform clbl declarations body `mappend` CStub empty [] [clbl] +-- | Generate a @__cxa_atexit@-based finalizer. +-- See Note [Finalizers via __cxa_atexit] +cxaAtexitFinalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub +cxaAtexitFinalizerCStub platform clbl declarations body = + let clbl_pretty = pprCLabel platform clbl + fini_name = hcat [clbl_pretty, text "$fini"] + wrapper_name = hcat [clbl_pretty, text "$fini_atexit"] + c_code = vcat + [ declarations + , text "int __cxa_atexit(void (*)(void *), void *, void *);" + , hcat [text "static void ", fini_name, text "(void)"] + , braces body + , hcat [text "static void ", wrapper_name, text "(void *arg __attribute__((unused)))"] + , braces (hcat [fini_name, text "();"]) + , hsep [text "void", clbl_pretty, text "(void)"] + , braces (hcat [text "__cxa_atexit(", wrapper_name, text ", 0, 0);"]) + ] + in CStub c_code [clbl] [] + +{- +Note [Finalizers via __cxa_atexit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On some platforms, placing a function pointer in the .fini_array / +__mod_term_func section is not sufficient to have it called on exit. +On these platforms we instead lower finalizers as initializers that register +the actual finalizer function via __cxa_atexit. + +Affected platforms: + + Wasm32: does not support .fini_array sections. + + Darwin: modern macOS dyld no longer processes __DATA,__mod_term_func entries. + Clang now lowers __attribute__((destructor)) as an initializer that calls + __cxa_atexit, placing the initializer in __DATA,__mod_init_func (which the + linker converts to __TEXT,__init_offsets). GHC must follow the same pattern. + +For a finalizer with label `clbl` and body `body`, on these platforms we +generate: + + static void clbl$fini(void) { + <body> + } + static void clbl$fini_atexit(void *arg) { + clbl$fini(); + } + void clbl(void) { + __cxa_atexit(clbl$fini_atexit, 0, 0); + } + +The function `clbl` is placed in the initializers list (getInitializers) +instead of the finalizers list (getFinalizers). During code output, +emitInitializerDecls places it in .init_array / __mod_init_func, so the +registration runs at startup. + +The actual finalizer body is in the static helper `clbl$fini`. A separate +wrapper `clbl$fini_atexit` with the void(*)(void*) signature expected by +__cxa_atexit is needed because some platforms (e.g. wasm32) enforce exact +function signature matching at call sites — a simple cast would trap at +runtime. + +This matches what clang does when lowering __attribute__((destructor)) on +these platforms. +-} + newtype CHeader = CHeader { getCHeader :: SDoc } instance Monoid CHeader where ===================================== rts/Linker.c ===================================== @@ -1117,6 +1117,27 @@ freePreloadObjectFile (ObjectCode *oc) oc->fileSize = 0; } +/* Note [Object unloading and finalizers] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * An ObjectCode may contain .fini_array/.dtors sections with finalizers that + * should run when the object is unloaded. However, we must only run these + * finalizers if the corresponding initializers (.init_array/.ctors) have + * actually been executed. + * + * Archive members start in OBJECT_LOADED state and only progress to + * OBJECT_NEEDED -> OBJECT_RESOLVED -> OBJECT_READY when a symbol from + * them is actually required. An archive member that was never needed never + * has its relocations applied, so its .fini_array section data still + * contains zeros (unresolved relocation targets). Running those finalizers + * would dereference NULL function pointers. + * + * When unloadObj sets an object's status to OBJECT_UNLOADED, it does so + * regardless of the previous state, so we cannot rely on the status alone + * to decide whether finalizers should run. Instead, we track whether + * initializers were executed via the initializersRan flag, which is set in + * ocRunInit after successfully running the initializers. + */ + /* * freeObjectCode() releases all the pieces of an ObjectCode. It is called by * the GC when a previously unloaded ObjectCode has been determined to be @@ -1126,11 +1147,9 @@ void freeObjectCode (ObjectCode *oc) { IF_DEBUG(linker, ocDebugBelch(oc, "freeObjectCode: start\n")); - // Run finalizers - if (oc->type == STATIC_OBJECT && - (oc->status == OBJECT_READY || oc->status == OBJECT_UNLOADED)) { - // Only run finalizers if the initializers have also been run, which - // happens when we resolve the object. + // Run finalizers only if initializers have been run. + // See Note [Object unloading and finalizers]. + if (oc->type == STATIC_OBJECT && oc->initializersRan) { #if defined(OBJFORMAT_ELF) ocRunFini_ELF(oc); #elif defined(OBJFORMAT_PEi386) @@ -1295,6 +1314,7 @@ mkOc( ObjectType type, pathchar *path, char *image, int imageSize, oc->imageMapped = mapped; oc->misalignment = misalignment; + oc->initializersRan = false; oc->cxa_finalize = NULL; oc->extraInfos = NULL; @@ -1691,6 +1711,7 @@ int ocRunInit(ObjectCode *oc) foreignExportsFinishedLoadingObject(); if (!r) { return r; } + oc->initializersRan = true; oc->status = OBJECT_READY; return 1; ===================================== rts/LinkerInternals.h ===================================== @@ -268,6 +268,12 @@ struct _ObjectCode { after allocation, so that we can use realloc */ int misalignment; + /* Set to true after initializers (.init_array, .ctors, etc.) have been + * executed. Used by freeObjectCode to decide whether finalizers should + * run: only objects whose initializers ran should have their finalizers + * executed. See Note [Object unloading and finalizers]. */ + bool initializersRan; + /* The address of __cxa_finalize; set when at least one finalizer was * register and therefore we must call __cxa_finalize before unloading. * See Note [Resolving __dso_handle]. */ ===================================== rts/linker/Elf.c ===================================== @@ -1308,6 +1308,16 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, case COMPAT_R_386_NONE: break; case COMPAT_R_386_32: *pP = value; break; case COMPAT_R_386_PC32: *pP = value - P; break; + case COMPAT_R_386_PLT32: *pP = value - P; break; + case COMPAT_R_386_GOTOFF: *pP = value - (Elf_Addr)oc->info->got_start; break; + case COMPAT_R_386_GOTPC: *pP = (Elf_Addr)oc->info->got_start + A - P; break; + case COMPAT_R_386_GOT32: + case COMPAT_R_386_GOT32X: + CHECK(symbol); + CHECK(symbol->got_addr); + *pP = (Elf_Addr)symbol->got_addr + - (Elf_Addr)oc->info->got_start + A; + break; # endif # if defined(arm_HOST_ARCH) ===================================== testsuite/tests/codeGen/should_run/T27072d.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE StaticPointers #-} +module T27072d where + +import GHC.StaticPtr + +f :: StaticPtr Int +f = static 1 + +g :: StaticPtr Int +g = static 2 ===================================== testsuite/tests/codeGen/should_run/T27072d.stdout ===================================== @@ -0,0 +1,2 @@ +SPT entries after init: 2 +SPT entries after finalizer: 0 ===================================== testsuite/tests/codeGen/should_run/T27072d_c.c ===================================== @@ -0,0 +1,38 @@ +// Test that GHC-generated module initializers and finalizer registrations +// work correctly on Darwin. +// +// On Darwin, GHC lowers finalizers as __cxa_atexit registrations from an +// initializer placed in __DATA,__mod_init_func (see Note [Finalizers via +// __cxa_atexit] in GHC.Types.ForeignStubs). +// +// This test verifies the mechanism by checking that: +// 1. The SPT initializer runs at load time (entries are inserted). +// 2. The SPT finalizer (registered via __cxa_atexit from __mod_init_func) +// fires during exit() and removes the entries. +// +// We verify (2) by registering our own __cxa_atexit checker from a +// constructor in a dylib that is loaded before the main executable's +// initializers run. Since __cxa_atexit handlers fire in LIFO order, +// a handler registered earlier runs later — so our checker runs after the +// GHC-generated finalizer, and can observe that SPT entries were removed. +// +// The Apple linker does not support --wrap, so this is the Darwin +// equivalent of T27072w's approach. + +#include "Rts.h" +#include <stdio.h> + +extern int hs_spt_key_count(void); + +int main(int argc, char *argv[]) { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + + printf("SPT entries after init: %d\n", hs_spt_key_count()); + fflush(stdout); + + // Do NOT call hs_exit(). Return normally so __cxa_atexit handlers fire, + // which includes the GHC-generated finalizer registered during init. + return 0; +} ===================================== testsuite/tests/codeGen/should_run/T27072d_check.c ===================================== @@ -0,0 +1,29 @@ +// Checker dylib for T27072d. +// +// Compiled as a dylib and linked against the test executable. Because dylib +// initializers run before the main executable's __mod_init_func entries, +// our __cxa_atexit registration happens first. Since __cxa_atexit handlers +// fire in LIFO order, our checker runs *after* the GHC-generated finalizer, +// allowing us to observe that SPT entries were removed. + +#include <stdio.h> + +// Provided by the RTS. +extern int hs_spt_key_count(void); + +static void check_spt_finalizer(void *arg __attribute__((unused))) { + int count = hs_spt_key_count(); + printf("SPT entries after finalizer: %d\n", count); + fflush(stdout); +} + +// Register the checker. This constructor runs during dylib initialization, +// which happens before the main executable's initializers. +__attribute__((constructor)) +static void register_spt_checker(void) { + // Use __cxa_atexit so we participate in the same LIFO chain as the + // GHC-generated finalizer. + extern int __cxa_atexit(void (*)(void *), void *, void *); + extern void *__dso_handle; + __cxa_atexit(check_spt_finalizer, (void *)0, &__dso_handle); +} ===================================== testsuite/tests/codeGen/should_run/T27072w.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE StaticPointers #-} +module T27072w where + +import GHC.StaticPtr + +f :: StaticPtr Int +f = static 1 + +g :: StaticPtr Int +g = static 2 ===================================== testsuite/tests/codeGen/should_run/T27072w.stdout ===================================== @@ -0,0 +1,3 @@ +SPT entries after init: 2 +finalizer: hs_spt_remove called +finalizer: hs_spt_remove called ===================================== testsuite/tests/codeGen/should_run/T27072w_c.c ===================================== @@ -0,0 +1,32 @@ +// Test that GHC-generated finalizers actually run on wasm32 +// +// We use --wrap=hs_spt_remove to intercept calls from the GHC-generated +// finalizer and verify they happen during exit(). + +#include "Rts.h" +#include <stdio.h> + +extern int hs_spt_key_count(void); + +// --wrap=hs_spt_remove: the linker redirects all calls to hs_spt_remove +// through our wrapper, and provides __real_hs_spt_remove for the original. +extern void __real_hs_spt_remove(StgWord64 key[2]); + +void __wrap_hs_spt_remove(StgWord64 key[2]) { + printf("finalizer: hs_spt_remove called\n"); + fflush(stdout); + __real_hs_spt_remove(key); +} + +int main(int argc, char *argv[]) { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + + printf("SPT entries after init: %d\n", hs_spt_key_count()); + fflush(stdout); + + // Do NOT call hs_exit(). Return normally so exit() fires the + // __cxa_atexit registered handlers. + return 0; +} ===================================== testsuite/tests/codeGen/should_run/all.T ===================================== @@ -260,3 +260,22 @@ test('T25364', normal, compile_and_run, ['']) test('T26061', normal, compile_and_run, ['']) test('T26537', normal, compile_and_run, ['-O2 -fregs-graph']) test('T24016', normal, compile_and_run, ['-O1 -fPIC']) + +# Check that GHC-generated finalizers run on Darwin. The Apple linker doesn't +# support --wrap, so we can't intercept hs_spt_remove directly. Instead we +# compile a small checker dylib (T27072d_check.c) whose constructor registers +# a __cxa_atexit handler *before* the executable's __mod_init_func entries run. +# LIFO ordering ensures the checker fires after the GHC-generated finalizer, +# so it can observe that SPT entries were removed. +# Requires dynamic way so the RTS is a dylib (avoids archive conflicts). +test('T27072d', [req_c, only_ways(['dyn']), when(not opsys('darwin'), skip), + pre_cmd('{compiler} -shared -no-hs-main' + ' -optl -undefined -optl dynamic_lookup' + ' -o T27072d_check.dylib T27072d_check.c')], + compile_and_run, + ['T27072d_c.c -no-hs-main' + ' -optl -Wl,-needed_library,T27072d_check.dylib -optl -rpath -optl .']) +# check that finalizers are being run, using --wrap to intercept hs_spt_remove. +# Skipped on Darwin (Apple linker doesn't support --wrap). +test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)], + compile_and_run, ['T27072w_c.c -no-hs-main -optl-Wl,--wrap=hs_spt_remove']) ===================================== testsuite/tests/rts/linker/T27072/Lib.c ===================================== @@ -0,0 +1,18 @@ +// Minimal module with an initializer and finalizer. +// The compiler places the function pointers in .init_array/.fini_array +// (ELF) or __mod_init_func/__mod_term_func (Mach-O). +// +// The counter lives in the main binary so it survives after this +// object is unloaded. + +extern int init_counter; + +__attribute__((constructor)) +static void lib_init(void) { + init_counter++; +} + +__attribute__((destructor)) +static void lib_fini(void) { + init_counter--; +} ===================================== testsuite/tests/rts/linker/T27072/Makefile ===================================== @@ -0,0 +1,21 @@ +.PHONY: clean_build_and_run build_and_run clean build + +clean_build_and_run: + $(MAKE) clean + $(MAKE) build_and_run + +build_and_run: build + ./main + +clean: + $(RM) Lib.o main.o main + +build: Lib.o main + +Lib.o: Lib.c + $(CC) -c -fPIC Lib.c -o Lib.o + +main: main.c + "$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \ + -no-hs-main -optc-Werror \ + main.c -o main ===================================== testsuite/tests/rts/linker/T27072/T27072.stdout ===================================== @@ -0,0 +1,3 @@ +counter before load: 0 +counter after load: 1 +counter after unload: 0 ===================================== testsuite/tests/rts/linker/T27072/all.T ===================================== @@ -0,0 +1,6 @@ +test('T27072', + [req_rts_linker, + js_skip, + extra_files(['Lib.c', 'main.c'])], + makefile_test, + ['clean_build_and_run']) ===================================== testsuite/tests/rts/linker/T27072/main.c ===================================== @@ -0,0 +1,57 @@ +// Test that the RTS linker executes .init_array entries on load and +// .fini_array entries on unload. The loaded module increments a +// counter in its initializer and decrements it in its finalizer. + +#include "Rts.h" +#include <stdio.h> + +#if defined(mingw32_HOST_OS) +#define PATH_STR(str) L##str +#else +#define PATH_STR(str) str +#endif + +int init_counter = 0; + +int main(int argc, char *argv[]) { + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &argv, conf); + + initLinker_(0); + insertSymbol(PATH_STR("main"), "init_counter", &init_counter); + + printf("counter before load: %d\n", init_counter); + fflush(stdout); + + int ok; + ok = loadObj(PATH_STR("Lib.o")); + if (!ok) { + errorBelch("loadObj(Lib.o) failed"); + return 1; + } + ok = resolveObjs(); + if (!ok) { + errorBelch("resolveObjs() failed"); + return 1; + } + + printf("counter after load: %d\n", init_counter); + fflush(stdout); + + ok = unloadObj(PATH_STR("Lib.o")); + if (!ok) { + errorBelch("unloadObj(Lib.o) failed"); + return 1; + } + + // GC triggers actual unloading and finalizer execution. + performMajorGC(); + performMajorGC(); + + printf("counter after unload: %d\n", init_counter); + fflush(stdout); + + hs_exit(); + return 0; +} ===================================== testsuite/tests/th/all.T ===================================== @@ -636,7 +636,6 @@ test('T25209', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('TH_MultilineStrings', normal, compile_and_run, ['']) test('T25252', [extra_files(['T25252B.hs', 'T25252_c.c']), - when(arch('i386'), expect_broken_for(25260,['ext-interp'])), req_th, req_c], compile_and_run, ['-fPIC T25252_c.c']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/76528cc323b6338a873fa68ef8c9a7… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/76528cc323b6338a873fa68ef8c9a7… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/T25262
by Teo Camarasu (＠teo) 21 Apr '26

21 Apr '26

Teo Camarasu deleted branch wip/T25262 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Deleted branch wip/T22095
by Teo Camarasu (＠teo) 21 Apr '26

21 Apr '26

Teo Camarasu deleted branch wip/T22095 at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org.

1 0