GitLab

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:

 +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