Matthew Pickering pushed to branch wip/gdc-files at Glasgow Haskell Compiler / GHC Commits: b76e8088 by Matthew Pickering at 2025-08-19T09:37:29+01:00 fixes - - - - - 6 changed files: - + compiler/GHC/Driver/ByteCode.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Linker/Deps.hs - compiler/GHC/Linker/Loader.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Driver/ByteCode.hs ===================================== @@ -0,0 +1,70 @@ +module GHC.Driver.ByteCode where + + +import GHC.Prelude + +import GHC.Driver.Session +import GHC.Driver.CodeOutput +import GHC.Driver.Env +import GHC.Runtime.Interpreter +import GHC.ByteCode.Types + +import GHC.Linker.Types +import GHC.Tc.Utils.Monad + +import GHC.Unit +import GHC.Types.ForeignStubs +import GHC.Data.Maybe + +import Data.List.NonEmpty (NonEmpty ((:|))) +import {-# SOURCE #-} GHC.Driver.Pipeline +import Data.Time + +import GHC.Platform.Ways + +import GHC.ByteCode.Serialize + +-- | Write foreign sources and foreign stubs to temporary files and compile them. +outputAndCompileForeign :: HscEnv -> Module -> ModLocation -> [(ForeignSrcLang, FilePath)] -> ForeignStubs -> IO [FilePath] +outputAndCompileForeign hsc_env mod_name location foreign_files foreign_stubs = do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + (_, has_stub) <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) mod_name location foreign_stubs + compile_for_interpreter hsc_env $ \ i_env -> do + stub_o <- traverse (compileForeign i_env LangC) has_stub + foreign_files_o <- traverse (uncurry (compileForeign i_env)) foreign_files + pure (maybeToList stub_o ++ foreign_files_o) + +-- | Modify flags such that objects are compiled for the interpreter's way. +-- This is necessary when building foreign objects for Template Haskell, since +-- those are object code built outside of the pipeline, which means they aren't +-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build +-- outputs for dependencies when the interpreter used for TH is dynamic but the +-- main outputs aren't. +-- Furthermore, the HPT only stores one set of objects with different names for +-- bytecode linking in 'HomeModLinkable', so the usual hack for switching +-- between ways in 'get_link_deps' doesn't work. +compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a +compile_for_interpreter hsc_env use = + use (hscUpdateFlags update hsc_env) + where + update dflags = dflags { + targetWays_ = adapt_way interpreterDynamic WayDyn $ + adapt_way interpreterProfiled WayProf $ + targetWays_ dflags + } + + adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay + +-- | Write the foreign sources and foreign stubs of a bytecode object to temporary files and compile them. +loadByteCodeObject :: HscEnv -> ModLocation -> ByteCodeObject + -> IO (CompiledByteCode, [FilePath]) +loadByteCodeObject hsc_env location (ByteCodeObject mod cbc foreign_srcs foreign_stubs) = do + fos <- outputAndCompileForeign hsc_env mod location foreign_srcs foreign_stubs + return (cbc, fos) + +loadByteCodeObjectLinkable :: HscEnv -> UTCTime -> ModLocation -> ByteCodeObject -> IO Linkable +loadByteCodeObjectLinkable hsc_env linkable_time location bco = do + ~(cbc, fos) <- loadByteCodeObject hsc_env location bco + return $! Linkable linkable_time (bco_module bco) (BCOs cbc :| [DotO fo ForeignObject | fo <- fos]) \ No newline at end of file ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -116,6 +116,7 @@ import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env +import GHC.Driver.ByteCode import GHC.Driver.Env.KnotVars import GHC.Driver.Errors import GHC.Driver.Messager @@ -290,12 +291,10 @@ import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.WholeCoreBindings import GHC.Types.TypeEnv import System.IO -import {-# SOURCE #-} GHC.Driver.Pipeline import Data.Time import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) -import GHC.Platform.Ways import GHC.Stg.EnforceEpt.TagSig (seqTagSig) import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM @@ -884,6 +883,11 @@ hscRecompStatus let just_o = justObjects <$> obj_linkable + bytecode_or_object_code + | gopt Opt_WriteByteCode lcl_dflags = justBytecode <$> definitely_bc + | otherwise = (justBytecode <$> maybe_bc) `choose` just_o + + definitely_both_os = case (bc_result, obj_linkable) of (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) -- If missing object code, just say we need to recompile because of object code. @@ -899,8 +903,7 @@ hscRecompStatus -- If not -fwrite-byte-code, then we could use core bindings or object code if that's available. maybe_bc = bc_in_memory_linkable `choose` bc_obj_linkable `choose` - bc_core_linkable `choose` - obj_linkable + bc_core_linkable bc_result = if gopt Opt_WriteByteCode lcl_dflags -- If the byte-code artifact needs to be produced, then we certainly need bytecode. @@ -915,8 +918,8 @@ hscRecompStatus -- pprTraceM "recomp" (ppr just_bc <+> ppr just_o) -- 2. Decide which of the products we will need let recomp_linkable_result = case () of - _ | backendCanReuseLoadedCode (backend lcl_dflags) -> - justBytecode <$> bc_result + _ | backendCanReuseLoadedCode (backend lcl_dflags) -> bytecode_or_object_code + -- Need object files for making object files | backendWritesFiles (backend lcl_dflags) -> if gopt Opt_ByteCodeAndObjectCode lcl_dflags @@ -936,13 +939,13 @@ hscRecompStatus -- | Prefer requires both arguments to be up-to-date. -- but prefers to use the second argument. -prefer :: MaybeValidated Linkable -> MaybeValidated Linkable -> MaybeValidated Linkable +prefer :: MaybeValidated a -> MaybeValidated a -> MaybeValidated a prefer (UpToDateItem _) (UpToDateItem l2) = UpToDateItem l2 prefer r1 _ = r1 -- | Disjunction, choose either argument, but prefer the first one. -- Report the failure of the first argument. -choose :: MaybeValidated Linkable -> MaybeValidated Linkable -> MaybeValidated Linkable +choose :: MaybeValidated a -> MaybeValidated a -> MaybeValidated a choose (UpToDateItem l1) _ = UpToDateItem l1 choose _ (UpToDateItem l2) = UpToDateItem l2 choose l1 _ = l1 @@ -1052,26 +1055,6 @@ initModDetails hsc_env iface = -- in make mode, since this HMI will go into the HPT. genModDetails hsc_env iface --- | Modify flags such that objects are compiled for the interpreter's way. --- This is necessary when building foreign objects for Template Haskell, since --- those are object code built outside of the pipeline, which means they aren't --- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build --- outputs for dependencies when the interpreter used for TH is dynamic but the --- main outputs aren't. --- Furthermore, the HPT only stores one set of objects with different names for --- bytecode linking in 'HomeModLinkable', so the usual hack for switching --- between ways in 'get_link_deps' doesn't work. -compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a -compile_for_interpreter hsc_env use = - use (hscUpdateFlags update hsc_env) - where - update dflags = dflags { - targetWays_ = adapt_way interpreterDynamic WayDyn $ - adapt_way interpreterProfiled WayProf $ - targetWays_ dflags - } - - adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay -- | Assemble 'WholeCoreBindings' if the interface contains Core bindings. iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings @@ -2257,30 +2240,6 @@ generateAndWriteByteCodeLinkable hsc_env cgguts mod_location = do bco_time <- maybe getCurrentTime pure =<< modificationTimeIfExists (ml_bytecode_file mod_location) loadByteCodeObjectLinkable hsc_env bco_time mod_location bco_object --- | Write foreign sources and foreign stubs to temporary files and compile them. -outputAndCompileForeign :: HscEnv -> Module -> ModLocation -> [(ForeignSrcLang, FilePath)] -> ForeignStubs -> IO [FilePath] -outputAndCompileForeign hsc_env mod_name location foreign_files foreign_stubs = do - let dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - tmpfs = hsc_tmpfs hsc_env - (_, has_stub) <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) mod_name location foreign_stubs - compile_for_interpreter hsc_env $ \ i_env -> do - stub_o <- traverse (compileForeign i_env LangC) has_stub - foreign_files_o <- traverse (uncurry (compileForeign i_env)) foreign_files - pure (maybeToList stub_o ++ foreign_files_o) - --- | Write the foreign sources and foreign stubs of a bytecode object to temporary files and compile them. -loadByteCodeObject :: HscEnv -> ModLocation -> ByteCodeObject - -> IO (CompiledByteCode, [FilePath]) -loadByteCodeObject hsc_env location (ByteCodeObject mod cbc foreign_srcs foreign_stubs) = do - fos <- outputAndCompileForeign hsc_env mod location foreign_srcs foreign_stubs - return (cbc, fos) - -loadByteCodeObjectLinkable :: HscEnv -> UTCTime -> ModLocation -> ByteCodeObject -> IO Linkable -loadByteCodeObjectLinkable hsc_env linkable_time location bco = do - (cbc, fos) <- loadByteCodeObject hsc_env location bco - return $! Linkable linkable_time (bco_module bco) (BCOs cbc :| [DotO fo ForeignObject | fo <- fos]) - mkByteCodeObject :: HscEnv -> Module -> ModLocation -> CgInteractiveGuts -> IO ByteCodeObject mkByteCodeObject hsc_env mod mod_location cgguts = do bcos <- hscGenerateByteCode hsc_env cgguts mod_location ===================================== compiler/GHC/HsToCore/Usage.hs ===================================== @@ -187,7 +187,9 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do -- home package ifaces in the PIT. miface <- lookupIfaceByModule hug pit m case miface of - Nothing -> pprPanic "mkObjectUsage" (ppr m) + -- TODO: MP: This is wrong, a placeholder for now. + -- We need to work out what to do for bytecode linkables which are not loaded into HPT + Nothing -> return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) fingerprint0 Just iface -> return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface) ===================================== compiler/GHC/Linker/Deps.hs ===================================== @@ -59,7 +59,7 @@ data LinkDepsOpts = LinkDepsOpts , ldWays :: !Ways -- ^ Enabled ways , ldFinderCache :: !FinderCache , ldFinderOpts :: !FinderOpts - , ldLoadByteCode :: !(Module -> IO (Maybe Linkable)) + , ldLoadByteCode :: !(Module -> ModLocation -> IO (Maybe Linkable)) , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId)) } @@ -161,8 +161,15 @@ get_link_deps opts pls maybe_normal_osuf span mods = do case ue_homeUnit unit_env of Nothing -> no_obj mod Just home_unit -> do - from_bc <- ldLoadByteCode opts mod - maybe (fallback_no_bytecode home_unit mod) pure from_bc + + let fc = ldFinderCache opts + let fopts = ldFinderOpts opts + mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) + case mb_stuff of + Found loc _ -> do + from_bc <- ldLoadByteCode opts mod loc + maybe (fallback_no_bytecode home_unit mod) pure from_bc + _ -> fallback_no_bytecode home_unit mod where fallback_no_bytecode home_unit mod = do ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -39,6 +39,7 @@ where import GHC.Prelude import GHC.Settings +import GHC.Utils.Misc import GHC.Platform import GHC.Platform.Ways @@ -48,6 +49,7 @@ import GHC.Driver.Phases import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.ByteCode import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Finder @@ -129,6 +131,7 @@ import qualified GHC.Runtime.Interpreter as GHCi import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M import Foreign.Ptr (nullPtr) +import GHC.ByteCode.Serialize -- Note [Linkers and loaders] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -628,7 +631,14 @@ initLinkDepsOpts hsc_env = opts } dflags = hsc_dflags hsc_env - ldLoadByteCode mod = do + ldLoadByteCode mod locn = do + bco <- findBytecodeLinkableMaybe hsc_env mod locn + case bco of + Nothing -> findWholeCoreBindings hsc_env mod + Just bco -> return (Just bco) + +findWholeCoreBindings :: HscEnv -> Module -> IO (Maybe Linkable) +findWholeCoreBindings hsc_env mod = do _ <- initIfaceLoad hsc_env $ loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) mod ImportBySystem @@ -636,6 +646,16 @@ initLinkDepsOpts hsc_env = opts sequence (lookupModuleEnv eps_iface_bytecode mod) +findBytecodeLinkableMaybe :: HscEnv -> Module -> ModLocation -> IO (Maybe Linkable) +findBytecodeLinkableMaybe hsc_env _mod locn = do + let bytecode_fn = ml_bytecode_file locn + maybe_bytecode_time <- modificationTimeIfExists bytecode_fn + case maybe_bytecode_time of + Nothing -> return Nothing + Just bytecode_time -> do + bco <- readBinByteCode hsc_env bytecode_fn + Just <$> loadByteCodeObjectLinkable hsc_env bytecode_time locn bco + get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) get_reachable_nodes hsc_env mods ===================================== compiler/ghc.cabal.in ===================================== @@ -490,6 +490,7 @@ Library GHC.Driver.Backend.Internal GHC.Driver.Backpack GHC.Driver.Backpack.Syntax + GHC.Driver.ByteCode GHC.Driver.CmdLine GHC.Driver.CodeOutput GHC.Driver.Config View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b76e8088267a950508a1a5eb7bc46131... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b76e8088267a950508a1a5eb7bc46131... You're receiving this email because of your account on gitlab.haskell.org.