[Git][ghc/ghc][wip/unit-index] Abstract out parts of mkUnitState into a handler type
by Matthew Pickering (＠mpickering) 18 Feb '26
by Matthew Pickering (＠mpickering) 18 Feb '26
18 Feb '26
Matthew Pickering pushed to branch wip/unit-index at Glasgow Haskell Compiler / GHC
Commits:
64b3f6f3 by Torsten Schmits at 2026-02-18T16:00:26+00:00
Abstract out parts of mkUnitState into a handler type
- - - - -
24 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session/Inspect.hs
- compiler/GHC/Driver/Session/Units.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/GHCi/UI/Print.hs
- ghc/Main.hs
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -376,7 +376,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars )
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
+import GHC.Rename.Names (hscRenamePkgQual, hscRenameRawPkgQual)
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
import GHC.Tc.Types
@@ -663,7 +663,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do
let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
+ index <- hscUnitIndex <$> getSession
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
let upd hue =
@@ -747,6 +748,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
then do
-- additionally, set checked dflags so we don't lose fixes
old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
+ ue_index <- hscUnitIndex <$> getSession
home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
@@ -754,7 +756,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph old_unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
pure HomeUnitEnv
@@ -773,6 +775,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
, ue_current_unit = ue_currentUnit old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
, ue_eps = ue_eps old_unit_env
+ , ue_index
}
modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
else modifySession (hscSetFlags dflags0)
@@ -830,6 +833,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
, ue_current_unit = ue_currentUnit unit_env0
, ue_eps = ue_eps unit_env0
, ue_module_graph = ue_module_graph unit_env0
+ , ue_index = ue_index unit_env0
}
modifySession $ \h ->
-- hscSetFlags takes care of updating the logger as well.
@@ -878,7 +882,7 @@ setProgramHUG_ invalidate_needed new_hug0 = do
old_hpt = homeUnitEnv_hpt homeUnitEnv
home_units = HUG.allUnits (ue_home_unit_graph unit_env)
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags (ue_index unit_env) cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
pure HomeUnitEnv
@@ -1700,10 +1704,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d
parens (text (expectJust (ml_hs_file loc)))
renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
+renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
+renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
-- | Like 'findModule', but differs slightly when the module refers to
-- a source file, and the file has not been loaded via 'load'. In
@@ -1728,7 +1732,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return m
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
@@ -1778,7 +1783,8 @@ lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do
let dflags = hsc_dflags hsc_env
let sec = initSourceErrorContext dflags
let fopts = initFinderOpts dflags
- res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ query <- hscUnitIndexQuery hsc_env
+ res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
case res of
Found _ m -> return [m]
err -> throwOneError sec $ noModError hsc_env noSrcSpan mod_name err
=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -79,8 +79,10 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
, mg_loc = loc
, mg_rdr_env = rdr_env })
= do { hpt_rule_base <- home_pkg_rules
+ ; query <- hscUnitIndexQuery hsc_env
; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
uniq_tag = SimplTag
+ name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
name_ppr_ctx loc $
@@ -103,7 +105,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod
extra_vars = interactiveInScope (hsc_IC hsc_env)
home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod)
(GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot })
- name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
ptc = initPromotionTickContext dflags
-- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-- This is very convienent for the users of the monad (e.g. plugins do not have to
@@ -448,6 +449,7 @@ doCorePass pass guts = do
dflags <- getDynFlags
us <- getUniqueSupplyM
p_fam_env <- getPackageFamInstEnv
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let platform = targetPlatform dflags
let fam_envs = (p_fam_env, mg_fam_inst_env guts)
let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
@@ -461,6 +463,7 @@ doCorePass pass guts = do
mkNamePprCtx
(initPromotionTickContext dflags)
(hsc_unit_env hsc_env)
+ query
rdr_env
=====================================
compiler/GHC/Driver/Backpack.hs
=====================================
@@ -438,6 +438,7 @@ addUnit u = do
logger <- getLogger
let dflags0 = hsc_dflags hsc_env
let old_unit_env = hsc_unit_env hsc_env
+ ue_index = hscUnitIndex hsc_env
newdbs <- case ue_unit_dbs old_unit_env of
Nothing -> panic "addUnit: called too early"
Just dbs ->
@@ -446,7 +447,7 @@ addUnit u = do
, unitDatabaseUnits = [u]
}
in return (dbs ++ [newdb]) -- added at the end because ordering matters
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-- update platform constants
dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
@@ -462,6 +463,7 @@ addUnit u = do
(HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit))
, ue_eps = ue_eps old_unit_env
, ue_module_graph = ue_module_graph old_unit_env
+ , ue_index
}
setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
@@ -879,13 +881,15 @@ hsModuleToModSummary home_keys pn hsc_src modname
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file_ospath location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file_ospath location)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
implicit_prelude = xopt LangExt.ImplicitPrelude dflags
generated_imports = mkPrelImports modname implicit_prelude imps
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
convImport (L _ i) = (convImportLevel (ideclLevelSpec i), rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -275,7 +275,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
where
--
- mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))
+ mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, RawPkgQual, GenWithIsBoot (Located ModuleName))
-- A simple edge to a module from the same home unit
mkEdge (IIModule n) =
let
@@ -294,12 +294,12 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
let lvl = convImportLevel (ideclLevelSpec i)
wanted_mod = unLoc (ideclName i)
is_boot = ideclSource i
- mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)
+ raw_pkg = ideclPkgQual i
unitId = homeUnitId $ hsc_home_unit hsc_env
- in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)
+ in Right (unitId, lvl, raw_pkg, GWIB (noLoc wanted_mod) is_boot)
loopFromInteractive :: HscEnv
- -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]
+ -> [Either ModuleNodeEdge (UnitId, ImportLevel, RawPkgQual, GenWithIsBoot (Located ModuleName))]
-> M.Map NodeKey ModuleGraphNode
-> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)
loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)
@@ -308,12 +308,13 @@ loopFromInteractive hsc_env (edge:edges) cached_nodes =
Left edge -> do
(edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes
return (edge : edges, cached_nodes')
- Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do
+ Right (unitId, lvl, raw_pkg, GWIB wanted_mod is_boot) -> do
let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)
let k _ loc mod =
let key = moduleToMnk mod is_boot
in return $ FoundHome (ModuleNodeFixed key loc)
- found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []
+ pkg_qual <- hscRenameRawPkgQual hsc_env (unLoc wanted_mod) raw_pkg
+ found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod pkg_qual []
case found of
-- Case 1: Home modules have to already be in the cache.
FoundHome (ModuleNodeFixed mod _) -> do
@@ -1541,7 +1542,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
sec = initSourceErrorContext pi_local_dflags
mimps <- getImports popts sec imp_prelude pi_hspp_buf pi_hspp_fn src_fn
return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
- let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))
let pi_srcimps = pi_srcimps'
let pi_theimps = rn_imps pi_theimps'
=====================================
compiler/GHC/Driver/Env.hs
=====================================
@@ -9,6 +9,8 @@ module GHC.Driver.Env
, hsc_home_unit
, hsc_home_unit_maybe
, hsc_units
+ , hscUnitIndex
+ , hscUnitIndexQuery
, hsc_HPT
, hsc_HUE
, hsc_HUG
@@ -123,6 +125,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env
hsc_units :: HasDebugCallStack => HscEnv -> UnitState
hsc_units = ue_homeUnitState . hsc_unit_env
+hscUnitIndex :: HscEnv -> UnitIndex
+hscUnitIndex = ue_index . hsc_unit_env
+
+hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
+hscUnitIndexQuery hsc_env =
+ unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
+
hsc_HPT :: HscEnv -> HomePackageTable
hsc_HPT = ue_hpt . hsc_unit_env
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2733,9 +2733,10 @@ hscTidy hsc_env guts = do
$! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-- post tidy pretty-printing and linting...
+ query <- hscUnitIndexQuery hsc_env
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
ptc = initPromotionTickContext (hsc_dflags hsc_env)
endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -173,12 +173,13 @@ depanalE diag_wrapper msg excluded_mods allow_dup_roots = do
if isEmptyMessages errs
then do
hsc_env <- getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
let one_unit_messages get_mod_errs k hue = do
errs <- get_mod_errs
unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
- unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
+ unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
return $ errs `unionMessages` unused_home_mod_err
@@ -451,15 +452,15 @@ loadWithCache cache diag_wrapper how_much = do
-- actually loaded packages. All the packages, specified on command line,
-- but never loaded, are probably unused dependencies.
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
+warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
+warnUnusedPackages us query dflags mod_graph =
let diag_opts = initDiagOpts dflags
home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
-- Only need non-source imports here because SOURCE imports are always HPT
loadedPackages = concat $
- mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs)
+ mapMaybe (\(_st, fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
$ concatMap ms_imps home_mod_sum
used_args = Set.fromList (map unitId loadedPackages)
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -671,9 +671,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-- gather the imports and module name
(hspp_buf,mod_name,imps,src_imps) <- do
buf <- hGetStringBuffer input_fn
+ query <- hscUnitIndexQuery hsc_env
let imp_prelude = xopt LangExt.ImplicitPrelude dflags
popts = initParserOpts dflags
- rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
+ rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn))
sec = initSourceErrorContext dflags
eimps <- getImports popts sec imp_prelude buf input_fn (basename <.> suff)
=====================================
compiler/GHC/Driver/Session/Inspect.hs
=====================================
@@ -80,7 +80,8 @@ getInsts = withSession $ \hsc_env ->
getNamePprCtx :: GhcMonad m => m NamePprCtx
getNamePprCtx = withSession $ \hsc_env -> do
- return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
-- | Container for information about a 'Module'.
data ModuleInfo = ModuleInfo {
@@ -175,7 +176,8 @@ mkNamePprCtxForModule ::
ModuleInfo ->
m NamePprCtx
mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
ptc = initPromotionTickContext (hsc_dflags hsc_env)
return name_ppr_ctx
@@ -196,4 +198,3 @@ modInfoSafe = minf_safe
modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks
modInfoModBreaks = minf_modBreaks
-
=====================================
compiler/GHC/Driver/Session/Units.hs
=====================================
@@ -128,11 +128,12 @@ initMulti unitArgsFiles lintDynFlagsAndSrcs = do
(initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags
let home_units = HUG.allUnits initial_home_graph
+ let ue_index = hscUnitIndex hsc_env
home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
hue_flags = homeUnitEnv_dflags homeUnitEnv
dflags = homeUnitEnv_dflags homeUnitEnv
- (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
emptyHpt <- liftIO $ emptyHomePackageTable
@@ -244,4 +245,3 @@ createUnitEnvFromFlags unitDflags = do
let activeUnit = fst $ NE.head unitEnvList
return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)
-
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -145,7 +145,8 @@ deSugar hsc_env
= do { let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
ptc = initPromotionTickContext (hsc_dflags hsc_env)
- name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
+ ; query <- hscUnitIndexQuery hsc_env
+ ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
; withTiming logger
(text "Desugar"<+>brackets (ppr mod))
(const ()) $
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -87,6 +87,7 @@ import GHC.Data.FastString
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -284,7 +285,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-- in allocations by ~5% if we don't do this.
traverse (lookupCompleteMatch type_env hsc_env) =<<
localAndImportedCompleteMatches tcg_comp_env eps
- ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var statics_var
next_wrapper_num_var ds_complete_matches
}
@@ -336,6 +338,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; msg_var <- newIORef emptyMessages
; statics_var <- newIORef nilOL
; eps <- liftIO $ hscEPS hsc_env
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
; let unit_env = hsc_unit_env hsc_env
type_env = typeEnvFromEntities ids tycons patsyns fam_insts
ptc = initPromotionTickContext (hsc_dflags hsc_env)
@@ -345,7 +348,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
; ds_complete_matches <- traverse (lookupCompleteMatch type_env hsc_env) =<<
localAndImportedCompleteMatches local_complete_matches eps
; let
- envs = mkDsEnvs unit_env this_mod rdr_env type_env
+ envs = mkDsEnvs unit_env query this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var statics_var
next_wrapper_num ds_complete_matches
; runDs hsc_env envs thing_inside
@@ -384,13 +387,13 @@ initTcDsForSolver thing_inside
Just ret -> pure ret
Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (OrdList (Id,CoreExpr))
-> IORef (ModuleEnv Int) -> DsCompleteMatches
-> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
+mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
statics_var next_wrapper_num complete_matches
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
@@ -407,7 +410,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_fam_inst_env = fam_inst_env
, ds_gbl_rdr_env = rdr_env
, ds_if_env = (if_genv, if_lenv)
- , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
+ , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
, ds_msgs = msg_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -23,6 +23,7 @@ module GHC.Rename.Names (
getMinimalImports,
printMinimalImports,
renamePkgQual, renameRawPkgQual,
+ hscRenamePkgQual, hscRenameRawPkgQual,
classifyGREs,
ImportDeclUsage
) where
@@ -332,7 +333,8 @@ rnImportDecl this_mod
hsc_env <- getTopEnv
unit_env <- hsc_unit_env <$> getTopEnv
- let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
-- Check for self-import, which confuses the typechecker (#9032)
-- ghc --make rejects self-import cycles already, but batch-mode may not
@@ -442,14 +444,14 @@ rnImportDecl this_mod
-- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
+renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
+renameRawPkgQual unit_env query mn = \case
NoRawPkgQual -> NoPkgQual
- RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
+ RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
-- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
+renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
+renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
Nothing -> NoPkgQual
Just pkg_fs
| Just uid <- homeUnitId <$> ue_homeUnit unit_env
@@ -459,7 +461,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
| Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-> ThisPkg uid
- | Just uid <- resolvePackageImport unit_state mn (PackageName pkg_fs)
+ | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
-> OtherPkg uid
| otherwise
@@ -474,6 +476,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of
hpt_deps :: [UnitId]
hpt_deps = homeUnitDepends unit_state
+hscRenameRawPkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ RawPkgQual ->
+ m PkgQual
+hscRenameRawPkgQual hsc_env name raw = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
+
+hscRenamePkgQual ::
+ MonadIO m =>
+ HscEnv ->
+ ModuleName ->
+ Maybe FastString ->
+ m PkgQual
+hscRenamePkgQual hsc_env name package = do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
-- | Calculate the 'ImportAvails' induced by an import of a particular
-- interface, but without 'imp_mods'.
@@ -2557,4 +2578,3 @@ addDupDeclErr gres@(gre :| _)
checkConName :: RdrName -> TcRn ()
checkConName name
= checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name)
-
=====================================
compiler/GHC/Runtime/Context.hs
=====================================
@@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume )
import GHC.Unit
import GHC.Unit.Env
+import GHC.Unit.State (UnitIndexQuery)
import GHC.Core.FamInstEnv
import GHC.Core.InstEnv
@@ -397,8 +398,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt)
]
-- | Get the NamePprCtx function based on the flags and this InteractiveContext
-icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
-icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
+icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
+icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
where ptc = initPromotionTickContext (ic_dflags ictxt)
-- | extendInteractiveContext is called with new TyThings recently defined to update the
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -265,9 +265,11 @@ tcRnModuleTcRnM hsc_env mod_sum
; when (notNull prel_imports) $ do
addDiagnostic TcRnImplicitImportOfPrelude
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+
; -- TODO This is a little skeevy; maybe handle a bit more directly
let { simplifyImport (L _ idecl) =
- ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
+ ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
, reLoc $ ideclName idecl)
}
; raw_sig_imports <- liftIO
@@ -2122,19 +2124,21 @@ runTcInteractive hsc_env thing_inside
, let local_gres = filter isLocalGRE gres
, not (null local_gres) ]) ]
- ; let getOrphansForModuleName m mb_pkg = do
- iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg
+ ; let getOrphansForModuleName m pkg = do
+ iface <- loadSrcInterface (text "runTcInteractive") m NotBoot pkg
pure $ mi_module iface : dep_orphs (mi_deps iface)
getOrphansForModule m = do
iface <- loadModuleInterface (text "runTcInteractive") m
pure $ mi_module iface : dep_orphs (mi_deps iface)
+
; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
case i of -- force above: see #15111
IIModule n -> getOrphansForModule n
- IIDecl i -> getOrphansForModuleName (unLoc (ideclName i))
- (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
+ IIDecl i -> do
+ qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
+ getOrphansForModuleName (unLoc (ideclName i)) qual
; (home_insts, home_fam_insts) <- liftIO $ UnitEnv.hugAllInstances (hsc_unit_env hsc_env)
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -971,7 +971,8 @@ getNamePprCtx
= do { ptc <- initPromotionTickContext <$> getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
- ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
+ ; query <- liftIO $ hscUnitIndexQuery hsc_env
+ ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
=====================================
compiler/GHC/Types/Name/Ppr.hs
=====================================
@@ -69,15 +69,16 @@ with some holes, we should try to give the user some more useful information.
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics.
-mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
-mkNamePprCtx ptc unit_env env
+mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
+mkNamePprCtx ptc unit_env index env
= QueryQualify
(mkQualName env)
- (mkQualModule unit_state unit_env)
+ (mkQualModule unit_state index home_unit)
(mkQualPackage unit_state)
(mkPromTick ptc env)
where
unit_state = ue_homeUnitState unit_env
+ home_unit = ue_homeUnit unit_env
mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName
mkQualName env = qual_name where
@@ -215,12 +216,10 @@ Side note (int-index):
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
-mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule
-mkQualModule unit_state unitEnv mod
- -- Check whether the unit of the module is in the HomeUnitGraph.
- -- If it is, then we consider this 'mod' to be "local" and don't
- -- want to qualify it.
- | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False
+mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
+mkQualModule unit_state index mhome_unit mod
+ | Just home_unit <- mhome_unit
+ , isHomeModule home_unit mod = False
| [(_, pkgconfig)] <- lookup,
mkUnit pkgconfig == moduleUnit mod
@@ -229,7 +228,7 @@ mkQualModule unit_state unitEnv mod
= False
| otherwise = True
- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
+ where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
=====================================
compiler/GHC/Unit/Env.hs
=====================================
@@ -174,6 +174,8 @@ data UnitEnv = UnitEnv
, ue_namever :: !GhcNameVersion
-- ^ GHC name/version (used for dynamic library suffix)
+
+ , ue_index :: !UnitIndex
}
ueEPS :: UnitEnv -> IO ExternalPackageState
@@ -182,6 +184,7 @@ ueEPS = eucEPS . ue_eps
initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv cur_unit hug namever platform = do
eps <- initExternalUnitCache
+ ue_index <- newUnitIndex
return $ UnitEnv
{ ue_eps = eps
, ue_home_unit_graph = hug
@@ -189,6 +192,7 @@ initUnitEnv cur_unit hug namever platform = do
, ue_current_unit = cur_unit
, ue_platform = platform
, ue_namever = namever
+ , ue_index
}
updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -181,7 +181,8 @@ findImportedModule hsc_env mod pkg_qual =
dflags = hsc_dflags hsc_env
fopts = initFinderOpts dflags
in do
- findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
+ query <- hscUnitIndexQuery hsc_env
+ findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult
findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do
@@ -194,11 +195,12 @@ findImportedModuleNoHsc
:: FinderCache
-> FinderOpts
-> UnitEnv
+ -> UnitIndexQuery
-> Maybe HomeUnit
-> ModuleName
-> PkgQual
-> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
+findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
case mb_pkg of
NoPkgQual -> unqual_import
ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
@@ -220,7 +222,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- If the module is reexported, then look for it as if it was from the perspective
-- of that package which reexports it.
| Just real_mod_name <- lookupUniqMap (finder_reexportedModules opts) mod_name =
- findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
+ findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) real_mod_name NoPkgQual
| elementOfUniqSet mod_name (finder_hiddenModules opts) =
return (mkHomeHidden uid)
| otherwise =
@@ -231,11 +233,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- first before looking at the packages in order.
any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts)
- pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
+ pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
unqual_import = any_home_import
`orIfNotFound`
- findExposedPackageModule fc fopts units mod_name NoPkgQual
+ findExposedPackageModule fc fopts units query mod_name NoPkgQual
units = case mhome_unit of
Nothing -> ue_homeUnitState ue
@@ -248,20 +250,21 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-- plugin. This consults the same set of exposed packages as
-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
-- @-plugin-package@ are specified.
-findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name =
+findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
+findPluginModuleNoHsc fc fopts units query (Just home_unit) mod_name =
findHomeModule fc fopts home_unit mod_name
`orIfNotFound`
- findExposedPluginPackageModule fc fopts units mod_name
-findPluginModuleNoHsc fc fopts units Nothing mod_name =
- findExposedPluginPackageModule fc fopts units mod_name
+ findExposedPluginPackageModule fc fopts units query mod_name
+findPluginModuleNoHsc fc fopts units query Nothing mod_name =
+ findExposedPluginPackageModule fc fopts units query mod_name
findPluginModule :: HscEnv -> ModuleName -> IO FindResult
findPluginModule hsc_env mod_name = do
let fc = hsc_FC hsc_env
let units = hsc_units hsc_env
let mhome_unit = hsc_home_unit_maybe hsc_env
- findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name
+ query <- hscUnitIndexQuery hsc_env
+ findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units query mhome_unit mod_name
-- | A version of findExactModule which takes the exact parts of the HscEnv it needs
@@ -333,15 +336,15 @@ homeSearchCache fc home_unit mod_name do_this = do
let mod = mkModule home_unit mod_name
modLocationCache fc mod do_this
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
+findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
+findExposedPackageModule fc fopts units query mod_name mb_pkg =
findLookupResult fc fopts
- $ lookupModuleWithSuggestions units mod_name mb_pkg
+ $ lookupModuleWithSuggestions units query mod_name mb_pkg
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
+findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
+findExposedPluginPackageModule fc fopts units query mod_name =
findLookupResult fc fopts
- $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
+ $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
findLookupResult fc fopts r = case r of
=====================================
compiler/GHC/Unit/State.hs
=====================================
@@ -1,6 +1,6 @@
+{-# LANGUAGE LambdaCase, RecordWildCards #-}
-- (c) The University of Glasgow, 2006
-
-- | Unit manipulation
module GHC.Unit.State (
module GHC.Unit.Info,
@@ -48,6 +48,14 @@ module GHC.Unit.State (
closeUnitDeps',
mayThrowUnitErr,
+ UnitConfig (..),
+ UnitIndex (..),
+ UnitIndexQuery (..),
+ UnitVisibility (..),
+ VisibilityMap,
+ ModuleNameProvidersMap,
+ newUnitIndex,
+
-- * Module hole substitution
ShHoleSubst,
renameHoleUnit,
@@ -578,10 +586,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId)
-- | Find the UnitId which an import qualified by a package import comes from.
-- Compared to 'lookupPackageName', this function correctly accounts for visibility,
-- renaming and thinning.
-resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
-resolvePackageImport unit_st mn pn = do
+resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
+resolvePackageImport unit_st query mn pn = do
-- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
- providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
+ providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
-- 2. Get the UnitIds of the candidates
let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
-- 3. Get the package names of the candidates
@@ -639,14 +647,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state)
-- 'initUnits' can be called again subsequently after updating the
-- 'packageFlags' field of the 'DynFlags', and it will update the
-- 'unitState' in 'DynFlags'.
-initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
-initUnits logger dflags cached_dbs home_units = do
+initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
+initUnits logger dflags index cached_dbs home_units = do
let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
(unit_state,dbs) <- withTiming logger (text "initializing unit database")
forceUnitInfoMap
- $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
+ $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
@@ -1480,9 +1488,11 @@ validateDatabase cfg pkg_map1 =
mkUnitState
:: Logger
+ -> UnitId
-> UnitConfig
+ -> UnitIndex
-> IO (UnitState,[UnitDatabase UnitId])
-mkUnitState logger cfg = do
+mkUnitState logger unit cfg index = do
{-
Plan.
@@ -1538,15 +1548,9 @@ mkUnitState logger cfg = do
-- if databases have not been provided, read the database flags
raw_dbs <- case unitConfigDBCache cfg of
- Nothing -> readUnitDatabases logger cfg
+ Nothing -> readDatabases index logger unit cfg
Just dbs -> return dbs
- -- distrust all units if the flag is set
- let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
- dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
- | otherwise = raw_dbs
-
-
-- This, and the other reverse's that you will see, are due to the fact that
-- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
-- than they are on the command line.
@@ -1558,15 +1562,20 @@ mkUnitState logger cfg = do
let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
-- Merge databases together, without checking validity
- (pkg_map1, prec_map) <- mergeDatabases logger dbs
+ (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
-- Now that we've merged everything together, prune out unusable
-- packages.
- let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
+ let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
+ -- distrust all units if the flag is set
+ let distrust_all info = info {unitIsTrusted = False}
+ pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
+ | otherwise = initial_dbs
+
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- mayThrowUnitErr
@@ -1671,6 +1680,9 @@ mkUnitState logger cfg = do
-- likely to actually happen.
return (updateVisibilityMap wired_map plugin_vis_map2)
+ (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
+ computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
+
let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
| p <- pkgs2
]
@@ -1683,8 +1695,6 @@ mkUnitState logger cfg = do
req_ctx = mapUniqMap (Set.toList)
$ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
-
- --
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
-- packages. we link these packages in eagerly. The preload set
@@ -1707,10 +1717,6 @@ mkUnitState logger cfg = do
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
- let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
- mod_map2 = mkUnusableModuleNameProvidersMap unusable
- mod_map = mod_map2 `plusUniqMap` mod_map1
-
-- Force the result to avoid leaking input parameters
let !state = UnitState
{ preloadUnits = dep_preload
@@ -1718,8 +1724,8 @@ mkUnitState logger cfg = do
, homeUnitDepends = Set.toList home_unit_deps
, unitInfoMap = pkg_db
, preloadClosure = emptyUniqSet
- , moduleNameProvidersMap = mod_map
- , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+ , moduleNameProvidersMap
+ , pluginModuleNameProvidersMap
, packageNameMap = pkgname_map
, wireMap = wired_map
, unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
@@ -1892,6 +1898,76 @@ addListTo = foldl' merge
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
+-- -----------------------------------------------------------------------------
+-- Index
+
+data UnitIndexQuery =
+ UnitIndexQuery {
+ findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
+ moduleProviders :: UnitState -> ModuleNameProvidersMap
+ }
+
+data UnitIndex =
+ UnitIndex {
+ unitIndexQuery :: UnitId -> IO UnitIndexQuery,
+ readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
+ computeProviders ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+ }
+
+queryFindOriginDefault ::
+ UnitState ->
+ ModuleName ->
+ Bool ->
+ Maybe (UniqMap Module ModuleOrigin)
+queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
+ lookupUniqMap source name
+ where
+ source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
+
+newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
+newUnitIndexQuery _ =
+ pure UnitIndexQuery {
+ findOrigin = queryFindOriginDefault,
+ moduleProviders = moduleNameProvidersMap
+ }
+
+readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
+readDatabasesDefault logger _ cfg =
+ readUnitDatabases logger cfg
+
+computeProvidersDefault ::
+ Logger ->
+ UnitId ->
+ UnitConfig ->
+ VisibilityMap ->
+ VisibilityMap ->
+ UnitInfoMap ->
+ UnitInfoMap ->
+ ModuleNameProvidersMap ->
+ IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
+computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
+ pure (mod_map, plugin_mod_map)
+ where
+ mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
+ mod_map = unusable `plusUniqMap` mod_map1
+ plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
+
+newUnitIndex :: IO UnitIndex
+newUnitIndex =
+ pure UnitIndex {
+ unitIndexQuery = newUnitIndexQuery,
+ readDatabases = readDatabasesDefault,
+ computeProviders = computeProvidersDefault
+ }
-- -----------------------------------------------------------------------------
-- Package Utils
@@ -1899,10 +1975,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
-- | Takes a 'ModuleName', and if the module is in any package returns
-- list of modules which take that name.
lookupModuleInAllUnits :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> [(Module, UnitInfo)]
-lookupModuleInAllUnits pkgs m
- = case lookupModuleWithSuggestions pkgs m NoPkgQual of
+lookupModuleInAllUnits pkgs query m
+ = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
LookupFound a b -> [(a,fst b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust (lookupUnit pkgs (moduleUnit m)))
@@ -1928,18 +2005,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
+lookupModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name False
-- | The package which the module **appears** to come from, this could be
-- the one which reexports the module from it's original package. This function
-- is currently only used for -Wunused-packages
-lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
-lookupModulePackage pkgs mn mfs =
- case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
+lookupModulePackage ::
+ UnitState ->
+ UnitIndexQuery ->
+ ModuleName ->
+ PkgQual ->
+ Maybe [UnitInfo]
+lookupModulePackage pkgs query mn mfs =
+ case lookupModuleWithSuggestions' pkgs query mn False mfs of
LookupFound _ (orig_unit, origin) ->
case origin of
ModOrigin {fromOrigUnit, fromExposedReexport} ->
@@ -1955,19 +2038,21 @@ lookupModulePackage pkgs mn mfs =
_ -> Nothing
lookupPluginModuleWithSuggestions :: UnitState
+ -> UnitIndexQuery
-> ModuleName
-> PkgQual
-> LookupResult
-lookupPluginModuleWithSuggestions pkgs
- = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
+lookupPluginModuleWithSuggestions pkgs query name
+ = lookupModuleWithSuggestions' pkgs query name True
lookupModuleWithSuggestions' :: UnitState
- -> ModuleNameProvidersMap
+ -> UnitIndexQuery
-> ModuleName
+ -> Bool
-> PkgQual
-> LookupResult
-lookupModuleWithSuggestions' pkgs mod_map m mb_pn
- = case lookupUniqMap mod_map m of
+lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
+ = case findOrigin query pkgs m onlyPlugins of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
@@ -2028,16 +2113,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn
all_mods :: [(String, ModuleSuggestion)] -- All modules
all_mods = sortBy (comparing fst) $
[ (moduleNameString m, suggestion)
- | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
+ | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
, suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
]
getSuggestion name (mod, origin) =
(if originVisible origin then SuggestVisible else SuggestHidden)
name mod origin
-listVisibleModuleNames :: UnitState -> [ModuleName]
-listVisibleModuleNames state =
- map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
+listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
+listVisibleModuleNames unit_state query =
+ map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
where visible (_, ms) = anyUniqMap originVisible ms
-- | Takes a list of UnitIds (and their "parent" dependency, used for error
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -87,6 +87,7 @@ import qualified GHC.Parser.Header as Header
import GHC.Types.PkgQual
import GHC.Unit
+import GHC.Unit.State (UnitIndex)
import GHC.Unit.Finder as Finder
import GHC.Unit.Module.Graph (filterToposortToModules)
import GHC.Unit.Module.ModSummary
@@ -764,8 +765,9 @@ installInteractiveHomeUnits = do
S.insert interactiveSessionUnitId $
hsc_all_home_unit_ids hsc_env
- ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs
- ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs
+ let unit_index = hscUnitIndex hsc_env
+ ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt unit_index all_unit_ids cached_unit_dbs
+ ghciSessionUnit <- setupHomeUnitFor logger dflagsSession unit_index all_unit_ids cached_unit_dbs
let
-- Setup up the HUG, install the interactive home units
withInteractiveUnits =
@@ -787,10 +789,10 @@ installInteractiveHomeUnits = do
pure ()
where
- setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv
- setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do
+ setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> UnitIndex -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv
+ setupHomeUnitFor logger dflags index all_home_units cached_unit_dbs = do
(dbs,unit_state,home_unit,_mconstants) <-
- liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units
+ liftIO $ initUnits logger dflags index (Just cached_unit_dbs) all_home_units
hpt <- liftIO emptyHomePackageTable
pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit))
@@ -4087,19 +4089,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
completeModule = wrapIdentCompleterMod $ \w -> do
hsc_env <- GHC.getSession
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules
return $ filter (w `isPrefixOf`)
$ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
hsc_env <- GHC.getSession
+ query <- liftIO $ hscUnitIndexQuery hsc_env
modules <- case m of
Just '-' -> do
imports <- GHC.getContext
return $ map iiModuleName imports
_ -> do
- let pkg_mods = allVisibleModules (hsc_units hsc_env)
+ let pkg_mods = allVisibleModules (hsc_units hsc_env) query
loaded_mods <- liftM (map GHC.moduleNodeInfoModuleName) getLoadedModules
return $ loaded_mods ++ pkg_mods
return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
@@ -4167,8 +4171,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor
-- | Return a list of visible module names for autocompletion.
-- (NB: exposed != visible)
-allVisibleModules :: UnitState -> [ModuleName]
-allVisibleModules unit_state = listVisibleModuleNames unit_state
+allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
+allVisibleModules us query = listVisibleModuleNames us query
completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
completeIdentifier
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -365,7 +365,6 @@ unsetOption opt
= do st <- getGHCiState
setGHCiState (st{ options = filter (/= opt) (options st) })
-
-- | Run a single Haskell expression
runStmt
:: GhciMonad m
=====================================
ghc/GHCi/UI/Print.hs
=====================================
@@ -18,6 +18,7 @@ import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Errors
import GHC.Driver.Config.Diagnostic
+import GHC.Driver.Env (hsc_unit_env, hscUnitIndexQuery)
import GHC.Utils.Logger
import GHC.Utils.Error
@@ -45,10 +46,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do
where
mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
- withSession $ \ hsc_env ->
- let unit_env = hsc_unit_env hsc_env
- ptc = initPromotionTickContext dflags
- in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
+ withSession $ \ hsc_env -> do
+ query <- liftIO $ hscUnitIndexQuery hsc_env
+ let unit_env = hsc_unit_env hsc_env
+ ptc = initPromotionTickContext dflags
+ return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
printForUser :: GhcMonad m => SDoc -> m ()
printForUser doc = do
=====================================
ghc/Main.hs
=====================================
@@ -339,6 +339,7 @@ doMake units targets = do
ok_flag <- GHC.load LoadAllTargets
when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+
-- ---------------------------------------------------------------------------
-- Various banners and verbosity output.
@@ -524,4 +525,3 @@ abiHash strs = do
f <- fingerprintBinMem bh
putStrLn (showPpr dflags f)
-
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b3f6f358ce0fc9ee8428cb8739c9f…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b3f6f358ce0fc9ee8428cb8739c9f…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
18 Feb '26
Matthew Pickering pushed new branch wip/unit-index at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/unit-index
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] 3 commits: Add bytecode linkable regression test
by Hannes Siebenhandl (＠fendor) 18 Feb '26
by Hannes Siebenhandl (＠fendor) 18 Feb '26
18 Feb '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
09531201 by fendor at 2026-02-18T14:24:53+01:00
Add bytecode linkable regression test
- - - - -
e74f4f1a by fendor at 2026-02-18T14:24:54+01:00
WIP: LinkableUsage
- - - - -
fbe69319 by fendor at 2026-02-18T16:51:06+01:00
WIP: debug memory usage
- - - - -
26 changed files:
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Utils/Binary.hs
- ghc/GHCi/Leak.hs
- + testsuite/ghc-config/ghc-config
- + testsuite/tests/bytecode/TLinkable/Makefile
- + testsuite/tests/bytecode/TLinkable/all.T
- + testsuite/tests/bytecode/TLinkable/genSplices
- + testsuite/tests/bytecode/TLinkable/genSplices2
- + testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -14,6 +14,7 @@ module GHC.ByteCode.Serialize
, InterpreterLibraryContents(..)
, writeBytecodeLib
, readBytecodeLib
+ , fingerprintModuleByteCodeContents
, decodeOnDiskModuleByteCode
, decodeOnDiskBytecodeLib
)
@@ -48,6 +49,7 @@ import GHC.Utils.Logger
import GHC.Linker.Types
import System.IO.Unsafe (unsafeInterleaveIO)
import GHC.Utils.Outputable
+import GHC.Utils.Fingerprint (Fingerprint, fingerprintByteString)
{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -94,6 +96,7 @@ See Note [Recompilation avoidance with bytecode objects]
-- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
-- temporary files.
data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module
+ , odgbc_hash :: Fingerprint
, odgbc_compiled_byte_code :: CompiledByteCode
, odgbc_foreign :: [ByteString] -- ^ Contents of object files
}
@@ -154,7 +157,6 @@ instance Binary OnDiskBytecodeLib where
put_ bh bytecodeLibForeign
-
writeBytecodeLib :: BytecodeLib -> FilePath -> IO ()
writeBytecodeLib lib path = do
odbco <- encodeBytecodeLib lib
@@ -174,12 +176,14 @@ readBytecodeLib hsc_env path = do
instance Binary OnDiskModuleByteCode where
get bh = do
odgbc_module <- get bh
+ odgbc_hash <- get bh
odgbc_compiled_byte_code <- get bh
odgbc_foreign <- get bh
pure OnDiskModuleByteCode {..}
put_ bh OnDiskModuleByteCode {..} = do
put_ bh odgbc_module
+ put_ bh odgbc_hash
put_ bh odgbc_compiled_byte_code
put_ bh odgbc_foreign
@@ -197,7 +201,8 @@ decodeOnDiskModuleByteCode hsc_env odbco = do
pure $ ModuleByteCode {
gbc_module = odgbc_module odbco,
gbc_compiled_byte_code = odgbc_compiled_byte_code odbco,
- gbc_foreign_files = foreign_files
+ gbc_foreign_files = foreign_files,
+ gbc_hash = odgbc_hash odbco
}
decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib
@@ -256,7 +261,8 @@ encodeOnDiskModuleByteCode bco = do
pure $ OnDiskModuleByteCode {
odgbc_module = gbc_module bco,
odgbc_compiled_byte_code = gbc_compiled_byte_code bco,
- odgbc_foreign = foreign_contents
+ odgbc_foreign = foreign_contents,
+ odgbc_hash = gbc_hash bco
}
-- | Read a 'ModuleByteCode' from a file.
@@ -281,6 +287,15 @@ writeBinByteCode f cbc = do
putWithUserData QuietBinIFace NormalCompression bh odbco
writeBinMem bh f
+fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint
+fingerprintModuleByteCodeContents modl cbc foreign_files = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addBinNameWriter bh'
+ foreign_contents <- readObjectFiles foreign_files
+ putWithUserData QuietBinIFace NormalCompression bh
+ (modl, cbc, foreign_contents)
+ withBinBuffer bh (pure . fingerprintByteString)
+
instance Binary CompiledByteCode where
get bh = do
bc_bcos <- get bh
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -137,7 +137,7 @@ data Hooks = Hooks
, tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
, hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult))
- , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)))
+ , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)))
, ghcPrimIfaceHook :: !(Maybe ModIface)
, runPhaseHook :: !(Maybe PhaseHook)
, runMetaHook :: !(Maybe (MetaHook TcM))
@@ -145,7 +145,7 @@ data Hooks = Hooks
-> HomePackageTable -> IO SuccessFlag))
, runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn)))
, getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type
- -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))
+ -> IO (Either Type (HValue, [LinkableWithUsage], PkgsLoaded))))
, createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
, stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -866,7 +866,7 @@ hscRecompStatus
| otherwise -> do
-- Check the status of all the linkable types we might need.
-- 1. The in-memory linkable we had at hand.
- bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable)
+ bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable)
-- 2. The bytecode object file
bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary
-- 3. Bytecode from an interface's whole core bindings.
@@ -1098,7 +1098,7 @@ loadIfaceByteCodeLazy ::
ModIface ->
ModLocation ->
TypeEnv ->
- IO (Maybe Linkable)
+ IO (Maybe (LinkableWith ModuleByteCode))
loadIfaceByteCodeLazy hsc_env iface location type_env =
case iface_core_bindings iface location of
Nothing -> return Nothing
@@ -1106,8 +1106,9 @@ loadIfaceByteCodeLazy hsc_env iface location type_env =
Just <$> compile wcb
where
compile decls = do
- bco <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls
- linkable $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env decls
+ linkable bco
linkable parts = do
if_time <- modificationTimeIfExists (ml_hi_file_ospath location)
@@ -1148,14 +1149,14 @@ initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
where
type_env = md_types details
- go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
+ go :: RecompBytecodeLinkable -> IO (Maybe (LinkableWith ModuleByteCode))
go (NormalLinkable l) = pure l
go (WholeCoreBindingsLinkable wcbl) =
fmap Just $ for wcbl $ \wcb -> do
add_iface_to_hpt iface details hsc_env
- bco <- unsafeInterleaveIO $
- compileWholeCoreBindings hsc_env type_env wcb
- pure $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env wcb
+ pure bco
-- | Hydrate interface Core bindings and compile them to bytecode.
--
@@ -2232,20 +2233,21 @@ make user's opt into writing the files.
-}
-- | Generate a 'ModuleByteCode' and write it to disk if `-fwrite-byte-code` is enabled.
-generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Linkable
+generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO (LinkableWith ModuleByteCode)
generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do
bco_object <- generateAndWriteByteCode hsc_env cgguts mod_location
-- Either, get the same time as the .gbc file if it exists, or just the current time.
-- It's important the time of the linkable matches the time of the .gbc file for recompilation
-- checking.
bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file_ospath mod_location)
- return $ mkModuleByteCodeLinkable bco_time bco_object
+ return $ mkOnlyModuleByteCodeLinkable bco_time bco_object
mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode
mkModuleByteCode hsc_env mod mod_location cgguts = do
bcos <- hscGenerateByteCode hsc_env cgguts mod_location
objs <- outputAndCompileForeign hsc_env mod mod_location (cgi_foreign_files cgguts) (cgi_foreign cgguts)
- return $! ModuleByteCode mod bcos objs
+ !bcos_hash <- fingerprintModuleByteCodeContents mod bcos objs
+ return $! ModuleByteCode mod bcos objs bcos_hash
-- | Generate a fresh 'ModuleByteCode' for a given module but do not write it to disk.
generateFreshByteCodeLinkable :: HscEnv
@@ -2767,13 +2769,13 @@ hscTidy hsc_env guts = do
%* *
%********************************************************************* -}
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
hscCompileCoreExpr hsc_env loc expr =
case hscCompileCoreExprHook (hsc_hooks hsc_env) of
Nothing -> hscCompileCoreExpr' hsc_env loc expr
Just h -> h hsc_env loc expr
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Simplify it -}
-- Question: should we call SimpleOpt.simpleOptExpr here instead?
@@ -2859,8 +2861,10 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- load it -}
bco_time <- getCurrentTime
+ !bco_hash <- fingerprintModuleByteCodeContents this_mod bcos []
+ let mbc = ModuleByteCode this_mod bcos [] bco_hash
(mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $
- Linkable bco_time this_mod $ NE.singleton $ DotGBC (ModuleByteCode this_mod bcos [])
+ Linkable bco_time this_mod $ NE.singleton (DotGBC mbc)
-- Get the foreign reference to the name we should have just loaded.
mhvs <- lookupFromLoadedEnv interp (idName binding_id)
{- Get the HValue for the root -}
@@ -2876,7 +2880,7 @@ jsCodeGen
-> Module
-> [(CgStgTopBinding,IdSet)]
-> Id
- -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+ -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
let logger = hsc_logger hsc_env
tmpfs = hsc_tmpfs hsc_env
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -430,7 +430,7 @@ link' hsc_env batch_attempt_linking mHscMessager hpt
let obj_files = concatMap linkableObjs linkables
in action obj_files
linkBytecodeLinkable action =
- checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeMod_bytecode $ \linkables ->
+ checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeModLinkableByteCode $ \linkables ->
let bytecode = concatMap linkableModuleByteCodes linkables
in action bytecode
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -342,7 +342,7 @@ data Plugins = Plugins
-- The purpose of this field is to cache the plugins so they
-- don't have to be loaded each time they are needed. See
-- 'GHC.Runtime.Loader.initializePlugins'.
- , loadedPluginDeps :: !([Linkable], PkgsLoaded)
+ , loadedPluginDeps :: !([LinkableWithUsage], PkgsLoaded)
-- ^ The object files required by the loaded plugins
-- See Note [Plugin dependencies]
}
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -7,8 +7,6 @@ module GHC.HsToCore.Usage (
import GHC.Prelude
-import GHC.Driver.Env
-
import GHC.Tc.Types
import GHC.Iface.Load
@@ -27,7 +25,6 @@ import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Unit.Env
-import GHC.Unit.External
import GHC.Unit.Module.Imported
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
@@ -35,18 +32,17 @@ import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import GHC.Data.FastString
-import Data.IORef
import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.List.NonEmpty as NE
import GHC.Linker.Types
import GHC.Unit.Finder
import GHC.Types.Unique.DFM
import GHC.Driver.Plugins
import qualified GHC.Unit.Home.Graph as HUG
+import qualified Data.List.NonEmpty as NE
{- Note [Module self-dependency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -75,19 +71,17 @@ data UsageConfig = UsageConfig
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv
-> Module -> ImportedMods -> [ImportUserSpec] -> NameSet
- -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
+ -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [LinkableWithUsage] -> PkgsLoaded
-> IfG [Usage]
mkUsageInfo uc plugins fc unit_env
this_mod dir_imp_mods imp_decls used_names
dependent_files dependent_dirs merged needed_links needed_pkgs
= do
- eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))
file_hashes <- liftIO $ mapM getFileHash dependent_files
dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
let hu = ue_unsafeHomeUnit unit_env
- hug = ue_home_unit_graph unit_env
-- Dependencies on object files due to TH and plugins
- object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs
+ object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod
dir_imp_mods imp_decls used_names
@@ -190,31 +184,31 @@ for a module or not. This is similar to how the recompilation checking for the l
-- | Find object files corresponding to the transitive closure of given home
-- modules and direct object files for pkg dependencies
-mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]
-mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
- let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed)
+mkObjectUsage :: Plugins -> FinderCache -> [LinkableWithUsage] -> PkgsLoaded -> IO [Usage]
+mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do
+ let ls = th_links_needed ++ plugins_links_needed
ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well
(plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
where
- linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)
-
- msg m = moduleNameString (moduleName m) ++ "[TH] changed"
+ linkableToUsage :: LinkableWithUsage -> IO [Usage]
+ linkableToUsage (Linkable _ _m parts) = traverse partToUsage (NE.toList parts)
+
+ partToUsage link_usage =
+ case link_usage of
+ FileLinkableUsage{flu_file, flu_message} -> do
+ fing flu_message flu_file
+
+ ByteCodeLinkableUsage{bclu_module, bclu_hash} ->
+ pure $
+ UsageHomeModuleBytecode
+ { usg_mod_name = moduleName bclu_module
+ , usg_unit_id = toUnitId $ moduleUnit bclu_module
+ , usg_bytecode_hash = bclu_hash
+ }
fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
- partToUsage m part =
- case linkablePartPath part of
- Just fn -> fing (Just (msg m)) fn
- Nothing -> do
- -- This should only happen for home package things but oneshot puts
- -- home package ifaces in the PIT.
- miface <- lookupIfaceByModule hug pit m
- case miface of
- Nothing -> pprPanic "linkableToUsage" (ppr m)
- Just iface ->
- return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface)
-
librarySpecToUsage :: LibrarySpec -> IO [Usage]
librarySpecToUsage (Objects os) = traverse (fing Nothing) os
librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn]
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -88,6 +88,10 @@ import GHC.Iface.Errors.Ppr
import Data.Functor
import Data.Bifunctor (first)
import GHC.Types.PkgQual
+import GHC.ByteCode.Serialize (ModuleByteCode, gbc_hash)
+import GHC.Unit.Home.Graph (lookupHugByModule)
+import GHC.Unit.Home.ModInfo (HomeModLinkable(..), HomeModInfo (..))
+import GHC.Linker.Types (linkableParts)
{-
-----------------------------------------------
@@ -190,6 +194,7 @@ data RecompReason
| ModuleAdded (ImportLevel, UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
+ | ModuleChangedBytecode ModuleName
| FileChanged FilePath
| DirChanged FilePath
| CustomReason String
@@ -224,7 +229,8 @@ instance Outputable RecompReason where
SigsMergeChanged -> text "Signatures to merge in changed"
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
- ModuleChangedIface m -> ppr m <+> text "changed (interface)"
+ ModuleChangedIface m -> ppr m <+> text "changed (bytecode)"
+ ModuleChangedBytecode m -> ppr m <+> text "changed (interface)"
ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
@@ -718,6 +724,15 @@ needInterface mod continue
Nothing -> return $ NeedsRecompile MustCompile
Just iface -> liftIO $ continue iface
+needBytecode :: Module -> (ModuleByteCode -> IO RecompileRequired)
+ -> IfG RecompileRequired
+needBytecode mod continue
+ = do
+ mb_recomp <- tryGetBytecode mod
+ case mb_recomp of
+ Nothing -> return $ NeedsRecompile MustCompile
+ Just mbc -> liftIO $ continue mbc
+
tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface doc_msg mod
= do -- Load the imported interface if possible
@@ -739,6 +754,27 @@ tryGetModIface doc_msg mod
-- import and it's been deleted
Succeeded iface -> pure $ Just iface
+tryGetBytecode :: Module -> IfG (Maybe ModuleByteCode)
+tryGetBytecode mod
+ = do -- Load the imported bytecode if possible
+ logger <- getLogger
+ liftIO $ trace_hi_diffs logger (text "Checking bytecode hash for module" <+> ppr mod <+> ppr (moduleUnit mod))
+
+ mb_module_bytecode <- do
+ env <- getTopEnv
+ liftIO (lookupHugByModule mod (hsc_HUG env)) >>= \ case
+ Nothing -> pure Nothing
+ Just hmi ->
+ case homeMod_bytecode (hm_linkable hmi) of
+ Nothing -> pure Nothing
+ Just gbc_linkable -> pure $ Just $ linkableParts gbc_linkable
+
+ case mb_module_bytecode of
+ Nothing -> do
+ liftIO $ trace_hi_diffs logger (sep [text "Couldn't find bytecode for module", ppr mod])
+ return Nothing
+ Just module_bytecode -> pure $ Just module_bytecode
+
-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
@@ -760,14 +796,14 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha
needInterface mod $ \iface -> do
let reason = ModuleChangedRaw (moduleName mod)
checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)
-checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name
+checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name
, usg_unit_id = uid
- , usg_iface_hash = old_mod_hash } = do
+ , usg_bytecode_hash = old_bytecode_hash } = do
let mod = mkModule (RealUnit (Definite uid)) mod_name
logger <- getLogger
- needInterface mod $ \iface -> do
- let reason = ModuleChangedIface mod_name
- checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface)
+ needBytecode mod $ \cbc -> do
+ let reason = ModuleChangedBytecode mod_name
+ checkBytecodeFingerprint logger reason old_bytecode_hash (gbc_hash cbc)
checkModUsage _ UsageHomeModule{
usg_mod_name = mod_name,
@@ -1032,19 +1068,18 @@ checkModuleFingerprint logger reason old_mod_hash new_mod_hash
= out_of_date_hash logger reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
-checkIfaceFingerprint
+checkBytecodeFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
-checkIfaceFingerprint logger reason old_mod_hash new_mod_hash
- | new_mod_hash == old_mod_hash
- = up_to_date logger (text "Iface fingerprint unchanged")
-
+checkBytecodeFingerprint logger reason old_bytecode_hash new_bytecode_hash
+ | old_bytecode_hash == new_bytecode_hash
+ = up_to_date logger (text "Bytecode fingerprint unchanged")
| otherwise
- = out_of_date_hash logger reason (text " Iface fingerprint has changed")
- old_mod_hash new_mod_hash
+ = out_of_date_hash logger reason (text " Bytecode fingerprint has changed")
+ old_bytecode_hash new_bytecode_hash
------------------------
checkEntityUsage :: Logger
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -146,10 +146,10 @@ pprUsage usage@UsageDirectory{}
ppr (usg_dir_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
-pprUsage usage@UsageHomeModuleInterface{}
- = hsep [text "implementation", ppr (usg_mod_name usage)
+pprUsage usage@UsageHomeModuleBytecode{}
+ = hsep [text "Bytecode", ppr (usg_mod_name usage)
, ppr (usg_unit_id usage)
- , ppr (usg_iface_hash usage)]
+ , ppr (usg_bytecode_hash usage)]
pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc
pprUsageImport mod hash safe
@@ -157,4 +157,4 @@ pprUsageImport mod hash safe
, ppr hash ]
where
pp_safe | safe = text "safe"
- | otherwise = text " -/ "
\ No newline at end of file
+ | otherwise = text " -/ "
=====================================
compiler/GHC/Linker/ByteCode.hs
=====================================
@@ -31,7 +31,7 @@ linkBytecodeLib hsc_env gbcs = do
on_disk_bcos <- mapM (readBinByteCode hsc_env) bytecodeObjects
- let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs <- on_disk_bcos ++ gbcs]
+ let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs _hash <- on_disk_bcos ++ gbcs]
interpreter_foreign_lib <- mkInterpreterLib hsc_env (concat foreign_stubs ++ objectFiles)
@@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files =
return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name)
Nothing -> pure Nothing
False -> do
- pure $ Just (InterpreterStaticObjects files)
\ No newline at end of file
+ pure $ Just (InterpreterStaticObjects files)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -63,7 +63,7 @@ data LinkDepsOpts = LinkDepsOpts
data LinkDeps = LinkDeps
{ ldNeededLinkables :: [Linkable]
- , ldAllLinkables :: [Linkable]
+ , ldAllLinkables :: [LinkableWithUsage]
, ldUnits :: [UnitId]
, ldNeededUnits :: UniqDSet UnitId
}
@@ -126,7 +126,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
return $ LinkDeps
{ ldNeededLinkables = lnks_needed
- , ldAllLinkables = links_got ++ lnks_needed
+ , ldAllLinkables = links_got ++ mkLinkablesUsage lnks_needed
, ldUnits = pkgs_needed
, ldNeededUnits = pkgs_s
}
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -135,6 +135,7 @@ import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import Foreign.Ptr (nullPtr)
import GHC.ByteCode.Serialize
+import Control.DeepSeq (force)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -228,7 +229,7 @@ lookupFromLoadedEnv interp name = do
-- | Load the module containing the given Name and get its associated 'HValue'.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
loadName interp hsc_env name = do
initLoaderState interp hsc_env
modifyLoaderState interp $ \pls0 -> do
@@ -258,7 +259,7 @@ loadDependencies
-> LoaderState
-> SrcSpan
-> [Module]
- -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
+ -> IO (LoaderState, SuccessFlag, [LinkableWithUsage], PkgsLoaded) -- ^ returns the set of linkables required
-- When called, the loader state must have been initialized (see `initLoaderState`)
loadDependencies interp hsc_env pls span needed_mods = do
let opts = initLinkDepsOpts hsc_env
@@ -667,6 +668,7 @@ findBytecodeLinkableMaybe hsc_env mod locn = do
case maybe_bytecode_time of
Nothing -> return Nothing
Just bytecode_time -> do
+ -- TODO: @fendor This must go
-- Also load the interface, for reasons to do with recompilation avoidance.
-- See Note [Recompilation avoidance with bytecode objects]
_ <- initIfaceLoad hsc_env $
@@ -723,7 +725,7 @@ get_reachable_nodes hsc_env mods
********************************************************************* -}
-- | Load the dependencies of a linkable, and then load the linkable itself.
-loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([Linkable], PkgsLoaded)
+loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([LinkableWithUsage], PkgsLoaded)
loadDecls interp hsc_env span linkable = do
-- Initialise the linker (if it's not been done already)
initLoaderState interp hsc_env
@@ -823,7 +825,7 @@ loadModuleLinkables interp hsc_env pls keep_spec linkables
(objs, bcos) = partitionLinkables linkables
-linkableInSet :: Linkable -> LinkableSet -> Bool
+linkableInSet :: Linkable -> LinkableSet LinkableWithUsage -> Bool
linkableInSet l objs_loaded =
case lookupModuleEnv objs_loaded (linkableModule l) of
Nothing -> False
@@ -952,17 +954,17 @@ dynLoadObjs interp hsc_env pls objs = do
then addWay WayProf
else id
-rmDupLinkables :: LinkableSet -- Already loaded
+rmDupLinkables :: LinkableSet LinkableWithUsage -- Already loaded
-> [Linkable] -- New linkables
- -> (LinkableSet, -- New loaded set (including new ones)
+ -> (LinkableSet LinkableWithUsage, -- New loaded set (including new ones)
[Linkable]) -- New linkables (excluding dups)
rmDupLinkables already ls
= go already [] ls
where
- go already extras [] = (already, extras)
- go already extras (l:ls)
+ go !already extras [] = (already, extras)
+ go !already extras (l:ls)
| linkableInSet l already = go already extras ls
- | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls
+ | otherwise = go (extendModuleEnv already (linkableModule l) $! force $ mkLinkableUsage l) (l:extras) ls
{- **********************************************************************
@@ -974,7 +976,7 @@ rmDupLinkables already ls
dynLinkBCOs :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [Linkable] -> IO LoaderState
dynLinkBCOs interp pls keep_spec bcos =
- let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+ let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos -- TODO: @fendor, convert to linkable usage here?
pls1 = pls { bcos_loaded = bcos_loaded' }
cbcs :: [CompiledByteCode]
@@ -1109,13 +1111,13 @@ unload_wkr interp pls@LoaderState{..} = do
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
- let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded
+ let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded -- TODO: @fendor LinkableUsage here already?
mapM_ unloadObjs linkables_to_unload
-- If we unloaded any object files at all, we need to purge the cache
-- of lookupSymbol results.
- when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $
+ when (not (null (filter (not . null . linkableUsageObjs) linkables_to_unload))) $
purgeLookupSymbolCache interp
let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState,
@@ -1125,7 +1127,7 @@ unload_wkr interp pls@LoaderState{..} = do
return new_pls
where
- unloadObjs :: Linkable -> IO ()
+ unloadObjs :: LinkableWithUsage -> IO ()
unloadObjs lnk
| interpreterDynamic interp = return ()
-- We don't do any cleanup when linking objects with the
@@ -1133,7 +1135,7 @@ unload_wkr interp pls@LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) (linkableObjs lnk)
+ = mapM_ (unloadObj interp) (linkableUsageObjs lnk)
-- The components of a BCO linkable may contain
-- dot-o files (generated from C stubs).
--
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -49,6 +49,7 @@ module GHC.Linker.Types
, WholeCoreBindingsLinkable
, LinkableWith(..)
, mkModuleByteCodeLinkable
+ , mkOnlyModuleByteCodeLinkable
, LinkablePart(..)
, LinkableObjectSort (..)
, linkableIsNativeCodeOnly
@@ -67,12 +68,17 @@ module GHC.Linker.Types
, linkableFilterNative
, partitionLinkables
+ , LinkableWithUsage
+ , linkableUsageObjs
+ , mkLinkablesUsage
+ , mkLinkableUsage
+
, ModuleByteCode(..)
)
where
import GHC.Prelude
-import GHC.Unit ( UnitId, Module )
+import GHC.Unit ( UnitId, Module, moduleNameString, moduleName )
import GHC.ByteCode.Types
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -97,6 +103,11 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
import Control.Applicative ((<|>))
import Data.Functor.Identity
+import GHC.Unit.Module.Deps (LinkableUsage (..), linkableUsageObjectPaths)
+import GHC.Fingerprint (Fingerprint)
+import qualified GHC.Data.OsPath as OsPath
+import qualified GHC.Data.FlatBag as FlatBag
+import Control.DeepSeq (NFData(..))
{- **********************************************************************
@@ -172,10 +183,10 @@ data LoaderState = LoaderState
-- ^ Information about bytecode objects we have loaded into the
-- interpreter.
- , bcos_loaded :: !LinkableSet
+ , bcos_loaded :: !(LinkableSet LinkableWithUsage)
-- ^ The currently loaded interpreted modules (home package)
- , objs_loaded :: !LinkableSet
+ , objs_loaded :: !(LinkableSet LinkableWithUsage)
-- ^ And the currently-loaded compiled modules (home package)
, pkgs_loaded :: !PkgsLoaded
@@ -380,19 +391,25 @@ data LinkableWith parts = Linkable
-- ^ Files and chunks of code to link.
} deriving (Functor, Traversable, Foldable)
+instance NFData a => NFData (LinkableWith a) where
+ rnf Linkable{linkableTime,linkableModule,linkableParts} =
+ rnf linkableTime `seq` rnf linkableModule `seq` rnf linkableParts `seq` ()
+
type Linkable = LinkableWith (NonEmpty LinkablePart)
type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
-type LinkableSet = ModuleEnv Linkable
+type LinkableWithUsage = LinkableWith (NonEmpty LinkableUsage)
+
+type LinkableSet = ModuleEnv
-mkLinkableSet :: [Linkable] -> LinkableSet
+mkLinkableSet :: [Linkable] -> LinkableSet Linkable
mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]
-- | Union of LinkableSets.
--
-- In case of conflict, keep the most recent Linkable (as per linkableTime)
-unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
+unionLinkableSet :: LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a)
unionLinkableSet = plusModuleEnv_C go
where
go l1 l2
@@ -435,8 +452,9 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | DotGBC ModuleByteCode
- -- ^ A byte-code object, lives only in memory.
+ | DotGBC
+ -- ^ A byte-code object, lives only in memory.
+ ModuleByteCode
-- | The in-memory representation of a bytecode object
@@ -444,14 +462,19 @@ data LinkablePart
data ModuleByteCode = ModuleByteCode { gbc_module :: Module
, gbc_compiled_byte_code :: CompiledByteCode
, gbc_foreign_files :: [FilePath] -- ^ Path to object files
+ , gbc_hash :: !Fingerprint
}
mkModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> Linkable
-mkModuleByteCodeLinkable linkable_time bco =
+mkModuleByteCodeLinkable linkable_time bco = do
Linkable linkable_time (gbc_module bco) (pure (DotGBC bco))
+mkOnlyModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> LinkableWith ModuleByteCode
+mkOnlyModuleByteCodeLinkable linkable_time bco = do
+ Linkable linkable_time (gbc_module bco) bco
+
instance Outputable ModuleByteCode where
- ppr (ModuleByteCode mod _cbc _fos) = text "ModuleByteCode" <+> ppr mod
+ ppr (ModuleByteCode mod _cbc _fos _) = text "ModuleByteCode" <+> ppr mod
instance Outputable LinkablePart where
ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort
@@ -544,8 +567,8 @@ linkablePartObjectPaths = \case
-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
linkablePartBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartBCOs = \case
- DotGBC bco -> [gbc_compiled_byte_code bco]
- _ -> []
+ DotGBC bco -> [gbc_compiled_byte_code bco]
+ _ -> []
linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter f linkable = do
@@ -586,6 +609,48 @@ partitionLinkables linkables =
mapMaybe linkableFilterByteCode linkables
)
+
+mkLinkableUsage :: Linkable -> LinkableWithUsage
+mkLinkableUsage linkables = do
+ linkableUsage linkables
+ where
+ msg m = moduleNameString (moduleName m) ++ "[TH] changed"
+
+ linkableUsage lnk@Linkable{linkableParts} =
+ setLinkableParts lnk linkableParts
+
+ mkFileLinkableUsage m fp objs =
+ FileLinkableUsage
+ { flu_file = fp
+ , flu_message = Just $ msg m
+ , flu_linkable_objs = FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ mkByteCodeLinkableUsage m fp objs =
+ ByteCodeLinkableUsage
+ { bclu_module = m
+ , bclu_hash = fp
+ , bclu_linkable_objs = FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ setLinkableParts lnk@(Linkable{linkableModule}) parts =
+ lnk
+ { linkableParts = fmap (go linkableModule) parts
+ }
+
+ go :: Module -> LinkablePart -> LinkableUsage
+ go m lnkPart = case lnkPart of
+ DotO fn _ -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotA fn -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotDLL fn -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotGBC mbc -> mkByteCodeLinkableUsage m (gbc_hash mbc) (linkablePartObjectPaths lnkPart)
+
+mkLinkablesUsage :: [Linkable] -> [LinkableWithUsage]
+mkLinkablesUsage linkables = map mkLinkableUsage linkables
+
+linkableUsageObjs :: LinkableWithUsage -> [FilePath]
+linkableUsageObjs lnkWithUsage = concatMap linkableUsageObjectPaths (linkableParts lnkWithUsage)
+
{- **********************************************************************
Loading packages
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -153,7 +153,7 @@ initializePlugins hsc_env
([] , _ ) -> False -- some external plugin added
(p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss
-loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [LinkableWithUsage], PkgsLoaded)
loadPlugins hsc_env
= do { unless (null to_load) $
checkExternalInterpreter hsc_env
@@ -173,7 +173,7 @@ loadPlugins hsc_env
loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env
-loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [LinkableWithUsage], PkgsLoaded)
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
(plugin, _iface, links, pkgs)
@@ -188,7 +188,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
-> throwIO (InstallationError "Plugins require -fno-external-interpreter")
_ -> pure ()
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableWithUsage], PkgsLoaded)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
@@ -266,7 +266,7 @@ forceLoadTyCon hsc_env con_name = do
-- * If the Name does not exist in the module
-- * If the link failed
-getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [LinkableWithUsage], PkgsLoaded))
getValueSafely hsc_env val_name expected_type = do
eith_hval <- case getValueSafelyHook hooks of
Nothing -> getHValueSafely interp hsc_env val_name expected_type
@@ -281,7 +281,7 @@ getValueSafely hsc_env val_name expected_type = do
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
-getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [LinkableWithUsage], PkgsLoaded))
getHValueSafely interp hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-- Now look up the names for the value and type constructor in the type environment
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -562,7 +562,7 @@ data TcGblEnv
-- is implicit rather than explicit, so we have to zap a
-- mutable variable.
- tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded),
+ tcg_th_needed_deps :: TcRef ([LinkableWithUsage], PkgsLoaded),
-- ^ The set of runtime dependencies required by this module
-- See Note [Object File Dependencies]
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2259,7 +2259,7 @@ fillCoercionHole (CH { ch_ref = ref, ch_co_var = cv }) co
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
-recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
+recordThNeededRuntimeDeps :: [LinkableWithUsage] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps new_links new_pkgs
= do { env <- getGblEnv
; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -3,9 +3,11 @@
module GHC.Unit.Home.ModInfo
(
HomeModInfo (..)
- , HomeModLinkable (..)
, homeModInfoObject
, homeModInfoByteCode
+ , HomeModLinkable (..)
+ , homeModLinkableByteCode
+ , homeModLinkableObject
, emptyHomeModInfoLinkable
)
where
@@ -15,9 +17,10 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Linker.Types ( Linkable )
+import GHC.Linker.Types ( Linkable, LinkableWith, ModuleByteCode, LinkablePart (..) )
import GHC.Utils.Outputable
+import qualified Data.List.NonEmpty as NE
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -48,18 +51,24 @@ data HomeModInfo = HomeModInfo
}
homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
-homeModInfoByteCode = homeMod_bytecode . hm_linkable
+homeModInfoByteCode = homeModLinkableByteCode . hm_linkable
homeModInfoObject :: HomeModInfo -> Maybe Linkable
-homeModInfoObject = homeMod_object . hm_linkable
+homeModInfoObject = homeModLinkableObject . hm_linkable
emptyHomeModInfoLinkable :: HomeModLinkable
emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
-- See Note [Home module build products]
-data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe (LinkableWith ModuleByteCode))
, homeMod_object :: !(Maybe Linkable) }
+homeModLinkableByteCode :: HomeModLinkable -> Maybe Linkable
+homeModLinkableByteCode = fmap (fmap (NE.singleton . DotGBC)) . homeMod_bytecode
+
+homeModLinkableObject :: HomeModLinkable -> Maybe Linkable
+homeModLinkableObject = homeMod_object
+
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -22,6 +22,10 @@ module GHC.Unit.Module.Deps
, ImportAvails (..)
, IfaceImportLevel(..)
, tcImportLevel
+ , LinkableUsage(..)
+ , linkableUsageObjectPaths
+ , noLinkableUsage
+ , combineLinkableUsage
)
where
@@ -49,7 +53,10 @@ import qualified Data.Set as Set
import Data.Bifunctor
import Control.DeepSeq
import GHC.Types.Name.Set
-
+import GHC.ByteCode.Types (FlatBag)
+import GHC.Data.OsPath
+import qualified Data.Foldable as Foldable
+import qualified GHC.Data.OsPath as OsPath
-- | Dependency information about ALL modules and packages below this one
@@ -372,12 +379,12 @@ data Usage
-- we won't spot it here. If you do want to spot that, the caller
-- should recursively add them to their useage.
}
- | UsageHomeModuleInterface {
+ | UsageHomeModuleBytecode {
usg_mod_name :: ModuleName
-- ^ Name of the module
, usg_unit_id :: UnitId
-- ^ UnitId of the HomeUnit the module is from
- , usg_iface_hash :: Fingerprint
+ , usg_bytecode_hash :: Fingerprint
-- ^ The *interface* hash of the module, not the ABI hash.
-- This changes when anything about the interface (and hence the
-- module) has changed.
@@ -412,7 +419,7 @@ instance NFData Usage where
rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
- rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
+ rnf (UsageHomeModuleBytecode mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
instance Binary Usage where
put_ bh usg@UsagePackageModule{} = do
@@ -441,11 +448,11 @@ instance Binary Usage where
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
- put_ bh usg@UsageHomeModuleInterface{} = do
+ put_ bh usg@UsageHomeModuleBytecode{} = do
putByte bh 4
put_ bh (usg_mod_name usg)
put_ bh (usg_unit_id usg)
- put_ bh (usg_iface_hash usg)
+ put_ bh (usg_bytecode_hash usg)
put_ bh usg@UsageDirectory{} = do
putByte bh 5
@@ -483,7 +490,7 @@ instance Binary Usage where
mod <- get bh
uid <- get bh
hash <- get bh
- return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
+ return UsageHomeModuleBytecode { usg_mod_name = mod, usg_unit_id = uid, usg_bytecode_hash = hash }
5 -> do
dp <- get bh
hash <- get bh
@@ -695,3 +702,41 @@ data ImportAvails
-- ^ Family instance modules below us in the import tree (and maybe
-- including us for imported modules)
}
+
+data LinkableUsage
+ = FileLinkableUsage
+ { flu_file :: !FilePath
+ , flu_message :: !(Maybe String)
+ , flu_linkable_objs :: !(FlatBag OsPath)
+ }
+ | ByteCodeLinkableUsage
+ { bclu_module :: !Module
+ , bclu_hash :: !Fingerprint
+ , bclu_linkable_objs :: !(FlatBag OsPath)
+ }
+
+instance Outputable LinkableUsage where
+ ppr = \ case
+ FileLinkableUsage fp mmsg _objs ->
+ text "FileLinkableUsage" <+> text fp <> maybe empty (\ msg -> text " " <> text msg) mmsg
+ ByteCodeLinkableUsage modl hash _objs ->
+ text "ByteCodeLinkableUsage" <+> ppr modl <+> ppr hash
+
+instance NFData LinkableUsage where
+ rnf FileLinkableUsage{} = ()
+ rnf ByteCodeLinkableUsage{} = ()
+
+linkableUsageObjectPaths :: LinkableUsage -> [FilePath]
+linkableUsageObjectPaths lnkUsage =
+ map OsPath.unsafeDecodeUtf . Foldable.toList $ linkableUsageObjectOsPaths lnkUsage
+
+linkableUsageObjectOsPaths :: LinkableUsage -> FlatBag OsPath
+linkableUsageObjectOsPaths lnkUsage = case lnkUsage of
+ FileLinkableUsage{flu_linkable_objs} -> flu_linkable_objs
+ ByteCodeLinkableUsage{bclu_linkable_objs} -> bclu_linkable_objs
+
+noLinkableUsage :: [LinkableUsage]
+noLinkableUsage = []
+
+combineLinkableUsage :: [LinkableUsage] -> [LinkableUsage] -> [LinkableUsage]
+combineLinkableUsage a b = a ++ b
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
-import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith, linkableBCOs, linkableModuleByteCodes )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
@@ -59,7 +59,7 @@ data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompByte
, recompLinkables_object :: !(Maybe Linkable) }
data RecompBytecodeLinkable
- = NormalLinkable !(Maybe Linkable)
+ = NormalLinkable !(Maybe (LinkableWith ModuleByteCode))
| WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
instance Outputable HscRecompStatus where
@@ -87,7 +87,8 @@ justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
justBytecode = \case
Left lm ->
assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ $ assertPpr (length (linkableBCOs lm) == 1) (text "Expected 1 DotGBC linkable" $$ ppr lm )
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just (head (linkableModuleByteCodes lm) <$ lm)) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -99,7 +100,8 @@ bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> R
bytecodeAndObjects either_bc o = case either_bc of
Left bc ->
assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ $ assertPpr (length (linkableBCOs bc) == 1) (text "Expected 1 DotGBC linkable" $$ ppr bc )
+ $ RecompLinkables (NormalLinkable (Just (head (linkableModuleByteCodes bc) <$ bc))) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -37,6 +37,7 @@ module GHC.Utils.Binary
tellBinWriter,
castBin,
withBinBuffer,
+ withReadBinBuffer,
freezeWriteHandle,
shrinkBinBuffer,
thawReadHandle,
@@ -349,6 +350,12 @@ withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do
arr <- readIORef arr_r
action $ BS.fromForeignPtr arr 0 ix
+-- | Get access to the underlying buffer.
+withReadBinBuffer :: ReadBinHandle -> (ByteString -> IO a) -> IO a
+withReadBinBuffer (ReadBinMem _ ix_r _ arr) action = do
+ ix <- readFastMutInt ix_r
+ action $ BS.fromForeignPtr arr 0 ix
+
unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
ix_r <- newFastMutInt 0
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -52,8 +52,11 @@ getLeakIndicators hsc_env =
return $ LeakModIndicators{..}
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
- mkWeakLinkables (HomeModLinkable mbc mo) =
- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
+ mkWeakLinkables hml =
+ mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln)
+ [ homeModLinkableByteCode hml
+ , homeModLinkableObject hml
+ ]
-- | Look at the LeakIndicators collected by an earlier call to
-- `getLeakIndicators`, and print messasges if any of them are still
=====================================
testsuite/ghc-config/ghc-config
=====================================
Binary files /dev/null and b/testsuite/ghc-config/ghc-config differ
=====================================
testsuite/tests/bytecode/TLinkable/Makefile
=====================================
@@ -0,0 +1,30 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: TLinkable_Prep
+TLinkable_Prep:
+ ./genSplices TLinkable
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -v0 TLinkable.hs
+
+.PHONY: TLinkable2_Prep
+TLinkable2_Prep:
+ ./genSplices TLinkable2
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -fwrite-byte-code -v0 TLinkable2.hs
+
+.PHONY: linkable_bytecodelib_Prep linkable_bytecodelib
+PKGCONF01=bytecode.package.conf
+LOCAL_GHC_PKG01='$(GHC_PKG)' --no-user-package-db -f $(PKGCONF01)
+MAIN_MOD=BytecodeUsage
+linkable_bytecodelib_Prep:
+ $(LOCAL_GHC_PKG01) init $(PKGCONF01)
+ mkdir outdir
+ cd outdir && ../genSplices2 $(MAIN_MOD) 50 500
+ mv outdir/$(MAIN_MOD).hs $(MAIN_MOD).hs
+ cd outdir && $(TEST_HC) -bytecodelib -hisuf=$(ghciWayExt) $(ghciWayFlags) \
+ -o testpkg-1.2.3.4-XXX.bytecodelib -fbyte-code -fwrite-interface -fwrite-byte-code -this-unit-id=testpkg-1.2.3.4-XXX \
+ *.hs
+ $(LOCAL_GHC_PKG01) register --force outdir/bytecode.pkg
+
+linkable_bytecodelib:
+ $(TEST_HC) $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code $(MAIN_MOD) -package testpkg -package-db $(PKGCONF01) +RTS -l -hT -i0.001 -RTS
=====================================
testsuite/tests/bytecode/TLinkable/all.T
=====================================
@@ -0,0 +1,34 @@
+# Test ideas
+# Bytecode libraries
+# Depend on that bytecode, look at the bytecode library tests to make sure this ends up in the EPS
+
+def normaliseDynlibNames(str):
+ return re.sub(r'-ghc[0-9.]+\.', '-ghc<VERSION>.', str)
+
+test('TLinkable',
+ [ collect_compiler_stats('bytes allocated',2),
+ pre_cmd('$MAKE -s --no-print-directory TLinkable_Prep'),
+ extra_files(['genSplices']),
+ compile_timeout_multiplier(5),
+ ],
+ compile,
+ ['-fprefer-byte-code -fforce-recomp ' + config.ghc_th_way_flags])
+
+test('TLinkable2',
+ [ collect_compiler_stats('bytes allocated',2),
+ pre_cmd('$MAKE -s --no-print-directory TLinkable2_Prep'),
+ extra_files(['genSplices']),
+ compile_timeout_multiplier(5),
+ ],
+ compile,
+ ['-fprefer-byte-code -fforce-recomp ' + config.ghc_th_way_flags])
+
+test('linkable_bytecodelib',
+ [ extra_files(["genSplices2"])
+ , when(have_profiling(), extra_ways(['prof']))
+ , normalise_errmsg_fun(normaliseDynlibNames)
+ , pre_cmd('$MAKE -s --no-print-directory linkable_bytecodelib_Prep')
+ , copy_files
+ , req_bco ],
+ makefile_test,
+ [])
=====================================
testsuite/tests/bytecode/TLinkable/genSplices
=====================================
@@ -0,0 +1,79 @@
+#!/bin/bash
+
+# Generate NMOD Haskell modules, each with NDEF NOINLINE functions
+# Usage: ./genSplices <MODNAME> <NMOD> <NDEF>
+
+MODNAME=${1}
+NMOD=${2:-20} # Default 20 modules
+NDEF=${3:-50} # Default 50 functions per module
+
+# Generate the modules
+for ((i=1; i<=NMOD; i++)); do
+ module_name="Module$(printf "%03d" $i)"
+ file_path="${module_name}.hs"
+
+ cat > "$file_path" << EOF
+module ${module_name} where
+
+EOF
+
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ cat >> "$file_path" << EOF
+{-# NOINLINE ${func_name} #-}
+${func_name} :: Int -> Int
+${func_name} x = x + ${j}
+
+EOF
+ done
+done
+
+# Generate imports section
+imports=""
+for ((i=1; i<=NMOD; i++)); do
+ imports="${imports}import splice Module$(printf "%03d" $i)
+"
+done
+
+# Generate the hard-coded TH expression
+# Build: Module001.func001 1 + Module001.func002 2 + ... + Module{NMOD}.func{NDEF} {NMOD*NDEF}
+expression=""
+count=1
+for ((i=1; i<=NMOD; i++)); do
+ mod_name="Module$(printf "%03d" $i)"
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ if [ $count -gt 1 ]; then
+ expression="${expression} + "
+ fi
+ expression="${expression}${mod_name}.${func_name} ${count}"
+ ((count++))
+ done
+done
+
+# Generate the TH splice file
+cat > "${MODNAME}".hs << EOF
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+
+module ${MODNAME} where
+
+import splice Language.Haskell.TH.Syntax (Lift(..))
+import Control.Concurrent (threadDelay)
+import splice Prelude (Num(..), ($), Monad(..), pure)
+
+-- Import all generated modules
+${imports}
+-- Hard-coded splice that references ALL functions from ALL modules
+result :: Int
+result = \$(lift \$ ${expression})
+
+result_test :: IO Int
+result_test = \$( [| threadDelay 1_000_000 >> pure 50 |] )
+
+main :: IO ()
+main = do
+ putStrLn \$ "Result: " ++ show result
+ putStrLn . ("Other result: " ++) . show =<< result_test
+EOF
=====================================
testsuite/tests/bytecode/TLinkable/genSplices2
=====================================
@@ -0,0 +1,98 @@
+#!/bin/bash
+
+MODNAME=${1}
+NMOD=${2:-20} # Default 20 modules
+NDEF=${3:-50} # Default 50 functions per module
+
+# Generate the modules
+for ((i=1; i<=NMOD; i++)); do
+ module_name="Module$(printf "%03d" $i)"
+ file_path="${module_name}.hs"
+
+ cat > "$file_path" << EOF
+module ${module_name} where
+
+EOF
+
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ cat >> "$file_path" << EOF
+{-# NOINLINE ${func_name} #-}
+${func_name} :: Int -> Int
+${func_name} x = x + ${j}
+
+EOF
+ done
+done
+
+# Generate imports section
+imports=""
+for ((i=1; i<=NMOD; i++)); do
+ imports="${imports}import splice Module$(printf "%03d" $i)
+"
+done
+
+# Generate the hard-coded TH expression
+# Build: Module001.func001 1 + Module001.func002 2 + ... + Module{NMOD}.func{NDEF} {NMOD*NDEF}
+expressions=""
+all_mods=""
+for ((i=1; i<=NMOD; i++)); do
+ mod_name="Module$(printf "%03d" $i)"
+ all_mods="${all_mods} ${mod_name}"
+ single_expression=""
+ count=1
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ if [ $count -gt 1 ]; then
+ single_expression="${single_expression} + "
+ fi
+ single_expression="${single_expression}${mod_name}.${func_name} ${count}"
+ ((count++))
+ done
+
+ expressions="comp$(printf "%03d" $i) = \$(lift \$ ${single_expression})\\n\\n${expressions}"
+done
+
+# Generate the TH splice file
+cat > bytecode.pkg << EOF
+name: testpkg
+version: 1.2.3.4
+id: testpkg-1.2.3.4-XXX
+key: testpkg-1.2.3.4-XXX
+license: BSD3
+copyright: (c) The Univsersity of Glasgow 2004
+maintainer: glasgow-haskell-users(a)haskell.org
+stability: stable
+homepage: http://www.haskell.org/ghc
+package-url: http://www.haskell.org/ghc
+description: A Test Package
+category: none
+author: simonmar(a)microsoft.com
+exposed: True
+exposed-modules: ${all_mods}
+import-dirs: \${pkgroot}/outdir
+library-dirs: \${pkgroot}/outdir
+include-dirs:
+bytecode-library-dirs: \${pkgroot}/outdir
+hs-libraries: testpkg-1.2.3.4-XXX
+EOF
+
+# Generate the TH splice file
+cat > "${MODNAME}".hs << EOF
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+
+module ${MODNAME} where
+
+import splice Language.Haskell.TH.Syntax (Lift(..))
+import Control.Concurrent (threadDelay)
+import splice Prelude (Num(..), ($), Monad(..), pure)
+
+-- Import all generated modules
+${imports}
+
+-- Use from each module
+$(echo -e -n "${expressions}")
+
+EOF
=====================================
testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout
=====================================
@@ -0,0 +1 @@
+[1 of 1] Compiling BytecodeUsage ( BytecodeUsage.hs, BytecodeUsage.o )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcdba7cde905a3f4758132b038c0f9…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fcdba7cde905a3f4758132b038c0f9…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/control-monad-zip-to-base] Move the implementation of `Control.Monad.Zip` to `base`
by Wolfgang Jeltsch (＠jeltsch) 18 Feb '26
by Wolfgang Jeltsch (＠jeltsch) 18 Feb '26
18 Feb '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/control-monad-zip-to-base at Glasgow Haskell Compiler / GHC
Commits:
02490385 by Wolfgang Jeltsch at 2026-02-18T16:53:00+02:00
Move the implementation of `Control.Monad.Zip` to `base`
- - - - -
7 changed files:
- libraries/base/src/Control/Monad/Zip.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
Changes:
=====================================
libraries/base/src/Control/Monad/Zip.hs
=====================================
@@ -18,4 +18,127 @@
module Control.Monad.Zip ( MonadZip(..) ) where
-import GHC.Internal.Control.Monad.Zip(MonadZip(..))
+import GHC.Internal.Control.Monad (liftM, liftM2, Monad(..))
+import GHC.Internal.Data.Functor.Identity
+import qualified GHC.Internal.Data.Functor
+import GHC.Internal.Data.Monoid
+import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )
+import GHC.Internal.Data.Ord ( Down(..) )
+import GHC.Internal.Data.Proxy
+--import qualified Data.List.NonEmpty as NE
+import GHC.Internal.Generics
+import qualified GHC.Internal.Data.List.NonEmpty as NE
+import qualified GHC.Internal.Data.List as List
+import GHC.Internal.Data.Maybe
+import GHC.Internal.Data.Tuple
+--import Prelude
+
+-- | Instances should satisfy the laws:
+--
+-- [Naturality]
+--
+-- @'liftM' (f 'Control.Arrow.***' g) ('mzip' ma mb)
+-- = 'mzip' ('liftM' f ma) ('liftM' g mb)@
+--
+-- [Information Preservation]
+--
+-- @'liftM' ('Prelude.const' ()) ma = 'liftM' ('Prelude.const' ()) mb@
+-- implies
+-- @'munzip' ('mzip' ma mb) = (ma, mb)@
+--
+class Monad m => MonadZip m where
+ {-# MINIMAL mzip | mzipWith #-}
+
+ mzip :: m a -> m b -> m (a,b)
+ mzip = mzipWith (,)
+
+ mzipWith :: (a -> b -> c) -> m a -> m b -> m c
+ mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)
+
+ munzip :: m (a,b) -> (m a, m b)
+ munzip mab = (liftM fst mab, liftM snd mab)
+ -- munzip is a member of the class because sometimes
+ -- you can implement it more efficiently than the
+ -- above default code. See #4370 comment by giorgidze
+
+-- | @since 4.3.1.0
+instance MonadZip [] where
+ mzip = List.zip
+ mzipWith = List.zipWith
+ munzip = List.unzip
+
+-- | @since 4.9.0.0
+instance MonadZip NonEmpty where
+ mzip = NE.zip
+ mzipWith = NE.zipWith
+ munzip = GHC.Internal.Data.Functor.unzip
+
+-- | @since 4.8.0.0
+instance MonadZip Identity where
+ mzipWith = liftM2
+ munzip (Identity (a, b)) = (Identity a, Identity b)
+
+-- | @since 4.15.0.0
+instance MonadZip Solo where
+ mzipWith = liftM2
+ munzip (MkSolo (a, b)) = (MkSolo a, MkSolo b)
+
+-- | @since 4.8.0.0
+instance MonadZip Dual where
+ -- Cannot use coerce, it's unsafe
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip Sum where
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip Product where
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip Maybe where
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip First where
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip Last where
+ mzipWith = liftM2
+
+-- | @since 4.8.0.0
+instance MonadZip f => MonadZip (Alt f) where
+ mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb)
+
+-- | @since 4.9.0.0
+instance MonadZip Proxy where
+ mzipWith _ _ _ = Proxy
+
+-- Instances for GHC.Generics
+-- | @since 4.9.0.0
+instance MonadZip U1 where
+ mzipWith _ _ _ = U1
+
+-- | @since 4.9.0.0
+instance MonadZip Par1 where
+ mzipWith = liftM2
+
+-- | @since 4.9.0.0
+instance MonadZip f => MonadZip (Rec1 f) where
+ mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb)
+
+-- | @since 4.9.0.0
+instance MonadZip f => MonadZip (M1 i c f) where
+ mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb)
+
+-- | @since 4.9.0.0
+instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where
+ mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2
+
+-- instances for GHC.Internal.Data.Ord
+
+-- | @since 4.12.0.0
+instance MonadZip Down where
+ mzipWith = liftM2
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -135,7 +135,6 @@ Library
GHC.Internal.Control.Monad.Fix
GHC.Internal.Control.Monad.IO.Class
GHC.Internal.Control.Monad.ST
- GHC.Internal.Control.Monad.Zip
GHC.Internal.Control.Monad.ST.Lazy
GHC.Internal.Control.Monad.ST.Imp
GHC.Internal.Control.Monad.ST.Lazy.Imp
=====================================
libraries/ghc-internal/src/GHC/Internal/Control/Monad/Zip.hs deleted
=====================================
@@ -1,144 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeOperators #-}
-
------------------------------------------------------------------------------
--- |
--- Module : Control.Monad.Zip
--- Copyright : (c) Nils Schweinsberg 2011,
--- (c) George Giorgidze 2011
--- (c) University Tuebingen 2011
--- License : BSD-style (see the file libraries/base/LICENSE)
--- Maintainer : libraries(a)haskell.org
--- Stability : stable
--- Portability : portable
---
--- Monadic zipping (used for monad comprehensions)
---
------------------------------------------------------------------------------
-
-module GHC.Internal.Control.Monad.Zip ( MonadZip(..) ) where
-
-import GHC.Internal.Control.Monad (liftM, liftM2, Monad(..))
-import GHC.Internal.Data.Functor.Identity
-import qualified GHC.Internal.Data.Functor
-import GHC.Internal.Data.Monoid
-import GHC.Internal.Data.NonEmpty ( NonEmpty(..) )
-import GHC.Internal.Data.Ord ( Down(..) )
-import GHC.Internal.Data.Proxy
---import qualified Data.List.NonEmpty as NE
-import GHC.Internal.Generics
-import qualified GHC.Internal.Data.List.NonEmpty as NE
-import qualified GHC.Internal.Data.List as List
-import GHC.Internal.Data.Maybe
-import GHC.Internal.Data.Tuple
---import Prelude
-
--- | Instances should satisfy the laws:
---
--- [Naturality]
---
--- @'liftM' (f 'Control.Arrow.***' g) ('mzip' ma mb)
--- = 'mzip' ('liftM' f ma) ('liftM' g mb)@
---
--- [Information Preservation]
---
--- @'liftM' ('Prelude.const' ()) ma = 'liftM' ('Prelude.const' ()) mb@
--- implies
--- @'munzip' ('mzip' ma mb) = (ma, mb)@
---
-class Monad m => MonadZip m where
- {-# MINIMAL mzip | mzipWith #-}
-
- mzip :: m a -> m b -> m (a,b)
- mzip = mzipWith (,)
-
- mzipWith :: (a -> b -> c) -> m a -> m b -> m c
- mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)
-
- munzip :: m (a,b) -> (m a, m b)
- munzip mab = (liftM fst mab, liftM snd mab)
- -- munzip is a member of the class because sometimes
- -- you can implement it more efficiently than the
- -- above default code. See #4370 comment by giorgidze
-
--- | @since 4.3.1.0
-instance MonadZip [] where
- mzip = List.zip
- mzipWith = List.zipWith
- munzip = List.unzip
-
--- | @since 4.9.0.0
-instance MonadZip NonEmpty where
- mzip = NE.zip
- mzipWith = NE.zipWith
- munzip = GHC.Internal.Data.Functor.unzip
-
--- | @since 4.8.0.0
-instance MonadZip Identity where
- mzipWith = liftM2
- munzip (Identity (a, b)) = (Identity a, Identity b)
-
--- | @since 4.15.0.0
-instance MonadZip Solo where
- mzipWith = liftM2
- munzip (MkSolo (a, b)) = (MkSolo a, MkSolo b)
-
--- | @since 4.8.0.0
-instance MonadZip Dual where
- -- Cannot use coerce, it's unsafe
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip Sum where
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip Product where
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip Maybe where
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip First where
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip Last where
- mzipWith = liftM2
-
--- | @since 4.8.0.0
-instance MonadZip f => MonadZip (Alt f) where
- mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb)
-
--- | @since 4.9.0.0
-instance MonadZip Proxy where
- mzipWith _ _ _ = Proxy
-
--- Instances for GHC.Generics
--- | @since 4.9.0.0
-instance MonadZip U1 where
- mzipWith _ _ _ = U1
-
--- | @since 4.9.0.0
-instance MonadZip Par1 where
- mzipWith = liftM2
-
--- | @since 4.9.0.0
-instance MonadZip f => MonadZip (Rec1 f) where
- mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb)
-
--- | @since 4.9.0.0
-instance MonadZip f => MonadZip (M1 i c f) where
- mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb)
-
--- | @since 4.9.0.0
-instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where
- mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2
-
--- instances for GHC.Internal.Data.Ord
-
--- | @since 4.12.0.0
-instance MonadZip Down where
- mzipWith = liftM2
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -10532,6 +10532,26 @@ module Unsafe.Coerce where
-- Instances:
+instance forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip [] -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Solo -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
+instance [safe] forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Functor.Const.Const -- Defined in ‘Data.Bifoldable’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Either.Either -- Defined in ‘Data.Bifoldable’
instance [safe] forall i. Data.Bifoldable.Bifoldable (GHC.Internal.Generics.K1 i) -- Defined in ‘Data.Bifoldable’
@@ -11574,26 +11594,6 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Max -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Min -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.IO.Class.MonadIO GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.IO.Class’
-instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip [] -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Solo -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
-instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’
instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’
instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -10570,6 +10570,26 @@ module Unsafe.Coerce where
-- Instances:
+instance forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip [] -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Solo -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
+instance [safe] forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Functor.Const.Const -- Defined in ‘Data.Bifoldable’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Either.Either -- Defined in ‘Data.Bifoldable’
instance [safe] forall i. Data.Bifoldable.Bifoldable (GHC.Internal.Generics.K1 i) -- Defined in ‘Data.Bifoldable’
@@ -11601,26 +11621,6 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Max -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Min -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.IO.Class.MonadIO GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.IO.Class’
-instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip [] -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Solo -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
-instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’
instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’
instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -10794,6 +10794,26 @@ module Unsafe.Coerce where
-- Instances:
+instance forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip [] -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Solo -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
+instance [safe] forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Functor.Const.Const -- Defined in ‘Data.Bifoldable’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Either.Either -- Defined in ‘Data.Bifoldable’
instance [safe] forall i. Data.Bifoldable.Bifoldable (GHC.Internal.Generics.K1 i) -- Defined in ‘Data.Bifoldable’
@@ -11832,26 +11852,6 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Max -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Min -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.IO.Class.MonadIO GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.IO.Class’
-instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip [] -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Solo -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
-instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’
instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’
instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -10532,6 +10532,26 @@ module Unsafe.Coerce where
-- Instances:
+instance forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip [] -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘Control.Monad.Zip’
+instance forall (f :: * -> *). Control.Monad.Zip.MonadZip f => Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Solo -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘Control.Monad.Zip’
+instance Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
+instance [safe] forall (f :: * -> *) (g :: * -> *). (Control.Monad.Zip.MonadZip f, Control.Monad.Zip.MonadZip g) => Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Functor.Const.Const -- Defined in ‘Data.Bifoldable’
instance [safe] Data.Bifoldable.Bifoldable GHC.Internal.Data.Either.Either -- Defined in ‘Data.Bifoldable’
instance [safe] forall i. Data.Bifoldable.Bifoldable (GHC.Internal.Generics.K1 i) -- Defined in ‘Data.Bifoldable’
@@ -11574,26 +11594,6 @@ instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Last -- Defined
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Max -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.Fix.MonadFix Data.Semigroup.Min -- Defined in ‘Data.Semigroup’
instance GHC.Internal.Control.Monad.IO.Class.MonadIO GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Control.Monad.IO.Class’
-instance forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (f GHC.Internal.Generics.:*: g) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Data.Semigroup.Internal.Alt f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Ord.Down -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Dual -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.First -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Functor.Identity.Identity -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Monoid.Last -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip [] -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *) i (c :: GHC.Internal.Generics.Meta). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.M1 i c f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Base.NonEmpty -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.Par1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Product -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Proxy.Proxy -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance forall (f :: * -> *). GHC.Internal.Control.Monad.Zip.MonadZip f => GHC.Internal.Control.Monad.Zip.MonadZip (GHC.Internal.Generics.Rec1 f) -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Solo -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Data.Semigroup.Internal.Sum -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip GHC.Internal.Generics.U1 -- Defined in ‘GHC.Internal.Control.Monad.Zip’
-instance GHC.Internal.Control.Monad.Zip.MonadZip Data.Complex.Complex -- Defined in ‘Data.Complex’
-instance [safe] forall (f :: * -> *) (g :: * -> *). (GHC.Internal.Control.Monad.Zip.MonadZip f, GHC.Internal.Control.Monad.Zip.MonadZip g) => GHC.Internal.Control.Monad.Zip.MonadZip (Data.Functor.Product.Product f g) -- Defined in ‘Data.Functor.Product’
instance forall (a :: * -> * -> *) b c. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable b, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable c, GHC.Internal.Data.Data.Data (a b c)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedArrow a b c) -- Defined in ‘Control.Applicative’
instance forall (m :: * -> *) a. (ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable m, ghc-internal-9.1500.0:GHC.Internal.Data.Typeable.Internal.Typeable a, GHC.Internal.Data.Data.Data (m a)) => GHC.Internal.Data.Data.Data (Control.Applicative.WrappedMonad m a) -- Defined in ‘Control.Applicative’
instance GHC.Internal.Data.Data.Data Data.Array.Byte.ByteArray -- Defined in ‘Data.Array.Byte’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0249038508def6edcc5a2e79d471f5e…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0249038508def6edcc5a2e79d471f5e…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/duplex-readability-and-writability] 15 commits: Fix subtle bug in cast worker/wrapper
by Wolfgang Jeltsch (＠jeltsch) 18 Feb '26
by Wolfgang Jeltsch (＠jeltsch) 18 Feb '26
18 Feb '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/duplex-readability-and-writability at Glasgow Haskell Compiler / GHC
Commits:
99d8c146 by Simon Peyton Jones at 2026-02-12T17:36:59+00:00
Fix subtle bug in cast worker/wrapper
See (CWw4) in Note [Cast worker/wrapper].
The true payload is in the change to the definition of
GHC.Types.Id.Info.hasInlineUnfolding
Everthing else is just documentation.
There is a 2% compile time decrease for T13056;
I'll take the win!
Metric Decrease:
T13056
- - - - -
530e8e58 by Simon Peyton Jones at 2026-02-12T20:17:23-05:00
Add regression tests for four StaticPtr bugs
Tickets #26545, #24464, #24773, #16981 are all solved by the
recently-landed MR
commit 318ee13bcffa6aa8df42ba442ccd92aa0f7e210c
Author: Simon Peyton Jones <simon.peytonjones(a)gmail.com>
Date: Mon Oct 20 23:07:20 2025 +0100
Simplify the treatment of static forms
This MR just adds regression tests for them.
- - - - -
4157160f by Cheng Shao at 2026-02-13T06:27:04-05:00
ci: remove unused hlint-ghc-and-base job definition
This patch removes the unused `hlint-ghc-and-base` job definition,
it's never run since !9806. Note that hadrian lint rules still work
locally, so anyone that wishes to run hlint on the codebase can
continue to do so in their local worktree.
- - - - -
039f1977 by Cheng Shao at 2026-02-13T06:27:47-05:00
wasm: use import.meta.main for proper distinction of nodejs main modules
This patch uses `import.meta.main` for proper distinction of nodejs
main modules, especially when the main module might be installed as a
symlink. Fixes #26916.
- - - - -
14f485ee by ARATA Mizuki at 2026-02-17T09:09:24+09:00
Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI
Also, mark AVX-512 ER and PF as deprecated.
AVX-512 instructions can be used for certain 64-bit integer vector operations.
GFNI can be used to implement bitReverse (currently not used by NCG, but LLVM may use it).
Closes #26406
Addresses #26509
- - - - -
016f79d5 by fendor at 2026-02-17T09:16:16-05:00
Hide implementation details from base exception stack traces
Ensure we hide the implementation details of the exception throwing mechanisms:
* `undefined`
* `throwSTM`
* `throw`
* `throwIO`
* `error`
The `HasCallStackBacktrace` should always have a length of exactly 1,
not showing internal implementation details in the stack trace, as these
are vastly distracting to end users.
CLC proposal [#387](https://github.com/haskell/core-libraries-committee/issues/387)
- - - - -
4f2840f2 by Brian J. Cardiff at 2026-02-17T17:04:08-05:00
configure: Accept happy-2.2
In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build
- - - - -
10b4d364 by Duncan Coutts at 2026-02-17T17:04:52-05:00
Fix errors in the documentation of the eventlog STOP_THREAD status codes
Fix the code for BlockedOnMsgThrowTo.
Document all the known historical warts.
Fixes issue #26867
- - - - -
c5e15b8b by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: use snippets for all list examples
- generate snippet output for docs
- reduce font size to better fit snippets
- Use only directive to guard html snippets
- Add latex snippets for lists
- - - - -
d388bac1 by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: Place the snippet input and output together
- Put the output seemingly inside the example box
- - - - -
016fa306 by Samuel Thibault at 2026-02-18T05:08:35-05:00
Fix linking against libm by moving the -lm option
For those systems that need -lm for getting math functions, this is
currently added on the link line very early, before the object files being
linked together. Newer toolchains enable --as-needed by default, which means
-lm is ignored at that point because no object requires a math function
yet. With such toolchains, we thus have to add -lm after the objects, so the
linker actually includes libm in the link.
- - - - -
68bd0805 by Teo Camarasu at 2026-02-18T05:09:19-05:00
ghc-internal: Move GHC.Internal.Data.Bool to base
This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression.
Resolves 26865
- - - - -
77342519 by Wolfgang Jeltsch at 2026-02-18T15:42:21+02:00
Correct `hIsReadable` and `hIsWritable` for duplex handles
This contribution implements CLC proposal #371. It changes `hIsReadable`
and `hIsWritable` such that they always throw a respective exception
when encountering a closed or semi-closed handle, not just in the case
of a file handle.
- - - - -
6682c7d3 by Wolfgang Jeltsch at 2026-02-18T15:42:25+02:00
Document `SemiClosedHandle`
- - - - -
6df86909 by Wolfgang Jeltsch at 2026-02-18T15:42:25+02:00
Tell users what “semi-closed” means for duplex handles
- - - - -
130 changed files:
- .gitlab-ci.yml
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/Config/Core/Lint.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Types/Id/Info.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/phases.rst
- docs/users_guide/using.rst
- libraries/base/changelog.md
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Text.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TypeError.hs
- + libraries/ghc-internal/tests/backtraces/T15395.hs
- + libraries/ghc-internal/tests/backtraces/T15395.stdout
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
- m4/fptools_happy.m4
- testsuite/driver/cpu_features.py
- testsuite/tests/arrows/should_compile/T21301.stderr
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.hs
- testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
- testsuite/tests/deSugar/should_run/T20024.stderr
- testsuite/tests/deSugar/should_run/dsrun005.stderr
- testsuite/tests/deSugar/should_run/dsrun007.stderr
- testsuite/tests/deSugar/should_run/dsrun008.stderr
- testsuite/tests/deriving/should_run/T9576.stderr
- testsuite/tests/ghci/scripts/Defer02.stderr
- testsuite/tests/ghci/scripts/T15325.stderr
- testsuite/tests/patsyn/should_run/ghci.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- + testsuite/tests/rename/should_fail/T26545.hs
- + testsuite/tests/rename/should_fail/T26545.stderr
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr
- testsuite/tests/simd/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T26903.hs
- + testsuite/tests/simplCore/should_compile/T26903.stderr
- testsuite/tests/simplCore/should_compile/T8331.stderr
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/type-data/should_run/T22332a.stderr
- + testsuite/tests/typecheck/should_compile/T24464.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_run/T10284.stderr
- testsuite/tests/typecheck/should_run/T13838.stderr
- + testsuite/tests/typecheck/should_run/T16981.hs
- + testsuite/tests/typecheck/should_run/T16981.stdout
- + testsuite/tests/typecheck/should_run/T24773.hs
- + testsuite/tests/typecheck/should_run/T24773.stdout
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- testsuite/tests/typecheck/should_run/all.T
- testsuite/tests/unsatisfiable/T23816.stderr
- testsuite/tests/unsatisfiable/UnsatDefer.stderr
- utils/haddock/doc/.gitignore
- utils/haddock/doc/Makefile
- + utils/haddock/doc/_static/haddock-custom.css
- utils/haddock/doc/conf.py
- utils/haddock/doc/markup.rst
- + utils/haddock/doc/snippets/.gitignore
- + utils/haddock/doc/snippets/Lists.hs
- + utils/haddock/doc/snippets/Makefile
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.html
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.tex
- + utils/haddock/doc/snippets/Snippet-List-Definition.html
- + utils/haddock/doc/snippets/Snippet-List-Definition.tex
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.html
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.tex
- + utils/haddock/doc/snippets/Snippet-List-Indentation.html
- + utils/haddock/doc/snippets/Snippet-List-Indentation.tex
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.tex
- utils/haddock/html-test/ref/A.html
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug1033.html
- utils/haddock/html-test/ref/Bug1103.html
- utils/haddock/html-test/ref/Bug548.html
- utils/haddock/html-test/ref/Bug923.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/FunArgs.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/Instances.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/RedactTypeSynonyms.html
- utils/haddock/html-test/ref/T23616.html
- utils/haddock/html-test/ref/Test.html
- utils/haddock/html-test/ref/TypeFamilies3.html
- utils/jsffi/dyld.mjs
- utils/jsffi/post-link.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/628441f417d7c2f5bedc7be3ab5e81…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/628441f417d7c2f5bedc7be3ab5e81…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] 2 commits: Add bytecode linkable regression test
by Hannes Siebenhandl (＠fendor) 18 Feb '26
by Hannes Siebenhandl (＠fendor) 18 Feb '26
18 Feb '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
708fdb9b by fendor at 2026-02-18T14:21:00+01:00
Add bytecode linkable regression test
- - - - -
fcdba7cd by fendor at 2026-02-18T14:21:00+01:00
WIP: LinkableUsage
- - - - -
26 changed files:
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Utils/Binary.hs
- ghc/GHCi/Leak.hs
- + testsuite/ghc-config/ghc-config
- + testsuite/tests/bytecode/TLinkable/Makefile
- + testsuite/tests/bytecode/TLinkable/all.T
- + testsuite/tests/bytecode/TLinkable/genSplices
- + testsuite/tests/bytecode/TLinkable/genSplices2
- + testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout
Changes:
=====================================
compiler/GHC/ByteCode/Serialize.hs
=====================================
@@ -14,6 +14,7 @@ module GHC.ByteCode.Serialize
, InterpreterLibraryContents(..)
, writeBytecodeLib
, readBytecodeLib
+ , fingerprintModuleByteCodeContents
, decodeOnDiskModuleByteCode
, decodeOnDiskBytecodeLib
)
@@ -48,6 +49,7 @@ import GHC.Utils.Logger
import GHC.Linker.Types
import System.IO.Unsafe (unsafeInterleaveIO)
import GHC.Utils.Outputable
+import GHC.Utils.Fingerprint (Fingerprint, fingerprintByteString)
{- Note [Overview of persistent bytecode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -94,6 +96,7 @@ See Note [Recompilation avoidance with bytecode objects]
-- contained by 'ModuleByteCode' are stored in-memory rather than as file paths to
-- temporary files.
data OnDiskModuleByteCode = OnDiskModuleByteCode { odgbc_module :: Module
+ , odgbc_hash :: Fingerprint
, odgbc_compiled_byte_code :: CompiledByteCode
, odgbc_foreign :: [ByteString] -- ^ Contents of object files
}
@@ -154,7 +157,6 @@ instance Binary OnDiskBytecodeLib where
put_ bh bytecodeLibForeign
-
writeBytecodeLib :: BytecodeLib -> FilePath -> IO ()
writeBytecodeLib lib path = do
odbco <- encodeBytecodeLib lib
@@ -174,12 +176,14 @@ readBytecodeLib hsc_env path = do
instance Binary OnDiskModuleByteCode where
get bh = do
odgbc_module <- get bh
+ odgbc_hash <- get bh
odgbc_compiled_byte_code <- get bh
odgbc_foreign <- get bh
pure OnDiskModuleByteCode {..}
put_ bh OnDiskModuleByteCode {..} = do
put_ bh odgbc_module
+ put_ bh odgbc_hash
put_ bh odgbc_compiled_byte_code
put_ bh odgbc_foreign
@@ -197,7 +201,8 @@ decodeOnDiskModuleByteCode hsc_env odbco = do
pure $ ModuleByteCode {
gbc_module = odgbc_module odbco,
gbc_compiled_byte_code = odgbc_compiled_byte_code odbco,
- gbc_foreign_files = foreign_files
+ gbc_foreign_files = foreign_files,
+ gbc_hash = odgbc_hash odbco
}
decodeOnDiskBytecodeLib :: HscEnv -> OnDiskBytecodeLib -> IO BytecodeLib
@@ -256,7 +261,8 @@ encodeOnDiskModuleByteCode bco = do
pure $ OnDiskModuleByteCode {
odgbc_module = gbc_module bco,
odgbc_compiled_byte_code = gbc_compiled_byte_code bco,
- odgbc_foreign = foreign_contents
+ odgbc_foreign = foreign_contents,
+ odgbc_hash = gbc_hash bco
}
-- | Read a 'ModuleByteCode' from a file.
@@ -281,6 +287,15 @@ writeBinByteCode f cbc = do
putWithUserData QuietBinIFace NormalCompression bh odbco
writeBinMem bh f
+fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint
+fingerprintModuleByteCodeContents modl cbc foreign_files = do
+ bh' <- openBinMem (1024 * 1024)
+ bh <- addBinNameWriter bh'
+ foreign_contents <- readObjectFiles foreign_files
+ putWithUserData QuietBinIFace NormalCompression bh
+ (modl, cbc, foreign_contents)
+ withBinBuffer bh (pure . fingerprintByteString)
+
instance Binary CompiledByteCode where
get bh = do
bc_bcos <- get bh
=====================================
compiler/GHC/Driver/Hooks.hs
=====================================
@@ -137,7 +137,7 @@ data Hooks = Hooks
, tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
, hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult))
- , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)))
+ , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)))
, ghcPrimIfaceHook :: !(Maybe ModIface)
, runPhaseHook :: !(Maybe PhaseHook)
, runMetaHook :: !(Maybe (MetaHook TcM))
@@ -145,7 +145,7 @@ data Hooks = Hooks
-> HomePackageTable -> IO SuccessFlag))
, runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn)))
, getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type
- -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))
+ -> IO (Either Type (HValue, [LinkableWithUsage], PkgsLoaded))))
, createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
, stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs
-> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -866,7 +866,7 @@ hscRecompStatus
| otherwise -> do
-- Check the status of all the linkable types we might need.
-- 1. The in-memory linkable we had at hand.
- bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeMod_bytecode old_linkable)
+ bc_in_memory_linkable <- checkByteCodeInMemory hsc_env mod_summary (homeModLinkableByteCode old_linkable)
-- 2. The bytecode object file
bc_obj_linkable <- checkByteCodeFromObject hsc_env mod_summary
-- 3. Bytecode from an interface's whole core bindings.
@@ -1098,7 +1098,7 @@ loadIfaceByteCodeLazy ::
ModIface ->
ModLocation ->
TypeEnv ->
- IO (Maybe Linkable)
+ IO (Maybe (LinkableWith ModuleByteCode))
loadIfaceByteCodeLazy hsc_env iface location type_env =
case iface_core_bindings iface location of
Nothing -> return Nothing
@@ -1106,8 +1106,9 @@ loadIfaceByteCodeLazy hsc_env iface location type_env =
Just <$> compile wcb
where
compile decls = do
- bco <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls
- linkable $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env decls
+ linkable bco
linkable parts = do
if_time <- modificationTimeIfExists (ml_hi_file_ospath location)
@@ -1148,14 +1149,14 @@ initWholeCoreBindings hsc_env iface details (RecompLinkables bc o) = do
where
type_env = md_types details
- go :: RecompBytecodeLinkable -> IO (Maybe Linkable)
+ go :: RecompBytecodeLinkable -> IO (Maybe (LinkableWith ModuleByteCode))
go (NormalLinkable l) = pure l
go (WholeCoreBindingsLinkable wcbl) =
fmap Just $ for wcbl $ \wcb -> do
add_iface_to_hpt iface details hsc_env
- bco <- unsafeInterleaveIO $
- compileWholeCoreBindings hsc_env type_env wcb
- pure $ NE.singleton (DotGBC bco)
+ bco <- unsafeInterleaveIO $ do
+ compileWholeCoreBindings hsc_env type_env wcb
+ pure bco
-- | Hydrate interface Core bindings and compile them to bytecode.
--
@@ -2232,20 +2233,21 @@ make user's opt into writing the files.
-}
-- | Generate a 'ModuleByteCode' and write it to disk if `-fwrite-byte-code` is enabled.
-generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO Linkable
+generateAndWriteByteCodeLinkable :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO (LinkableWith ModuleByteCode)
generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do
bco_object <- generateAndWriteByteCode hsc_env cgguts mod_location
-- Either, get the same time as the .gbc file if it exists, or just the current time.
-- It's important the time of the linkable matches the time of the .gbc file for recompilation
-- checking.
bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file_ospath mod_location)
- return $ mkModuleByteCodeLinkable bco_time bco_object
+ return $ mkOnlyModuleByteCodeLinkable bco_time bco_object
mkModuleByteCode :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ModuleByteCode
mkModuleByteCode hsc_env mod mod_location cgguts = do
bcos <- hscGenerateByteCode hsc_env cgguts mod_location
objs <- outputAndCompileForeign hsc_env mod mod_location (cgi_foreign_files cgguts) (cgi_foreign cgguts)
- return $! ModuleByteCode mod bcos objs
+ !bcos_hash <- fingerprintModuleByteCodeContents mod bcos objs
+ return $! ModuleByteCode mod bcos objs bcos_hash
-- | Generate a fresh 'ModuleByteCode' for a given module but do not write it to disk.
generateFreshByteCodeLinkable :: HscEnv
@@ -2767,13 +2769,13 @@ hscTidy hsc_env guts = do
%* *
%********************************************************************* -}
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
hscCompileCoreExpr hsc_env loc expr =
case hscCompileCoreExprHook (hsc_hooks hsc_env) of
Nothing -> hscCompileCoreExpr' hsc_env loc expr
Just h -> h hsc_env loc expr
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Simplify it -}
-- Question: should we call SimpleOpt.simpleOptExpr here instead?
@@ -2859,8 +2861,10 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- load it -}
bco_time <- getCurrentTime
+ !bco_hash <- fingerprintModuleByteCodeContents this_mod bcos []
+ let mbc = ModuleByteCode this_mod bcos [] bco_hash
(mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $
- Linkable bco_time this_mod $ NE.singleton $ DotGBC (ModuleByteCode this_mod bcos [])
+ Linkable bco_time this_mod $ NE.singleton (DotGBC mbc)
-- Get the foreign reference to the name we should have just loaded.
mhvs <- lookupFromLoadedEnv interp (idName binding_id)
{- Get the HValue for the root -}
@@ -2876,7 +2880,7 @@ jsCodeGen
-> Module
-> [(CgStgTopBinding,IdSet)]
-> Id
- -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+ -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
let logger = hsc_logger hsc_env
tmpfs = hsc_tmpfs hsc_env
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -430,7 +430,7 @@ link' hsc_env batch_attempt_linking mHscMessager hpt
let obj_files = concatMap linkableObjs linkables
in action obj_files
linkBytecodeLinkable action =
- checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeMod_bytecode $ \linkables ->
+ checkLinkablesUpToDate hsc_env mHscMessager home_mods pkg_deps staticLink checkBytecodeLibraryLinkingNeeded homeModLinkableByteCode $ \linkables ->
let bytecode = concatMap linkableModuleByteCodes linkables
in action bytecode
=====================================
compiler/GHC/Driver/Plugins.hs
=====================================
@@ -342,7 +342,7 @@ data Plugins = Plugins
-- The purpose of this field is to cache the plugins so they
-- don't have to be loaded each time they are needed. See
-- 'GHC.Runtime.Loader.initializePlugins'.
- , loadedPluginDeps :: !([Linkable], PkgsLoaded)
+ , loadedPluginDeps :: !([LinkableWithUsage], PkgsLoaded)
-- ^ The object files required by the loaded plugins
-- See Note [Plugin dependencies]
}
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -7,8 +7,6 @@ module GHC.HsToCore.Usage (
import GHC.Prelude
-import GHC.Driver.Env
-
import GHC.Tc.Types
import GHC.Iface.Load
@@ -27,7 +25,6 @@ import GHC.Types.Unique.Set
import GHC.Unit
import GHC.Unit.Env
-import GHC.Unit.External
import GHC.Unit.Module.Imported
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
@@ -35,18 +32,17 @@ import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import GHC.Data.FastString
-import Data.IORef
import Data.List (sortBy)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.List.NonEmpty as NE
import GHC.Linker.Types
import GHC.Unit.Finder
import GHC.Types.Unique.DFM
import GHC.Driver.Plugins
import qualified GHC.Unit.Home.Graph as HUG
+import qualified Data.List.NonEmpty as NE
{- Note [Module self-dependency]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -75,19 +71,17 @@ data UsageConfig = UsageConfig
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv
-> Module -> ImportedMods -> [ImportUserSpec] -> NameSet
- -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
+ -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [LinkableWithUsage] -> PkgsLoaded
-> IfG [Usage]
mkUsageInfo uc plugins fc unit_env
this_mod dir_imp_mods imp_decls used_names
dependent_files dependent_dirs merged needed_links needed_pkgs
= do
- eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))
file_hashes <- liftIO $ mapM getFileHash dependent_files
dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
let hu = ue_unsafeHomeUnit unit_env
- hug = ue_home_unit_graph unit_env
-- Dependencies on object files due to TH and plugins
- object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs
+ object_usages <- liftIO $ mkObjectUsage plugins fc needed_links needed_pkgs
let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env)
mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod
dir_imp_mods imp_decls used_names
@@ -190,31 +184,31 @@ for a module or not. This is similar to how the recompilation checking for the l
-- | Find object files corresponding to the transitive closure of given home
-- modules and direct object files for pkg dependencies
-mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]
-mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
- let ls = ordNubOn linkableModule (th_links_needed ++ plugins_links_needed)
+mkObjectUsage :: Plugins -> FinderCache -> [LinkableWithUsage] -> PkgsLoaded -> IO [Usage]
+mkObjectUsage plugins fc th_links_needed th_pkgs_needed = do
+ let ls = th_links_needed ++ plugins_links_needed
ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well
(plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
where
- linkableToUsage (Linkable _ m uls) = mapM (partToUsage m) (NE.toList uls)
-
- msg m = moduleNameString (moduleName m) ++ "[TH] changed"
+ linkableToUsage :: LinkableWithUsage -> IO [Usage]
+ linkableToUsage (Linkable _ _m parts) = traverse partToUsage (NE.toList parts)
+
+ partToUsage link_usage =
+ case link_usage of
+ FileLinkableUsage{flu_file, flu_message} -> do
+ fing flu_message flu_file
+
+ ByteCodeLinkableUsage{bclu_module, bclu_hash} ->
+ pure $
+ UsageHomeModuleBytecode
+ { usg_mod_name = moduleName bclu_module
+ , usg_unit_id = toUnitId $ moduleUnit bclu_module
+ , usg_bytecode_hash = bclu_hash
+ }
fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
- partToUsage m part =
- case linkablePartPath part of
- Just fn -> fing (Just (msg m)) fn
- Nothing -> do
- -- This should only happen for home package things but oneshot puts
- -- home package ifaces in the PIT.
- miface <- lookupIfaceByModule hug pit m
- case miface of
- Nothing -> pprPanic "linkableToUsage" (ppr m)
- Just iface ->
- return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface)
-
librarySpecToUsage :: LibrarySpec -> IO [Usage]
librarySpecToUsage (Objects os) = traverse (fing Nothing) os
librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn]
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -88,6 +88,10 @@ import GHC.Iface.Errors.Ppr
import Data.Functor
import Data.Bifunctor (first)
import GHC.Types.PkgQual
+import GHC.ByteCode.Serialize (ModuleByteCode, gbc_hash)
+import GHC.Unit.Home.Graph (lookupHugByModule)
+import GHC.Unit.Home.ModInfo (HomeModLinkable(..), HomeModInfo (..))
+import GHC.Linker.Types (linkableParts)
{-
-----------------------------------------------
@@ -190,6 +194,7 @@ data RecompReason
| ModuleAdded (ImportLevel, UnitId, ModuleName)
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
+ | ModuleChangedBytecode ModuleName
| FileChanged FilePath
| DirChanged FilePath
| CustomReason String
@@ -224,7 +229,8 @@ instance Outputable RecompReason where
SigsMergeChanged -> text "Signatures to merge in changed"
ModuleChanged m -> ppr m <+> text "changed"
ModuleChangedRaw m -> ppr m <+> text "changed (raw)"
- ModuleChangedIface m -> ppr m <+> text "changed (interface)"
+ ModuleChangedIface m -> ppr m <+> text "changed (bytecode)"
+ ModuleChangedBytecode m -> ppr m <+> text "changed (interface)"
ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
@@ -718,6 +724,15 @@ needInterface mod continue
Nothing -> return $ NeedsRecompile MustCompile
Just iface -> liftIO $ continue iface
+needBytecode :: Module -> (ModuleByteCode -> IO RecompileRequired)
+ -> IfG RecompileRequired
+needBytecode mod continue
+ = do
+ mb_recomp <- tryGetBytecode mod
+ case mb_recomp of
+ Nothing -> return $ NeedsRecompile MustCompile
+ Just mbc -> liftIO $ continue mbc
+
tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
tryGetModIface doc_msg mod
= do -- Load the imported interface if possible
@@ -739,6 +754,27 @@ tryGetModIface doc_msg mod
-- import and it's been deleted
Succeeded iface -> pure $ Just iface
+tryGetBytecode :: Module -> IfG (Maybe ModuleByteCode)
+tryGetBytecode mod
+ = do -- Load the imported bytecode if possible
+ logger <- getLogger
+ liftIO $ trace_hi_diffs logger (text "Checking bytecode hash for module" <+> ppr mod <+> ppr (moduleUnit mod))
+
+ mb_module_bytecode <- do
+ env <- getTopEnv
+ liftIO (lookupHugByModule mod (hsc_HUG env)) >>= \ case
+ Nothing -> pure Nothing
+ Just hmi ->
+ case homeMod_bytecode (hm_linkable hmi) of
+ Nothing -> pure Nothing
+ Just gbc_linkable -> pure $ Just $ linkableParts gbc_linkable
+
+ case mb_module_bytecode of
+ Nothing -> do
+ liftIO $ trace_hi_diffs logger (sep [text "Couldn't find bytecode for module", ppr mod])
+ return Nothing
+ Just module_bytecode -> pure $ Just module_bytecode
+
-- | Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.
@@ -760,14 +796,14 @@ checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_ha
needInterface mod $ \iface -> do
let reason = ModuleChangedRaw (moduleName mod)
checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface)
-checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name
+checkModUsage _ UsageHomeModuleBytecode{ usg_mod_name = mod_name
, usg_unit_id = uid
- , usg_iface_hash = old_mod_hash } = do
+ , usg_bytecode_hash = old_bytecode_hash } = do
let mod = mkModule (RealUnit (Definite uid)) mod_name
logger <- getLogger
- needInterface mod $ \iface -> do
- let reason = ModuleChangedIface mod_name
- checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface)
+ needBytecode mod $ \cbc -> do
+ let reason = ModuleChangedBytecode mod_name
+ checkBytecodeFingerprint logger reason old_bytecode_hash (gbc_hash cbc)
checkModUsage _ UsageHomeModule{
usg_mod_name = mod_name,
@@ -1032,19 +1068,18 @@ checkModuleFingerprint logger reason old_mod_hash new_mod_hash
= out_of_date_hash logger reason (text " Module fingerprint has changed")
old_mod_hash new_mod_hash
-checkIfaceFingerprint
+checkBytecodeFingerprint
:: Logger
-> RecompReason
-> Fingerprint
-> Fingerprint
-> IO RecompileRequired
-checkIfaceFingerprint logger reason old_mod_hash new_mod_hash
- | new_mod_hash == old_mod_hash
- = up_to_date logger (text "Iface fingerprint unchanged")
-
+checkBytecodeFingerprint logger reason old_bytecode_hash new_bytecode_hash
+ | old_bytecode_hash == new_bytecode_hash
+ = up_to_date logger (text "Bytecode fingerprint unchanged")
| otherwise
- = out_of_date_hash logger reason (text " Iface fingerprint has changed")
- old_mod_hash new_mod_hash
+ = out_of_date_hash logger reason (text " Bytecode fingerprint has changed")
+ old_bytecode_hash new_bytecode_hash
------------------------
checkEntityUsage :: Logger
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -146,10 +146,10 @@ pprUsage usage@UsageDirectory{}
ppr (usg_dir_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
-pprUsage usage@UsageHomeModuleInterface{}
- = hsep [text "implementation", ppr (usg_mod_name usage)
+pprUsage usage@UsageHomeModuleBytecode{}
+ = hsep [text "Bytecode", ppr (usg_mod_name usage)
, ppr (usg_unit_id usage)
- , ppr (usg_iface_hash usage)]
+ , ppr (usg_bytecode_hash usage)]
pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc
pprUsageImport mod hash safe
@@ -157,4 +157,4 @@ pprUsageImport mod hash safe
, ppr hash ]
where
pp_safe | safe = text "safe"
- | otherwise = text " -/ "
\ No newline at end of file
+ | otherwise = text " -/ "
=====================================
compiler/GHC/Linker/ByteCode.hs
=====================================
@@ -31,7 +31,7 @@ linkBytecodeLib hsc_env gbcs = do
on_disk_bcos <- mapM (readBinByteCode hsc_env) bytecodeObjects
- let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs <- on_disk_bcos ++ gbcs]
+ let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs _hash <- on_disk_bcos ++ gbcs]
interpreter_foreign_lib <- mkInterpreterLib hsc_env (concat foreign_stubs ++ objectFiles)
@@ -67,4 +67,4 @@ mkInterpreterLib hsc_env files =
return $ Just (InterpreterSharedObject foreign_stub_lib_path foreign_stub_lib_dir foreign_stub_lib_name)
Nothing -> pure Nothing
False -> do
- pure $ Just (InterpreterStaticObjects files)
\ No newline at end of file
+ pure $ Just (InterpreterStaticObjects files)
=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -63,7 +63,7 @@ data LinkDepsOpts = LinkDepsOpts
data LinkDeps = LinkDeps
{ ldNeededLinkables :: [Linkable]
- , ldAllLinkables :: [Linkable]
+ , ldAllLinkables :: [LinkableWithUsage]
, ldUnits :: [UnitId]
, ldNeededUnits :: UniqDSet UnitId
}
@@ -126,7 +126,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
return $ LinkDeps
{ ldNeededLinkables = lnks_needed
- , ldAllLinkables = links_got ++ lnks_needed
+ , ldAllLinkables = links_got ++ mkLinkablesUsage lnks_needed
, ldUnits = pkgs_needed
, ldNeededUnits = pkgs_s
}
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -135,6 +135,7 @@ import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import Foreign.Ptr (nullPtr)
import GHC.ByteCode.Serialize
+import Control.DeepSeq (force)
-- Note [Linkers and loaders]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -228,7 +229,7 @@ lookupFromLoadedEnv interp name = do
-- | Load the module containing the given Name and get its associated 'HValue'.
--
-- Throws a 'ProgramError' if loading fails or the name cannot be found.
-loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
+loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [LinkableWithUsage], PkgsLoaded)
loadName interp hsc_env name = do
initLoaderState interp hsc_env
modifyLoaderState interp $ \pls0 -> do
@@ -258,7 +259,7 @@ loadDependencies
-> LoaderState
-> SrcSpan
-> [Module]
- -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
+ -> IO (LoaderState, SuccessFlag, [LinkableWithUsage], PkgsLoaded) -- ^ returns the set of linkables required
-- When called, the loader state must have been initialized (see `initLoaderState`)
loadDependencies interp hsc_env pls span needed_mods = do
let opts = initLinkDepsOpts hsc_env
@@ -667,6 +668,7 @@ findBytecodeLinkableMaybe hsc_env mod locn = do
case maybe_bytecode_time of
Nothing -> return Nothing
Just bytecode_time -> do
+ -- TODO: @fendor This must go
-- Also load the interface, for reasons to do with recompilation avoidance.
-- See Note [Recompilation avoidance with bytecode objects]
_ <- initIfaceLoad hsc_env $
@@ -723,7 +725,7 @@ get_reachable_nodes hsc_env mods
********************************************************************* -}
-- | Load the dependencies of a linkable, and then load the linkable itself.
-loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([Linkable], PkgsLoaded)
+loadDecls :: Interp -> HscEnv -> SrcSpan -> Linkable -> IO ([LinkableWithUsage], PkgsLoaded)
loadDecls interp hsc_env span linkable = do
-- Initialise the linker (if it's not been done already)
initLoaderState interp hsc_env
@@ -823,7 +825,7 @@ loadModuleLinkables interp hsc_env pls keep_spec linkables
(objs, bcos) = partitionLinkables linkables
-linkableInSet :: Linkable -> LinkableSet -> Bool
+linkableInSet :: Linkable -> LinkableSet LinkableWithUsage -> Bool
linkableInSet l objs_loaded =
case lookupModuleEnv objs_loaded (linkableModule l) of
Nothing -> False
@@ -952,17 +954,17 @@ dynLoadObjs interp hsc_env pls objs = do
then addWay WayProf
else id
-rmDupLinkables :: LinkableSet -- Already loaded
+rmDupLinkables :: LinkableSet LinkableWithUsage -- Already loaded
-> [Linkable] -- New linkables
- -> (LinkableSet, -- New loaded set (including new ones)
+ -> (LinkableSet LinkableWithUsage, -- New loaded set (including new ones)
[Linkable]) -- New linkables (excluding dups)
rmDupLinkables already ls
= go already [] ls
where
- go already extras [] = (already, extras)
- go already extras (l:ls)
+ go !already extras [] = (already, extras)
+ go !already extras (l:ls)
| linkableInSet l already = go already extras ls
- | otherwise = go (extendModuleEnv already (linkableModule l) l) (l:extras) ls
+ | otherwise = go (extendModuleEnv already (linkableModule l) $! force $ mkLinkableUsage l) (l:extras) ls
{- **********************************************************************
@@ -974,7 +976,7 @@ rmDupLinkables already ls
dynLinkBCOs :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [Linkable] -> IO LoaderState
dynLinkBCOs interp pls keep_spec bcos =
- let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+ let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos -- TODO: @fendor, convert to linkable usage here?
pls1 = pls { bcos_loaded = bcos_loaded' }
cbcs :: [CompiledByteCode]
@@ -1109,13 +1111,13 @@ unload_wkr interp pls@LoaderState{..} = do
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
- let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded
+ let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded -- TODO: @fendor LinkableUsage here already?
mapM_ unloadObjs linkables_to_unload
-- If we unloaded any object files at all, we need to purge the cache
-- of lookupSymbol results.
- when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $
+ when (not (null (filter (not . null . linkableUsageObjs) linkables_to_unload))) $
purgeLookupSymbolCache interp
let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState,
@@ -1125,7 +1127,7 @@ unload_wkr interp pls@LoaderState{..} = do
return new_pls
where
- unloadObjs :: Linkable -> IO ()
+ unloadObjs :: LinkableWithUsage -> IO ()
unloadObjs lnk
| interpreterDynamic interp = return ()
-- We don't do any cleanup when linking objects with the
@@ -1133,7 +1135,7 @@ unload_wkr interp pls@LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) (linkableObjs lnk)
+ = mapM_ (unloadObj interp) (linkableUsageObjs lnk)
-- The components of a BCO linkable may contain
-- dot-o files (generated from C stubs).
--
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -49,6 +49,7 @@ module GHC.Linker.Types
, WholeCoreBindingsLinkable
, LinkableWith(..)
, mkModuleByteCodeLinkable
+ , mkOnlyModuleByteCodeLinkable
, LinkablePart(..)
, LinkableObjectSort (..)
, linkableIsNativeCodeOnly
@@ -67,12 +68,17 @@ module GHC.Linker.Types
, linkableFilterNative
, partitionLinkables
+ , LinkableWithUsage
+ , linkableUsageObjs
+ , mkLinkablesUsage
+ , mkLinkableUsage
+
, ModuleByteCode(..)
)
where
import GHC.Prelude
-import GHC.Unit ( UnitId, Module )
+import GHC.Unit ( UnitId, Module, moduleNameString, moduleName )
import GHC.ByteCode.Types
import GHCi.BreakArray
import GHCi.RemoteTypes
@@ -97,6 +103,11 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty)
import qualified Data.List.NonEmpty as NE
import Control.Applicative ((<|>))
import Data.Functor.Identity
+import GHC.Unit.Module.Deps (LinkableUsage (..), linkableUsageObjectPaths)
+import GHC.Fingerprint (Fingerprint)
+import qualified GHC.Data.OsPath as OsPath
+import qualified GHC.Data.FlatBag as FlatBag
+import Control.DeepSeq (NFData(..))
{- **********************************************************************
@@ -172,10 +183,10 @@ data LoaderState = LoaderState
-- ^ Information about bytecode objects we have loaded into the
-- interpreter.
- , bcos_loaded :: !LinkableSet
+ , bcos_loaded :: !(LinkableSet LinkableWithUsage)
-- ^ The currently loaded interpreted modules (home package)
- , objs_loaded :: !LinkableSet
+ , objs_loaded :: !(LinkableSet LinkableWithUsage)
-- ^ And the currently-loaded compiled modules (home package)
, pkgs_loaded :: !PkgsLoaded
@@ -380,19 +391,25 @@ data LinkableWith parts = Linkable
-- ^ Files and chunks of code to link.
} deriving (Functor, Traversable, Foldable)
+instance NFData a => NFData (LinkableWith a) where
+ rnf Linkable{linkableTime,linkableModule,linkableParts} =
+ rnf linkableTime `seq` rnf linkableModule `seq` rnf linkableParts `seq` ()
+
type Linkable = LinkableWith (NonEmpty LinkablePart)
type WholeCoreBindingsLinkable = LinkableWith WholeCoreBindings
-type LinkableSet = ModuleEnv Linkable
+type LinkableWithUsage = LinkableWith (NonEmpty LinkableUsage)
+
+type LinkableSet = ModuleEnv
-mkLinkableSet :: [Linkable] -> LinkableSet
+mkLinkableSet :: [Linkable] -> LinkableSet Linkable
mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls]
-- | Union of LinkableSets.
--
-- In case of conflict, keep the most recent Linkable (as per linkableTime)
-unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet
+unionLinkableSet :: LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a) -> LinkableSet (LinkableWith a)
unionLinkableSet = plusModuleEnv_C go
where
go l1 l2
@@ -435,8 +452,9 @@ data LinkablePart
| DotDLL FilePath
-- ^ Dynamically linked library file (.so, .dll, .dylib)
- | DotGBC ModuleByteCode
- -- ^ A byte-code object, lives only in memory.
+ | DotGBC
+ -- ^ A byte-code object, lives only in memory.
+ ModuleByteCode
-- | The in-memory representation of a bytecode object
@@ -444,14 +462,19 @@ data LinkablePart
data ModuleByteCode = ModuleByteCode { gbc_module :: Module
, gbc_compiled_byte_code :: CompiledByteCode
, gbc_foreign_files :: [FilePath] -- ^ Path to object files
+ , gbc_hash :: !Fingerprint
}
mkModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> Linkable
-mkModuleByteCodeLinkable linkable_time bco =
+mkModuleByteCodeLinkable linkable_time bco = do
Linkable linkable_time (gbc_module bco) (pure (DotGBC bco))
+mkOnlyModuleByteCodeLinkable :: UTCTime -> ModuleByteCode -> LinkableWith ModuleByteCode
+mkOnlyModuleByteCodeLinkable linkable_time bco = do
+ Linkable linkable_time (gbc_module bco) bco
+
instance Outputable ModuleByteCode where
- ppr (ModuleByteCode mod _cbc _fos) = text "ModuleByteCode" <+> ppr mod
+ ppr (ModuleByteCode mod _cbc _fos _) = text "ModuleByteCode" <+> ppr mod
instance Outputable LinkablePart where
ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort
@@ -544,8 +567,8 @@ linkablePartObjectPaths = \case
-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
linkablePartBCOs :: LinkablePart -> [CompiledByteCode]
linkablePartBCOs = \case
- DotGBC bco -> [gbc_compiled_byte_code bco]
- _ -> []
+ DotGBC bco -> [gbc_compiled_byte_code bco]
+ _ -> []
linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
linkableFilter f linkable = do
@@ -586,6 +609,48 @@ partitionLinkables linkables =
mapMaybe linkableFilterByteCode linkables
)
+
+mkLinkableUsage :: Linkable -> LinkableWithUsage
+mkLinkableUsage linkables = do
+ linkableUsage linkables
+ where
+ msg m = moduleNameString (moduleName m) ++ "[TH] changed"
+
+ linkableUsage lnk@Linkable{linkableParts} =
+ setLinkableParts lnk linkableParts
+
+ mkFileLinkableUsage m fp objs =
+ FileLinkableUsage
+ { flu_file = fp
+ , flu_message = Just $ msg m
+ , flu_linkable_objs = FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ mkByteCodeLinkableUsage m fp objs =
+ ByteCodeLinkableUsage
+ { bclu_module = m
+ , bclu_hash = fp
+ , bclu_linkable_objs = FlatBag.fromList (strictGenericLength objs) [ OsPath.unsafeEncodeUtf obj | obj <- objs ]
+ }
+
+ setLinkableParts lnk@(Linkable{linkableModule}) parts =
+ lnk
+ { linkableParts = fmap (go linkableModule) parts
+ }
+
+ go :: Module -> LinkablePart -> LinkableUsage
+ go m lnkPart = case lnkPart of
+ DotO fn _ -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotA fn -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotDLL fn -> mkFileLinkableUsage m fn (linkablePartObjectPaths lnkPart)
+ DotGBC mbc -> mkByteCodeLinkableUsage m (gbc_hash mbc) (linkablePartObjectPaths lnkPart)
+
+mkLinkablesUsage :: [Linkable] -> [LinkableWithUsage]
+mkLinkablesUsage linkables = map mkLinkableUsage linkables
+
+linkableUsageObjs :: LinkableWithUsage -> [FilePath]
+linkableUsageObjs lnkWithUsage = concatMap linkableUsageObjectPaths (linkableParts lnkWithUsage)
+
{- **********************************************************************
Loading packages
=====================================
compiler/GHC/Runtime/Loader.hs
=====================================
@@ -153,7 +153,7 @@ initializePlugins hsc_env
([] , _ ) -> False -- some external plugin added
(p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss
-loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
+loadPlugins :: HscEnv -> IO ([LoadedPlugin], [LinkableWithUsage], PkgsLoaded)
loadPlugins hsc_env
= do { unless (null to_load) $
checkExternalInterpreter hsc_env
@@ -173,7 +173,7 @@ loadPlugins hsc_env
loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env
-loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [LinkableWithUsage], PkgsLoaded)
loadFrontendPlugin hsc_env mod_name = do
checkExternalInterpreter hsc_env
(plugin, _iface, links, pkgs)
@@ -188,7 +188,7 @@ checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
-> throwIO (InstallationError "Plugins require -fno-external-interpreter")
_ -> pure ()
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [LinkableWithUsage], PkgsLoaded)
loadPlugin' occ_name plugin_name hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name occ_name
dflags = hsc_dflags hsc_env
@@ -266,7 +266,7 @@ forceLoadTyCon hsc_env con_name = do
-- * If the Name does not exist in the module
-- * If the link failed
-getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
+getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [LinkableWithUsage], PkgsLoaded))
getValueSafely hsc_env val_name expected_type = do
eith_hval <- case getValueSafelyHook hooks of
Nothing -> getHValueSafely interp hsc_env val_name expected_type
@@ -281,7 +281,7 @@ getValueSafely hsc_env val_name expected_type = do
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
-getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [LinkableWithUsage], PkgsLoaded))
getHValueSafely interp hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-- Now look up the names for the value and type constructor in the type environment
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -562,7 +562,7 @@ data TcGblEnv
-- is implicit rather than explicit, so we have to zap a
-- mutable variable.
- tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded),
+ tcg_th_needed_deps :: TcRef ([LinkableWithUsage], PkgsLoaded),
-- ^ The set of runtime dependencies required by this module
-- See Note [Object File Dependencies]
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2259,7 +2259,7 @@ fillCoercionHole (CH { ch_ref = ref, ch_co_var = cv }) co
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
-recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
+recordThNeededRuntimeDeps :: [LinkableWithUsage] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps new_links new_pkgs
= do { env <- getGblEnv
; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -3,9 +3,11 @@
module GHC.Unit.Home.ModInfo
(
HomeModInfo (..)
- , HomeModLinkable (..)
, homeModInfoObject
, homeModInfoByteCode
+ , HomeModLinkable (..)
+ , homeModLinkableByteCode
+ , homeModLinkableObject
, emptyHomeModInfoLinkable
)
where
@@ -15,9 +17,10 @@ import GHC.Prelude
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
-import GHC.Linker.Types ( Linkable )
+import GHC.Linker.Types ( Linkable, LinkableWith, ModuleByteCode, LinkablePart (..) )
import GHC.Utils.Outputable
+import qualified Data.List.NonEmpty as NE
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -48,18 +51,24 @@ data HomeModInfo = HomeModInfo
}
homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
-homeModInfoByteCode = homeMod_bytecode . hm_linkable
+homeModInfoByteCode = homeModLinkableByteCode . hm_linkable
homeModInfoObject :: HomeModInfo -> Maybe Linkable
-homeModInfoObject = homeMod_object . hm_linkable
+homeModInfoObject = homeModLinkableObject . hm_linkable
emptyHomeModInfoLinkable :: HomeModLinkable
emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
-- See Note [Home module build products]
-data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe (LinkableWith ModuleByteCode))
, homeMod_object :: !(Maybe Linkable) }
+homeModLinkableByteCode :: HomeModLinkable -> Maybe Linkable
+homeModLinkableByteCode = fmap (fmap (NE.singleton . DotGBC)) . homeMod_bytecode
+
+homeModLinkableObject :: HomeModLinkable -> Maybe Linkable
+homeModLinkableObject = homeMod_object
+
instance Outputable HomeModLinkable where
ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -22,6 +22,10 @@ module GHC.Unit.Module.Deps
, ImportAvails (..)
, IfaceImportLevel(..)
, tcImportLevel
+ , LinkableUsage(..)
+ , linkableUsageObjectPaths
+ , noLinkableUsage
+ , combineLinkableUsage
)
where
@@ -49,7 +53,10 @@ import qualified Data.Set as Set
import Data.Bifunctor
import Control.DeepSeq
import GHC.Types.Name.Set
-
+import GHC.ByteCode.Types (FlatBag)
+import GHC.Data.OsPath
+import qualified Data.Foldable as Foldable
+import qualified GHC.Data.OsPath as OsPath
-- | Dependency information about ALL modules and packages below this one
@@ -372,12 +379,12 @@ data Usage
-- we won't spot it here. If you do want to spot that, the caller
-- should recursively add them to their useage.
}
- | UsageHomeModuleInterface {
+ | UsageHomeModuleBytecode {
usg_mod_name :: ModuleName
-- ^ Name of the module
, usg_unit_id :: UnitId
-- ^ UnitId of the HomeUnit the module is from
- , usg_iface_hash :: Fingerprint
+ , usg_bytecode_hash :: Fingerprint
-- ^ The *interface* hash of the module, not the ABI hash.
-- This changes when anything about the interface (and hence the
-- module) has changed.
@@ -412,7 +419,7 @@ instance NFData Usage where
rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
- rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
+ rnf (UsageHomeModuleBytecode mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
instance Binary Usage where
put_ bh usg@UsagePackageModule{} = do
@@ -441,11 +448,11 @@ instance Binary Usage where
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
- put_ bh usg@UsageHomeModuleInterface{} = do
+ put_ bh usg@UsageHomeModuleBytecode{} = do
putByte bh 4
put_ bh (usg_mod_name usg)
put_ bh (usg_unit_id usg)
- put_ bh (usg_iface_hash usg)
+ put_ bh (usg_bytecode_hash usg)
put_ bh usg@UsageDirectory{} = do
putByte bh 5
@@ -483,7 +490,7 @@ instance Binary Usage where
mod <- get bh
uid <- get bh
hash <- get bh
- return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
+ return UsageHomeModuleBytecode { usg_mod_name = mod, usg_unit_id = uid, usg_bytecode_hash = hash }
5 -> do
dp <- get bh
hash <- get bh
@@ -695,3 +702,41 @@ data ImportAvails
-- ^ Family instance modules below us in the import tree (and maybe
-- including us for imported modules)
}
+
+data LinkableUsage
+ = FileLinkableUsage
+ { flu_file :: !FilePath
+ , flu_message :: !(Maybe String)
+ , flu_linkable_objs :: !(FlatBag OsPath)
+ }
+ | ByteCodeLinkableUsage
+ { bclu_module :: !Module
+ , bclu_hash :: !Fingerprint
+ , bclu_linkable_objs :: !(FlatBag OsPath)
+ }
+
+instance Outputable LinkableUsage where
+ ppr = \ case
+ FileLinkableUsage fp mmsg _objs ->
+ text "FileLinkableUsage" <+> text fp <> maybe empty (\ msg -> text " " <> text msg) mmsg
+ ByteCodeLinkableUsage modl hash _objs ->
+ text "ByteCodeLinkableUsage" <+> ppr modl <+> ppr hash
+
+instance NFData LinkableUsage where
+ rnf FileLinkableUsage{} = ()
+ rnf ByteCodeLinkableUsage{} = ()
+
+linkableUsageObjectPaths :: LinkableUsage -> [FilePath]
+linkableUsageObjectPaths lnkUsage =
+ map OsPath.unsafeDecodeUtf . Foldable.toList $ linkableUsageObjectOsPaths lnkUsage
+
+linkableUsageObjectOsPaths :: LinkableUsage -> FlatBag OsPath
+linkableUsageObjectOsPaths lnkUsage = case lnkUsage of
+ FileLinkableUsage{flu_linkable_objs} -> flu_linkable_objs
+ ByteCodeLinkableUsage{bclu_linkable_objs} -> bclu_linkable_objs
+
+noLinkableUsage :: [LinkableUsage]
+noLinkableUsage = []
+
+combineLinkableUsage :: [LinkableUsage] -> [LinkableUsage] -> [LinkableUsage]
+combineLinkableUsage a b = a ++ b
=====================================
compiler/GHC/Unit/Module/Status.hs
=====================================
@@ -18,7 +18,7 @@ import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
-import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly )
+import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith, linkableBCOs, linkableModuleByteCodes )
import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
@@ -59,7 +59,7 @@ data RecompLinkables = RecompLinkables { recompLinkables_bytecode :: !RecompByte
, recompLinkables_object :: !(Maybe Linkable) }
data RecompBytecodeLinkable
- = NormalLinkable !(Maybe Linkable)
+ = NormalLinkable !(Maybe (LinkableWith ModuleByteCode))
| WholeCoreBindingsLinkable !WholeCoreBindingsLinkable
instance Outputable HscRecompStatus where
@@ -87,7 +87,8 @@ justBytecode :: Either Linkable WholeCoreBindingsLinkable -> RecompLinkables
justBytecode = \case
Left lm ->
assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm)
- $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
+ $ assertPpr (length (linkableBCOs lm) == 1) (text "Expected 1 DotGBC linkable" $$ ppr lm )
+ $ emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just (head (linkableModuleByteCodes lm) <$ lm)) }
Right lm -> emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }
justObjects :: Linkable -> RecompLinkables
@@ -99,7 +100,8 @@ bytecodeAndObjects :: Either Linkable WholeCoreBindingsLinkable -> Linkable -> R
bytecodeAndObjects either_bc o = case either_bc of
Left bc ->
assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o)
- $ RecompLinkables (NormalLinkable (Just bc)) (Just o)
+ $ assertPpr (length (linkableBCOs bc) == 1) (text "Expected 1 DotGBC linkable" $$ ppr bc )
+ $ RecompLinkables (NormalLinkable (Just (head (linkableModuleByteCodes bc) <$ bc))) (Just o)
Right bc ->
assertPpr (linkableIsNativeCodeOnly o) (ppr o)
$ RecompLinkables (WholeCoreBindingsLinkable bc) (Just o)
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -37,6 +37,7 @@ module GHC.Utils.Binary
tellBinWriter,
castBin,
withBinBuffer,
+ withReadBinBuffer,
freezeWriteHandle,
shrinkBinBuffer,
thawReadHandle,
@@ -349,6 +350,12 @@ withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do
arr <- readIORef arr_r
action $ BS.fromForeignPtr arr 0 ix
+-- | Get access to the underlying buffer.
+withReadBinBuffer :: ReadBinHandle -> (ByteString -> IO a) -> IO a
+withReadBinBuffer (ReadBinMem _ ix_r _ arr) action = do
+ ix <- readFastMutInt ix_r
+ action $ BS.fromForeignPtr arr 0 ix
+
unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
ix_r <- newFastMutInt 0
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -52,8 +52,11 @@ getLeakIndicators hsc_env =
return $ LeakModIndicators{..}
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
- mkWeakLinkables (HomeModLinkable mbc mo) =
- mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
+ mkWeakLinkables hml =
+ mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln)
+ [ homeModLinkableByteCode hml
+ , homeModLinkableObject hml
+ ]
-- | Look at the LeakIndicators collected by an earlier call to
-- `getLeakIndicators`, and print messasges if any of them are still
=====================================
testsuite/ghc-config/ghc-config
=====================================
Binary files /dev/null and b/testsuite/ghc-config/ghc-config differ
=====================================
testsuite/tests/bytecode/TLinkable/Makefile
=====================================
@@ -0,0 +1,31 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: TLinkable_Prep
+TLinkable_Prep:
+ ./genSplices TLinkable
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -v0 TLinkable.hs
+
+.PHONY: TLinkable2_Prep
+TLinkable2_Prep:
+ ./genSplices TLinkable2
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -fwrite-byte-code -v0 TLinkable2.hs
+
+.PHONY: linkable_bytecodelib_Prep linkable_bytecodelib
+PKGCONF01=bytecode.package.conf
+LOCAL_GHC_PKG01='$(GHC_PKG)' --no-user-package-db -f $(PKGCONF01)
+MAIN_MOD=BytecodeUsage
+linkable_bytecodelib_Prep:
+ $(LOCAL_GHC_PKG01) init $(PKGCONF01)
+ mkdir outdir
+ cd outdir && ../genSplices2 $(MAIN_MOD)
+ mv outdir/$(MAIN_MOD).hs $(MAIN_MOD).hs
+ cd outdir && $(TEST_HC) -bytecodelib -hisuf=$(ghciWayExt) $(ghciWayFlags) \
+ -o testpkg-1.2.3.4-XXX.bytecodelib -fbyte-code -fwrite-interface -fwrite-byte-code -this-unit-id=testpkg-1.2.3.4-XXX \
+ *.hs
+ $(LOCAL_GHC_PKG01) register --force outdir/bytecode.pkg
+
+linkable_bytecodelib:
+ $(TEST_HC) $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code $(MAIN_MOD) -package testpkg -package-db $(PKGCONF01) +RTS -l -hT -i0.001 -RTS
+
=====================================
testsuite/tests/bytecode/TLinkable/all.T
=====================================
@@ -0,0 +1,33 @@
+# Test ideas
+# Bytecode libraries
+# Depend on that bytecode, look at the bytecode library tests to make sure this ends up in the EPS
+
+def normaliseDynlibNames(str):
+ return re.sub(r'-ghc[0-9.]+\.', '-ghc<VERSION>.', str)
+
+test('TLinkable',
+ [ collect_compiler_stats('bytes allocated',2),
+ pre_cmd('$MAKE -s --no-print-directory TLinkable_Prep'),
+ extra_files(['genSplices']),
+ compile_timeout_multiplier(5),
+ ],
+ compile,
+ ['-fprefer-byte-code -fforce-recomp ' + config.ghc_th_way_flags])
+
+test('TLinkable2',
+ [ collect_compiler_stats('bytes allocated',2),
+ pre_cmd('$MAKE -s --no-print-directory TLinkable2_Prep'),
+ extra_files(['genSplices']),
+ compile_timeout_multiplier(5),
+ ],
+ compile,
+ ['-fprefer-byte-code -fforce-recomp ' + config.ghc_th_way_flags])
+
+test('linkable_bytecodelib',
+ [ extra_files(["genSplices2"])
+ , normalise_errmsg_fun(normaliseDynlibNames)
+ , pre_cmd('$MAKE -s --no-print-directory linkable_bytecodelib_Prep')
+ , copy_files
+ , req_bco ],
+ makefile_test,
+ [])
=====================================
testsuite/tests/bytecode/TLinkable/genSplices
=====================================
@@ -0,0 +1,79 @@
+#!/bin/bash
+
+# Generate NMOD Haskell modules, each with NDEF NOINLINE functions
+# Usage: ./genSplices <MODNAME> <NMOD> <NDEF>
+
+MODNAME=${1}
+NMOD=${2:-20} # Default 20 modules
+NDEF=${3:-50} # Default 50 functions per module
+
+# Generate the modules
+for ((i=1; i<=NMOD; i++)); do
+ module_name="Module$(printf "%03d" $i)"
+ file_path="${module_name}.hs"
+
+ cat > "$file_path" << EOF
+module ${module_name} where
+
+EOF
+
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ cat >> "$file_path" << EOF
+{-# NOINLINE ${func_name} #-}
+${func_name} :: Int -> Int
+${func_name} x = x + ${j}
+
+EOF
+ done
+done
+
+# Generate imports section
+imports=""
+for ((i=1; i<=NMOD; i++)); do
+ imports="${imports}import splice Module$(printf "%03d" $i)
+"
+done
+
+# Generate the hard-coded TH expression
+# Build: Module001.func001 1 + Module001.func002 2 + ... + Module{NMOD}.func{NDEF} {NMOD*NDEF}
+expression=""
+count=1
+for ((i=1; i<=NMOD; i++)); do
+ mod_name="Module$(printf "%03d" $i)"
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ if [ $count -gt 1 ]; then
+ expression="${expression} + "
+ fi
+ expression="${expression}${mod_name}.${func_name} ${count}"
+ ((count++))
+ done
+done
+
+# Generate the TH splice file
+cat > "${MODNAME}".hs << EOF
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+
+module ${MODNAME} where
+
+import splice Language.Haskell.TH.Syntax (Lift(..))
+import Control.Concurrent (threadDelay)
+import splice Prelude (Num(..), ($), Monad(..), pure)
+
+-- Import all generated modules
+${imports}
+-- Hard-coded splice that references ALL functions from ALL modules
+result :: Int
+result = \$(lift \$ ${expression})
+
+result_test :: IO Int
+result_test = \$( [| threadDelay 1_000_000 >> pure 50 |] )
+
+main :: IO ()
+main = do
+ putStrLn \$ "Result: " ++ show result
+ putStrLn . ("Other result: " ++) . show =<< result_test
+EOF
=====================================
testsuite/tests/bytecode/TLinkable/genSplices2
=====================================
@@ -0,0 +1,98 @@
+#!/bin/bash
+
+MODNAME=${1}
+NMOD=${2:-20} # Default 20 modules
+NDEF=${3:-50} # Default 50 functions per module
+
+# Generate the modules
+for ((i=1; i<=NMOD; i++)); do
+ module_name="Module$(printf "%03d" $i)"
+ file_path="${module_name}.hs"
+
+ cat > "$file_path" << EOF
+module ${module_name} where
+
+EOF
+
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ cat >> "$file_path" << EOF
+{-# NOINLINE ${func_name} #-}
+${func_name} :: Int -> Int
+${func_name} x = x + ${j}
+
+EOF
+ done
+done
+
+# Generate imports section
+imports=""
+for ((i=1; i<=NMOD; i++)); do
+ imports="${imports}import splice Module$(printf "%03d" $i)
+"
+done
+
+# Generate the hard-coded TH expression
+# Build: Module001.func001 1 + Module001.func002 2 + ... + Module{NMOD}.func{NDEF} {NMOD*NDEF}
+expressions=""
+all_mods=""
+for ((i=1; i<=NMOD; i++)); do
+ mod_name="Module$(printf "%03d" $i)"
+ all_mods="${all_mods} ${mod_name}"
+ single_expression=""
+ count=1
+ for ((j=1; j<=NDEF; j++)); do
+ func_name="func$(printf "%03d" $j)"
+ if [ $count -gt 1 ]; then
+ single_expression="${single_expression} + "
+ fi
+ single_expression="${single_expression}${mod_name}.${func_name} ${count}"
+ ((count++))
+ done
+
+ expressions="comp$(printf "%03d" $i) = \$(lift \$ ${single_expression})\\n\\n${expressions}"
+done
+
+# Generate the TH splice file
+cat > bytecode.pkg << EOF
+name: testpkg
+version: 1.2.3.4
+id: testpkg-1.2.3.4-XXX
+key: testpkg-1.2.3.4-XXX
+license: BSD3
+copyright: (c) The Univsersity of Glasgow 2004
+maintainer: glasgow-haskell-users(a)haskell.org
+stability: stable
+homepage: http://www.haskell.org/ghc
+package-url: http://www.haskell.org/ghc
+description: A Test Package
+category: none
+author: simonmar(a)microsoft.com
+exposed: True
+exposed-modules: ${all_mods}
+import-dirs: \${pkgroot}/outdir
+library-dirs: \${pkgroot}/outdir
+include-dirs:
+bytecode-library-dirs: \${pkgroot}/outdir
+hs-libraries: testpkg-1.2.3.4-XXX
+EOF
+
+# Generate the TH splice file
+cat > "${MODNAME}".hs << EOF
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE ExplicitLevelImports #-}
+
+module ${MODNAME} where
+
+import splice Language.Haskell.TH.Syntax (Lift(..))
+import Control.Concurrent (threadDelay)
+import splice Prelude (Num(..), ($), Monad(..), pure)
+
+-- Import all generated modules
+${imports}
+
+-- Use from each module
+$(echo -e -n "${expressions}")
+
+EOF
=====================================
testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout
=====================================
@@ -0,0 +1 @@
+[1 of 1] Compiling BytecodeUsage ( BytecodeUsage.hs, BytecodeUsage.o )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cdc44268af423ea74630d7078d6076…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cdc44268af423ea74630d7078d6076…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T26875] 9 commits: Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI
by Teo Camarasu (＠teo) 18 Feb '26
by Teo Camarasu (＠teo) 18 Feb '26
18 Feb '26
Teo Camarasu pushed to branch wip/T26875 at Glasgow Haskell Compiler / GHC
Commits:
14f485ee by ARATA Mizuki at 2026-02-17T09:09:24+09:00
Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI
Also, mark AVX-512 ER and PF as deprecated.
AVX-512 instructions can be used for certain 64-bit integer vector operations.
GFNI can be used to implement bitReverse (currently not used by NCG, but LLVM may use it).
Closes #26406
Addresses #26509
- - - - -
016f79d5 by fendor at 2026-02-17T09:16:16-05:00
Hide implementation details from base exception stack traces
Ensure we hide the implementation details of the exception throwing mechanisms:
* `undefined`
* `throwSTM`
* `throw`
* `throwIO`
* `error`
The `HasCallStackBacktrace` should always have a length of exactly 1,
not showing internal implementation details in the stack trace, as these
are vastly distracting to end users.
CLC proposal [#387](https://github.com/haskell/core-libraries-committee/issues/387)
- - - - -
4f2840f2 by Brian J. Cardiff at 2026-02-17T17:04:08-05:00
configure: Accept happy-2.2
In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build
- - - - -
10b4d364 by Duncan Coutts at 2026-02-17T17:04:52-05:00
Fix errors in the documentation of the eventlog STOP_THREAD status codes
Fix the code for BlockedOnMsgThrowTo.
Document all the known historical warts.
Fixes issue #26867
- - - - -
c5e15b8b by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: use snippets for all list examples
- generate snippet output for docs
- reduce font size to better fit snippets
- Use only directive to guard html snippets
- Add latex snippets for lists
- - - - -
d388bac1 by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: Place the snippet input and output together
- Put the output seemingly inside the example box
- - - - -
016fa306 by Samuel Thibault at 2026-02-18T05:08:35-05:00
Fix linking against libm by moving the -lm option
For those systems that need -lm for getting math functions, this is
currently added on the link line very early, before the object files being
linked together. Newer toolchains enable --as-needed by default, which means
-lm is ignored at that point because no object requires a math function
yet. With such toolchains, we thus have to add -lm after the objects, so the
linker actually includes libm in the link.
- - - - -
68bd0805 by Teo Camarasu at 2026-02-18T05:09:19-05:00
ghc-internal: Move GHC.Internal.Data.Bool to base
This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression.
Resolves 26865
- - - - -
82000eaa by Teo Camarasu at 2026-02-18T10:56:53+00:00
ghc-internal: avoid depending on GHC.Internal.Control.Monad.Fix
This module contains the definition of MonadFix, since we want an
instance for IO, that instance requires a lot of machinery and we want
to avoid an orphan instance, this will naturally be quite high up in the
dependency graph.
So we want to avoid other modules depending on it as far as possible.
Resolves #26875
- - - - -
120 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/SysTools/Cpp.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/phases.rst
- docs/users_guide/using.rst
- libraries/base/changelog.md
- libraries/base/src/Control/Arrow.hs
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/Exts.hs
- libraries/base/src/System/IO.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Control/Arrow.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/Fix.hs
- libraries/ghc-internal/src/GHC/Internal/Control/Monad/ST/Lazy/Imp.hs
- − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Monad.hs
- libraries/ghc-internal/src/GHC/Internal/TypeError.hs
- + libraries/ghc-internal/tests/backtraces/T15395.hs
- + libraries/ghc-internal/tests/backtraces/T15395.stdout
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
- m4/fptools_happy.m4
- testsuite/driver/cpu_features.py
- testsuite/tests/arrows/should_compile/T21301.stderr
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.hs
- testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
- testsuite/tests/deSugar/should_run/T20024.stderr
- testsuite/tests/deSugar/should_run/dsrun005.stderr
- testsuite/tests/deSugar/should_run/dsrun007.stderr
- testsuite/tests/deSugar/should_run/dsrun008.stderr
- testsuite/tests/deriving/should_run/T9576.stderr
- testsuite/tests/ghci/scripts/Defer02.stderr
- testsuite/tests/ghci/scripts/ListTuplePunsPpr.stdout
- testsuite/tests/ghci/scripts/T15325.stderr
- testsuite/tests/ghci/scripts/T4175.stdout
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/mdo/should_fail/mdofail006.stderr
- testsuite/tests/patsyn/should_run/ghci.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/type-data/should_run/T22332a.stderr
- testsuite/tests/typecheck/should_run/T10284.stderr
- testsuite/tests/typecheck/should_run/T13838.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- testsuite/tests/unsatisfiable/T23816.stderr
- testsuite/tests/unsatisfiable/UnsatDefer.stderr
- utils/haddock/doc/.gitignore
- utils/haddock/doc/Makefile
- + utils/haddock/doc/_static/haddock-custom.css
- utils/haddock/doc/conf.py
- utils/haddock/doc/markup.rst
- + utils/haddock/doc/snippets/.gitignore
- + utils/haddock/doc/snippets/Lists.hs
- + utils/haddock/doc/snippets/Makefile
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.html
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.tex
- + utils/haddock/doc/snippets/Snippet-List-Definition.html
- + utils/haddock/doc/snippets/Snippet-List-Definition.tex
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.html
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.tex
- + utils/haddock/doc/snippets/Snippet-List-Indentation.html
- + utils/haddock/doc/snippets/Snippet-List-Indentation.tex
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.tex
- utils/haddock/html-test/ref/A.html
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug1033.html
- utils/haddock/html-test/ref/Bug1103.html
- utils/haddock/html-test/ref/Bug548.html
- utils/haddock/html-test/ref/Bug923.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/FunArgs.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/Instances.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/RedactTypeSynonyms.html
- utils/haddock/html-test/ref/T23616.html
- utils/haddock/html-test/ref/Test.html
- utils/haddock/html-test/ref/TypeFamilies3.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b5fa580049dd07d74f958f55491be…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8b5fa580049dd07d74f958f55491be…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/linkable-usage] 11 commits: Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI
by Hannes Siebenhandl (＠fendor) 18 Feb '26
by Hannes Siebenhandl (＠fendor) 18 Feb '26
18 Feb '26
Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC
Commits:
14f485ee by ARATA Mizuki at 2026-02-17T09:09:24+09:00
Support more x86 extensions: AVX-512 {BW,DQ,VL} and GFNI
Also, mark AVX-512 ER and PF as deprecated.
AVX-512 instructions can be used for certain 64-bit integer vector operations.
GFNI can be used to implement bitReverse (currently not used by NCG, but LLVM may use it).
Closes #26406
Addresses #26509
- - - - -
016f79d5 by fendor at 2026-02-17T09:16:16-05:00
Hide implementation details from base exception stack traces
Ensure we hide the implementation details of the exception throwing mechanisms:
* `undefined`
* `throwSTM`
* `throw`
* `throwIO`
* `error`
The `HasCallStackBacktrace` should always have a length of exactly 1,
not showing internal implementation details in the stack trace, as these
are vastly distracting to end users.
CLC proposal [#387](https://github.com/haskell/core-libraries-committee/issues/387)
- - - - -
4f2840f2 by Brian J. Cardiff at 2026-02-17T17:04:08-05:00
configure: Accept happy-2.2
In Jan 2026 happy-2.2 was released. The most sensible change is https://github.com/haskell/happy/issues/335 which didn't trigger in a fresh build
- - - - -
10b4d364 by Duncan Coutts at 2026-02-17T17:04:52-05:00
Fix errors in the documentation of the eventlog STOP_THREAD status codes
Fix the code for BlockedOnMsgThrowTo.
Document all the known historical warts.
Fixes issue #26867
- - - - -
c5e15b8b by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: use snippets for all list examples
- generate snippet output for docs
- reduce font size to better fit snippets
- Use only directive to guard html snippets
- Add latex snippets for lists
- - - - -
d388bac1 by Phil de Joux at 2026-02-18T05:07:36-05:00
haddock: Place the snippet input and output together
- Put the output seemingly inside the example box
- - - - -
016fa306 by Samuel Thibault at 2026-02-18T05:08:35-05:00
Fix linking against libm by moving the -lm option
For those systems that need -lm for getting math functions, this is
currently added on the link line very early, before the object files being
linked together. Newer toolchains enable --as-needed by default, which means
-lm is ignored at that point because no object requires a math function
yet. With such toolchains, we thus have to add -lm after the objects, so the
linker actually includes libm in the link.
- - - - -
68bd0805 by Teo Camarasu at 2026-02-18T05:09:19-05:00
ghc-internal: Move GHC.Internal.Data.Bool to base
This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression.
Resolves 26865
- - - - -
c45e90e1 by Matthew Pickering at 2026-02-18T11:16:59+01:00
Add support for ghc-debug to ghc executable
- - - - -
bc1c437c by fendor at 2026-02-18T11:16:59+01:00
Add bytecode linkable regression test
- - - - -
cdc44268 by fendor at 2026-02-18T11:16:59+01:00
WIP: LinkableUsage
- - - - -
140 changed files:
- .gitmodules
- compiler/GHC/ByteCode/Serialize.hs
- compiler/GHC/CmmToAsm/Config.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/Instr.hs
- compiler/GHC/CmmToAsm/X86/Ppr.hs
- compiler/GHC/Driver/Config/CmmToAsm.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Plugins.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Linker/ByteCode.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/Deps.hs
- compiler/GHC/Unit/Module/Status.hs
- compiler/GHC/Utils/Binary.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/phases.rst
- docs/users_guide/using.rst
- + ghc-debug
- ghc/GHCi/Leak.hs
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
- hadrian/src/Packages.hs
- hadrian/src/Settings/Default.hs
- hadrian/src/Settings/Packages.hs
- + instructions.md
- libraries/base/changelog.md
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/Exception.hs
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/STM.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TypeError.hs
- + libraries/ghc-internal/tests/backtraces/T15395.hs
- + libraries/ghc-internal/tests/backtraces/T15395.stdout
- libraries/ghc-internal/tests/backtraces/all.T
- libraries/ghc-internal/tests/stack-annotation/ann_frame005.stdout
- m4/fptools_happy.m4
- testsuite/driver/cpu_features.py
- + testsuite/ghc-config/ghc-config
- testsuite/tests/arrows/should_compile/T21301.stderr
- + testsuite/tests/bytecode/TLinkable/Makefile
- + testsuite/tests/bytecode/TLinkable/all.T
- + testsuite/tests/bytecode/TLinkable/genSplices
- + testsuite/tests/bytecode/TLinkable/genSplices2
- + testsuite/tests/bytecode/TLinkable/linkable_bytecodelib.stdout
- testsuite/tests/codeGen/should_gen_asm/all.T
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-minmax.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-int64-mul.hs
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.asm
- + testsuite/tests/codeGen/should_gen_asm/avx512-word64-minmax.hs
- testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
- testsuite/tests/deSugar/should_run/T20024.stderr
- testsuite/tests/deSugar/should_run/dsrun005.stderr
- testsuite/tests/deSugar/should_run/dsrun007.stderr
- testsuite/tests/deSugar/should_run/dsrun008.stderr
- testsuite/tests/deriving/should_run/T9576.stderr
- testsuite/tests/ghci/scripts/Defer02.stderr
- testsuite/tests/ghci/scripts/T15325.stderr
- testsuite/tests/patsyn/should_run/ghci.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/safeHaskell/safeLanguage/SafeLang15.stderr
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/type-data/should_run/T22332a.stderr
- testsuite/tests/typecheck/should_run/T10284.stderr
- testsuite/tests/typecheck/should_run/T13838.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- testsuite/tests/unsatisfiable/T23816.stderr
- testsuite/tests/unsatisfiable/UnsatDefer.stderr
- utils/haddock/doc/.gitignore
- utils/haddock/doc/Makefile
- + utils/haddock/doc/_static/haddock-custom.css
- utils/haddock/doc/conf.py
- utils/haddock/doc/markup.rst
- + utils/haddock/doc/snippets/.gitignore
- + utils/haddock/doc/snippets/Lists.hs
- + utils/haddock/doc/snippets/Makefile
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.html
- + utils/haddock/doc/snippets/Snippet-List-Bulleted.tex
- + utils/haddock/doc/snippets/Snippet-List-Definition.html
- + utils/haddock/doc/snippets/Snippet-List-Definition.tex
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.html
- + utils/haddock/doc/snippets/Snippet-List-Enumerated.tex
- + utils/haddock/doc/snippets/Snippet-List-Indentation.html
- + utils/haddock/doc/snippets/Snippet-List-Indentation.tex
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Multiline-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.html
- + utils/haddock/doc/snippets/Snippet-List-Nested-Item.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Newline.tex
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.html
- + utils/haddock/doc/snippets/Snippet-List-Not-Separated.tex
- utils/haddock/html-test/ref/A.html
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug1033.html
- utils/haddock/html-test/ref/Bug1103.html
- utils/haddock/html-test/ref/Bug548.html
- utils/haddock/html-test/ref/Bug923.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/FunArgs.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/Instances.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/RedactTypeSynonyms.html
- utils/haddock/html-test/ref/T23616.html
- utils/haddock/html-test/ref/Test.html
- utils/haddock/html-test/ref/TypeFamilies3.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47420bcbe490a7a36bbcb04fc329ab…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/47420bcbe490a7a36bbcb04fc329ab…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] ghc-internal: Move GHC.Internal.Data.Bool to base
by Marge Bot (＠marge-bot) 18 Feb '26
by Marge Bot (＠marge-bot) 18 Feb '26
18 Feb '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
68bd0805 by Teo Camarasu at 2026-02-18T05:09:19-05:00
ghc-internal: Move GHC.Internal.Data.Bool to base
This is a tiny module that only defines bool :: Bool -> a -> a -> a. We can just move this to base and delete it from ghc-internal. If we want this functionality there we can just use a case statement or if-then expression.
Resolves 26865
- - - - -
31 changed files:
- libraries/base/src/Data/Bool.hs
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NubOrdSet.hs
- libraries/base/src/GHC/Exts.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- − libraries/ghc-internal/src/GHC/Internal/Data/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Foldable.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Function.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Bool.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Type/Ord.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/IO/FD.hs
- libraries/ghc-internal/src/GHC/Internal/JS/Prim.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO/OS.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Lift.hs
- libraries/ghc-internal/src/GHC/Internal/TypeError.hs
- utils/haddock/html-test/ref/A.html
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug1033.html
- utils/haddock/html-test/ref/Bug1103.html
- utils/haddock/html-test/ref/Bug548.html
- utils/haddock/html-test/ref/Bug923.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/FunArgs.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/Instances.html
- utils/haddock/html-test/ref/LinearTypes.html
- utils/haddock/html-test/ref/RedactTypeSynonyms.html
- utils/haddock/html-test/ref/T23616.html
- utils/haddock/html-test/ref/Test.html
- utils/haddock/html-test/ref/TypeFamilies3.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68bd08055594b8cbf6148a72d108786…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/68bd08055594b8cbf6148a72d108786…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Fix linking against libm by moving the -lm option
by Marge Bot (＠marge-bot) 18 Feb '26
by Marge Bot (＠marge-bot) 18 Feb '26
18 Feb '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
016fa306 by Samuel Thibault at 2026-02-18T05:08:35-05:00
Fix linking against libm by moving the -lm option
For those systems that need -lm for getting math functions, this is
currently added on the link line very early, before the object files being
linked together. Newer toolchains enable --as-needed by default, which means
-lm is ignored at that point because no object requires a math function
yet. With such toolchains, we thus have to add -lm after the objects, so the
linker actually includes libm in the link.
- - - - -
1 changed file:
- compiler/GHC/Linker/Dynamic.hs
Changes:
=====================================
compiler/GHC/Linker/Dynamic.hs
=====================================
@@ -227,7 +227,6 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
runLink logger tmpfs linker_config (
map Option verbFlags
- ++ libmLinkOpts platform
++ [ Option "-o"
, FileOption "" output_fn
]
@@ -260,6 +259,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- driver is a more pragmatic solution.
++ [ Option "-Wl,--Bsymbolic,--experimental-pic,--unresolved-symbols=import-dynamic" | arch == ArchWasm32 ]
++ extra_ld_inputs
+ ++ libmLinkOpts platform
++ map Option lib_path_opts
++ map Option pkg_lib_path_opts
++ map Option pkg_link_opts
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/016fa306cd8afdaac56ebdebe44a447…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/016fa306cd8afdaac56ebdebe44a447…
You're receiving this email because of your account on gitlab.haskell.org.
1
0