Hannes Siebenhandl pushed to branch wip/fendor/linkable-usage at Glasgow Haskell Compiler / GHC Commits: 74f436e1 by fendor at 2026-02-16T14:45:42+01:00 Add bytecode linkable regression test - - - - - 0831be2f by fendor at 2026-02-16T14:45:42+01:00 WIP: LinkableUsage - - - - - 23 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/tests/bytecode/TLinkable/Makefile - + testsuite/tests/bytecode/TLinkable/all.T - + testsuite/tests/bytecode/TLinkable/genSplices 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 ===================================== @@ -228,7 +228,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 +258,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 +667,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 +724,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 +824,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,9 +953,9 @@ 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 @@ -962,7 +963,7 @@ rmDupLinkables already 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) (mkLinkableUsage l)) (l:extras) ls {- ********************************************************************** @@ -974,7 +975,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 +1110,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 +1126,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 +1134,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,10 @@ 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 {- ********************************************************************** @@ -172,10 +182,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 @@ -384,15 +394,17 @@ 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 +447,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 +457,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 +562,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 +604,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 ===================================== @@ -563,7 +563,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 ===================================== @@ -2266,7 +2266,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,38 @@ 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 + + +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, @@ -348,6 +349,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/tests/bytecode/TLinkable/Makefile ===================================== @@ -0,0 +1,17 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: TLinkable_Prep +TLinkable_Prep: + ./genSplices + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -v0 TLinkable.hs + +.PHONY: TLinkable2Pre +TLinkable2Pre: + ./genSplices + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -fprefer-byte-code -fwrite-byte-code -v0 THMain.hs + +.PHONY: TLinkable2 +TLinkable2: + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -c -fprefer-byte-code -fwrite-byte-code -v0 THMain.hs ===================================== testsuite/tests/bytecode/TLinkable/all.T ===================================== @@ -0,0 +1,22 @@ +# Test ideas +# Bytecode libraries +# Depend on that bytecode, look at the bytecode library tests to make sure this ends up in the EPS + +# test('TLinkable', +# [ collect_compiler_stats('bytes allocated',2), +# pre_cmd('$MAKE -s --no-print-directory TLinkablePre'), +# extra_files(['genSplices']), +# ], +# makefile_test, +# ['TLinkable']) + +# A performance test for calculating link dependencies in -c mode. +test('TLinkable', + [ collect_compiler_stats('bytes allocated',2), + pre_cmd('$MAKE -s --no-print-directory TLinkable_Prep'), + extra_files(['genSplices']), + compile_timeout_multiplier(5), + when(arch('wasm32'), fragile(25336)), + ], + compile, + ['-fforce-recomp ' + config.ghc_th_way_flags]) ===================================== testsuite/tests/bytecode/TLinkable/genSplices ===================================== @@ -0,0 +1,69 @@ +#!/bin/bash + +# Generate NMOD Haskell modules, each with NDEF NOINLINE functions +# Usage: ./genSplices <NMOD> <NDEF> + +NMOD=${1:-20} # Default 20 modules +NDEF=${2:-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 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 > TLinkable.hs << EOF +{-# LANGUAGE TemplateHaskell #-} + +module TLinkable where +import Language.Haskell.TH.Syntax (Lift(..)) + +-- Import all generated modules +${imports} +-- Hard-coded splice that references ALL functions from ALL modules +result :: Int +result = \$(lift \$ ${expression}) + +main :: IO () +main = do + putStrLn \$ "Result: " ++ show result +EOF View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88863e7fc8022ef334542ccb572f261... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/88863e7fc8022ef334542ccb572f261... You're receiving this email because of your account on gitlab.haskell.org.