[Git][ghc/ghc][master] compiler: Store ForeignStubs and foreign C files in interfaces

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Thu Aug 22 14:38:55 UTC 2024



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
821d0a9a by Cheng Shao at 2024-08-22T10:38:22-04:00
compiler: Store ForeignStubs and foreign C files in interfaces

This data is used alongside Core bindings to reconstruct intermediate
build products when linking Template Haskell splices with bytecode.

Since foreign stubs and files are generated in the pipeline, they were
lost with only Core bindings stored in interfaces.

The interface codec type `IfaceForeign` contains a simplified
representation of `ForeignStubs` and the set of foreign sources that
were manually added by the user.

When the backend phase writes an interface, `mkFullIface` calls
`encodeIfaceForeign` to read foreign source file contents and assemble
`IfaceForeign`.

After the recompilation status check of an upstream module,
`initWholeCoreBindings` calls `decodeIfaceForeign` to restore
`ForeignStubs` and write the contents of foreign sources to the file
system as temporary files.
The restored foreign inputs are then processed by `hscInteractive` in
the same manner as in a regular pipeline.

When linking the stub objects for splices, they are excluded from suffix
adjustment for the interpreter way through a new flag in `Unlinked`.

For details about these processes, please consult Note [Foreign stubs
and TH bytecode linking].

Metric Decrease:
    T13701

- - - - -


23 changed files:

- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- testsuite/tests/bytecode/T24634/Hello.hs
- testsuite/tests/bytecode/T24634/Makefile
- + testsuite/tests/bytecode/T24634/T24634a.stdout
- + testsuite/tests/bytecode/T24634/T24634b.stdout
- testsuite/tests/bytecode/T24634/all.T
- testsuite/tests/bytecode/T24634/hello.c → testsuite/tests/bytecode/T24634/hello_c.c
- testsuite/tests/bytecode/T24634/hello.h → testsuite/tests/bytecode/T24634/hello_c.h
- testsuite/tests/count-deps/CountDepsAst.stdout
- testsuite/tests/count-deps/CountDepsParser.stdout


Changes:

=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -135,7 +135,10 @@ module GHC.Cmm.CLabel (
         ppInternalProcLabel,
 
         -- * Others
-        dynamicLinkerLabelInfo
+        dynamicLinkerLabelInfo,
+        CStubLabel (..),
+        cStubLabel,
+        fromCStubLabel,
     ) where
 
 import GHC.Prelude
@@ -1864,3 +1867,42 @@ The transformation is performed because
      T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
 returns True.
 -}
+
+-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign
+-- declarations for the purpose of serializing to interface files.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+data CStubLabel =
+  CStubLabel {
+    csl_is_initializer :: Bool,
+    csl_module :: Module,
+    csl_name :: FastString
+  }
+
+instance Outputable CStubLabel where
+  ppr CStubLabel {csl_is_initializer, csl_module, csl_name} =
+    text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name)
+    where
+      ini = if csl_is_initializer then "initializer" else "finalizer"
+
+-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an
+-- initializer or finalizer.
+cStubLabel :: CLabel -> Maybe CStubLabel
+cStubLabel = \case
+  ModuleLabel csl_module label_kind -> do
+    (csl_is_initializer, csl_name) <- case label_kind of
+      MLK_Initializer (LexicalFastString s) -> Just (True, s)
+      MLK_Finalizer (LexicalFastString s) -> Just (False, s)
+      _ -> Nothing
+    Just (CStubLabel {csl_is_initializer, csl_module, csl_name})
+  _ -> Nothing
+
+-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'.
+fromCStubLabel :: CStubLabel -> CLabel
+fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =
+  ModuleLabel csl_module (label_kind (LexicalFastString csl_name))
+  where
+    label_kind =
+      if csl_is_initializer
+      then MLK_Initializer
+      else MLK_Finalizer


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -968,6 +968,7 @@ loadByteCode iface mod_sum = do
     case mi_extra_decls iface of
       Just extra_decls -> do
           let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
+                   (mi_foreign iface)
           return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))
       _ -> return $ outOfDateItemBecause MissingBytecode Nothing
 --------------------------------------------------------------
@@ -989,30 +990,47 @@ initModDetails hsc_env iface =
     -- in make mode, since this HMI will go into the HPT.
     genModDetails hsc_env' iface
 
--- Hydrate any WholeCoreBindings linkables into BCOs
+-- | If the 'Linkable' contains Core bindings loaded from an interface, replace
+-- them with a lazy IO thunk that compiles them to bytecode and foreign objects.
+--
+-- The laziness is necessary because this value is stored purely in a
+-- 'HomeModLinkable' in the home package table, rather than some dedicated
+-- mutable state that would generate bytecode on demand, so we have to call this
+-- function even when we don't know that we'll need the bytecode.
+--
+-- In addition, the laziness has to be hidden inside 'LazyBCOs' because
+-- 'Linkable' is used too generally, so that looking at the constructor to
+-- decide whether to discard it when linking native code would force the thunk
+-- otherwise, incurring a significant performance penalty.
+--
+-- This is sound because generateByteCode just depends on things already loaded
+-- in the interface file.
 initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (Linkable utc_time this_mod uls) = Linkable utc_time this_mod <$> mapM go uls
+initWholeCoreBindings hsc_env mod_iface details (Linkable utc_time this_mod uls) =
+  Linkable utc_time this_mod <$> mapM go uls
   where
-    go (CoreBindings fi) = do
-        let act hpt  = addToHpt hpt (moduleName $ mi_module mod_iface)
-                                (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
+    go (CoreBindings wcb at WholeCoreBindings {wcb_foreign, wcb_mod_location}) = do
         types_var <- newIORef (md_types details)
-        let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
-        let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
-        -- The bytecode generation itself is lazy because otherwise even when doing
-        -- recompilation checking the bytecode will be generated (which slows things down a lot)
-        -- the laziness is OK because generateByteCode just depends on things already loaded
-        -- in the interface file.
-        LazyBCOs <$> (unsafeInterleaveIO $ do
-                  core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
-                  -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
-                  -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
-                  -- reports a bug.
-                  let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
-                  trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
-                  generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
+        let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
+                      (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
+            kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
+            hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
+        ~(bcos, fos) <- unsafeInterleaveIO $ do
+          core_binds <- initIfaceCheck (text "l") hsc_env' $
+                        typecheckWholeCoreBindings types_var wcb
+          (stubs, foreign_files) <-
+            decodeIfaceForeign logger (hsc_tmpfs hsc_env)
+            (tmpDir (hsc_dflags hsc_env)) wcb_foreign
+          let cgi_guts = CgInteractiveGuts this_mod core_binds
+                         (typeEnvTyCons (md_types details)) stubs foreign_files
+                         Nothing []
+          trace_if logger (text "Generating ByteCode for" <+> ppr this_mod)
+          generateByteCode hsc_env cgi_guts wcb_mod_location
+        pure (LazyBCOs bcos fos)
     go ul = return ul
 
+    logger = hsc_logger hsc_env
+
 {-
 Note [ModDetails and --make mode]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1979,13 +1997,14 @@ data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module
                                            , cgi_binds  :: CoreProgram
                                            , cgi_tycons :: [TyCon]
                                            , cgi_foreign :: ForeignStubs
+                                           , cgi_foreign_files :: [(ForeignSrcLang, FilePath)]
                                            , cgi_modBreaks ::  Maybe ModBreaks
                                            , cgi_spt_entries :: [SptEntry]
                                            }
 
 mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
-mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBreaks, cg_spt_entries}
-  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_modBreaks cg_spt_entries
+mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries}
+  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries
 
 hscInteractive :: HscEnv
                -> CgInteractiveGuts
@@ -2035,20 +2054,18 @@ hscInteractive hsc_env cgguts location = do
         <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
     return (istub_c_exists, comp_bc)
 
+-- | Compile Core bindings and foreign inputs that were loaded from an
+-- interface, to produce bytecode and potential foreign objects for the purpose
+-- of linking splices.
 generateByteCode :: HscEnv
   -> CgInteractiveGuts
   -> ModLocation
-  -> IO (NonEmpty LinkablePart)
+  -> IO (CompiledByteCode, [FilePath])
 generateByteCode hsc_env cgguts mod_location = do
   (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
-
-  stub_o <- case hasStub of
-            Nothing -> return []
-            Just stub_c -> do
-                stub_o <- compileForeign hsc_env LangC stub_c
-                return [DotO stub_o]
-
-  return (BCOs comp_bc :| stub_o)
+  stub_o <- traverse (compileForeign hsc_env LangC) hasStub
+  foreign_files_o <- traverse (uncurry (compileForeign hsc_env)) (cgi_foreign_files cgguts)
+  pure (comp_bc, maybeToList stub_o ++ foreign_files_o)
 
 generateFreshByteCode :: HscEnv
   -> ModuleName
@@ -2057,8 +2074,11 @@ generateFreshByteCode :: HscEnv
   -> IO Linkable
 generateFreshByteCode hsc_env mod_name cgguts mod_location = do
   bco_time <- getCurrentTime
-  bco <- generateByteCode hsc_env cgguts mod_location
-  return $! Linkable bco_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) bco
+  (bcos, fos) <- generateByteCode hsc_env cgguts mod_location
+  return $!
+    Linkable bco_time
+    (mkHomeModule (hsc_home_unit hsc_env) mod_name)
+    (BCOs bcos :| [DotO fo ForeignObject | fo <- fos])
 ------------------------------
 
 hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
@@ -2752,10 +2772,9 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
     deps <- getLinkDeps link_opts interp pls srcspan needed_mods
     -- We update the LinkerState even if the JS interpreter maintains its linker
     -- state independently to load new objects here.
-    let (objs, _bcos) = partition linkableIsNativeCodeOnly
-                          (concatMap partitionLinkable (ldNeededLinkables deps))
 
-    let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
+    let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps)
+        (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
 
     -- FIXME: we should make the JS linker load new_objs here, instead of
     -- on-demand.


=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -96,6 +96,7 @@ import GHC.Runtime.Loader      ( initializePlugins )
 
 import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) )
 import GHC.Types.Error       ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts )
+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))
 import GHC.Types.Target
 import GHC.Types.SrcLoc
 import GHC.Types.SourceFile
@@ -795,9 +796,7 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
   else
     case result of
       HscUpdate iface ->  return (iface, emptyHomeModInfoLinkable)
-      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable
-    -- TODO: Why is there not a linkable?
-    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
+      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing NoStubs []) <*> pure emptyHomeModInfoLinkable
 
 hscGenBackendPipeline :: P m
   => PipeEnv
@@ -816,9 +815,9 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
       -- No object file produced, bytecode or NoBackend
       Nothing -> return mlinkable
       Just o_fp -> do
-        part_time <- liftIO (liftIO getCurrentTime)
-        final_part <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
-        let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton final_part)
+        part_time <- liftIO getCurrentTime
+        final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos)
+        let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject))
         -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
         return (mlinkable { homeMod_object = Just linkable })
   return (miface, final_linkable)
@@ -930,7 +929,7 @@ pipelineStart pipe_env hsc_env input_fn mb_phase =
    as :: P m => Bool -> m (Maybe FilePath)
    as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
 
-   objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk :| []))) = Just lnk
+   objFromLinkable (_, homeMod_object -> Just (Linkable _ _ (DotO lnk _ :| []))) = Just lnk
    objFromLinkable _ = Nothing
 
    fromPhase :: P m => Phase -> m (Maybe FilePath)


=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -21,8 +21,10 @@ import GHC.Driver.Pipeline.Monad
 import GHC.Driver.Pipeline.Phases
 import GHC.Driver.Env hiding (Hsc)
 import GHC.Unit.Module.Location
+import GHC.Unit.Module.ModGuts (cg_foreign, cg_foreign_files)
 import GHC.Driver.Phases
 import GHC.Unit.Types
+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))
 import GHC.Types.SourceFile
 import GHC.Unit.Module.Status
 import GHC.Unit.Module.ModIface
@@ -582,26 +584,28 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
              do
               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
               (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
-
                 hscGenHardCode hsc_env cgguts mod_location output_fn
-              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos
+
+              stub_o <- mapM (compileStub hsc_env) mStub
+              foreign_os <-
+                mapM (uncurry (compileForeign hsc_env)) foreign_files
+              let fos = maybe [] return stub_o ++ foreign_os
+                  (iface_stubs, iface_files)
+                    | gopt Opt_WriteIfSimplifiedCore dflags = (cg_foreign cgguts, cg_foreign_files cgguts)
+                    | otherwise = (NoStubs, [])
+
+              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos iface_stubs iface_files
 
               -- See Note [Writing interface files]
               hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
               mlinkable <-
-                if backendGeneratesCode (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags
+                if gopt Opt_ByteCodeAndObjectCode dflags
                   then do
                     bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
                     return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc }
 
                   else return emptyHomeModInfoLinkable
 
-
-              stub_o <- mapM (compileStub hsc_env) mStub
-              foreign_os <-
-                mapM (uncurry (compileForeign hsc_env)) foreign_files
-              let fos = (maybe [] return stub_o ++ foreign_os)
-
               -- This is awkward, no linkable is produced here because we still
               -- have some way to do before the object file is produced
               -- In future we can split up the driver logic more so that this function
@@ -612,7 +616,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
               -- In interpreted mode the regular codeGen backend is not run so we
               -- generate a interface without codeGen info.
             do
-              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing
+              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing NoStubs []
               hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
               bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
               return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")


=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -167,7 +167,7 @@ to inject the appropriate dependencies.
 -- 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)
+      let ls = ordNubOn linkableModule (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)


=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -53,6 +53,7 @@ import GHC.Driver.Plugins
 
 import GHC.Types.Id
 import GHC.Types.Fixity.Env
+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))
 import GHC.Types.SafeHaskell
 import GHC.Types.Annotations
 import GHC.Types.Name
@@ -88,6 +89,7 @@ import GHC.Unit.Module.ModDetails
 import GHC.Unit.Module.ModGuts
 import GHC.Unit.Module.ModSummary
 import GHC.Unit.Module.Deps
+import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign)
 
 import Data.Function
 import Data.List ( sortBy )
@@ -133,17 +135,20 @@ mkPartialIface hsc_env core_prog mod_details mod_summary import_decls
 -- CmmCgInfos is not available when not generating code (-fno-code), or when not
 -- generating interface pragmas (-fomit-interface-pragmas). See also
 -- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
-mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> IO ModIface
+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos stubs foreign_files = do
     let decls
           | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
           = mi_decls partial_iface
           | otherwise
           = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
 
+    -- See Note [Foreign stubs and TH bytecode linking]
+    foreign_ <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files
+
     full_iface <-
       {-# SCC "addFingerprints" #-}
-      addFingerprints hsc_env (set_mi_decls decls partial_iface)
+      addFingerprints hsc_env $ set_mi_foreign foreign_ $ set_mi_decls decls partial_iface
 
     -- Debug printing
     let unit_state = hsc_units hsc_env
@@ -274,7 +279,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
                    docs mod_summary
                    mod_details
 
-          mkFullIface hsc_env partial_iface Nothing Nothing
+          mkFullIface hsc_env partial_iface Nothing Nothing NoStubs []
 
 mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
          -> Bool -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec]


=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -1241,10 +1241,12 @@ addFingerprints hsc_env iface0
    --   - orphans
    --   - deprecations
    --   - flag abi hash
+   --   - foreign stubs and files
    mod_hash <- computeFingerprint putNameLiterally
                       (map fst sorted_decls,
                        export_hash,  -- includes orphan_hash
-                       mi_warns iface0)
+                       mi_warns iface0,
+                       mi_foreign iface0)
 
    -- The interface hash depends on:
    --   - the ABI hash, plus


=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -258,9 +258,9 @@ typecheckIface iface
     }
 
 typecheckWholeCoreBindings :: IORef TypeEnv ->  WholeCoreBindings -> IfG [CoreBind]
-typecheckWholeCoreBindings type_var (WholeCoreBindings tidy_bindings this_mod _) =
-  initIfaceLcl this_mod (text "typecheckWholeCoreBindings") NotBoot $ do
-    tcTopIfaceBindings type_var tidy_bindings
+typecheckWholeCoreBindings type_var WholeCoreBindings {wcb_bindings, wcb_module} =
+  initIfaceLcl wcb_module (text "typecheckWholeCoreBindings") NotBoot $ do
+    tcTopIfaceBindings type_var wcb_bindings
 
 
 {-


=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -300,7 +300,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
                         return lnk
 
             adjust_part new_osuf part = case part of
-              DotO file -> do
+              DotO file ModuleObject -> do
                 massert (osuf `isSuffixOf` file)
                 let file_base = fromJust (stripExtension osuf file)
                     new_file = file_base <.> new_osuf
@@ -309,12 +309,14 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
                    then dieWith opts span $
                           text "cannot find object file "
                                 <> quotes (text new_file) $$ while_linking_expr
-                   else return (DotO new_file)
+                   else return (DotO new_file ModuleObject)
+              DotO file ForeignObject -> pure (DotO file ForeignObject)
               DotA fp    -> panic ("adjust_ul DotA " ++ show fp)
               DotDLL fp  -> panic ("adjust_ul DotDLL " ++ show fp)
               BCOs {}    -> pure part
               LazyBCOs{} -> pure part
-              CoreBindings (WholeCoreBindings _ mod _) -> pprPanic "Unhydrated core bindings" (ppr mod)
+              CoreBindings WholeCoreBindings {wcb_module} ->
+                pprPanic "Unhydrated core bindings" (ppr wcb_module)
 
 {-
 Note [Using Byte Code rather than Object Code for Template Haskell]


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -32,7 +32,6 @@ module GHC.Linker.Loader
    , rmDupLinkables
    , modifyLoaderState
    , initLinkDepsOpts
-   , partitionLinkable
    )
 where
 
@@ -100,7 +99,6 @@ import Data.Maybe
 import Control.Concurrent.MVar
 import qualified Control.Monad.Catch as MC
 import qualified Data.List.NonEmpty as NE
-import Data.List.NonEmpty (NonEmpty(..))
 
 import System.FilePath
 import System.Directory
@@ -727,8 +725,11 @@ loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (Load
 loadModuleLinkables interp hsc_env pls linkables
   = mask_ $ do  -- don't want to be interrupted by ^C in here
 
-        let (objs, bcos) = partition linkableIsNativeCodeOnly
-                              (concatMap partitionLinkable linkables)
+        debugTraceMsg (hsc_logger hsc_env) 3 $
+          hang (text "Loading module linkables") 2 $ vcat [
+            hang (text "Objects:") 2 (vcat (ppr <$> objs)),
+            hang (text "Bytecode:") 2 (vcat (ppr <$> bcos))
+          ]
 
                 -- Load objects first; they can't depend on BCOs
         (pls1, ok_flag) <- loadObjects interp hsc_env pls objs
@@ -738,16 +739,10 @@ loadModuleLinkables interp hsc_env pls linkables
           else do
                 pls2 <- dynLinkBCOs interp pls1 bcos
                 return (pls2, Succeeded)
+  where
+    (objs, bcos) = partitionLinkables linkables
 
 
--- HACK to support f-x-dynamic in the interpreter; no other purpose
-partitionLinkable :: Linkable -> [Linkable]
-partitionLinkable li = case linkablePartitionParts li of
-  (o:os, bco:bcos) -> [ li { linkableParts = o   :| os }
-                      , li { linkableParts = bco :| bcos }
-                      ]
-  _ -> [li]
-
 linkableInSet :: Linkable -> LinkableSet -> Bool
 linkableInSet l objs_loaded =
   case lookupModuleEnv objs_loaded (linkableModule l) of


=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -30,6 +30,7 @@ module GHC.Linker.Types
    -- * Linkable
    , Linkable(..)
    , LinkablePart(..)
+   , LinkableObjectSort (..)
    , linkableIsNativeCodeOnly
    , linkableObjs
    , linkableLibs
@@ -41,7 +42,9 @@ module GHC.Linker.Types
    , linkablePartAllBCOs
    , isNativeCode
    , isNativeLib
-   , isInterpretable
+   , linkableFilterByteCode
+   , linkableFilterNative
+   , partitionLinkables
    )
 where
 
@@ -63,8 +66,8 @@ import GHC.Unit.Module.Env
 import GHC.Types.Unique.DSet
 import GHC.Types.Unique.DFM
 import GHC.Unit.Module.WholeCoreBindings
-import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (mapMaybe)
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import qualified Data.List.NonEmpty as NE
 
 
@@ -252,10 +255,28 @@ instance Outputable Linkable where
 
 type ObjFile = FilePath
 
+-- | Classify the provenance of @.o@ products.
+data LinkableObjectSort =
+  -- | The object is the final product for a module.
+  -- When linking splices, its file extension will be adapted to the
+  -- interpreter's way if needed.
+  ModuleObject
+  |
+  -- | The object was created from generated code for foreign stubs or foreign
+  -- sources added by the user.
+  -- Its file extension must be preserved, since there are no objects for
+  -- alternative ways available.
+  ForeignObject
+
 -- | Objects which have yet to be linked by the compiler
 data LinkablePart
-  = DotO ObjFile
+  = DotO
+      ObjFile
       -- ^ An object file (.o)
+      LinkableObjectSort
+      -- ^ Whether the object is an internal, intermediate build product that
+      -- should not be adapted to the interpreter's way. Used for foreign stubs
+      -- loaded from interfaces.
 
   | DotA FilePath
       -- ^ Static archive file (.a)
@@ -268,18 +289,22 @@ data LinkablePart
       -- used by some other backend See Note [Interface Files with Core
       -- Definitions]
 
-  | LazyBCOs (NonEmpty LinkablePart)
-    -- ^ Some BCOs generated on-demand when forced. This is used for
-    -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
-    --
-    -- We use `NonEmpty LinkablePart` instead of `CompiledByteCode` because the list
-    -- also contains the stubs objects (DotO) for the BCOs.
+  | LazyBCOs
+      CompiledByteCode
+      -- ^ Some BCOs generated on-demand when forced. This is used for
+      -- WholeCoreBindings, see Note [Interface Files with Core Definitions]
+      [FilePath]
+      -- ^ Objects containing foreign stubs and files
 
   | BCOs CompiledByteCode
     -- ^ A byte-code object, lives only in memory.
 
 instance Outputable LinkablePart where
-  ppr (DotO path)       = text "DotO" <+> text path
+  ppr (DotO path sort)   = text "DotO" <+> text path <+> pprSort sort
+    where
+      pprSort = \case
+        ModuleObject -> empty
+        ForeignObject -> brackets (text "foreign")
   ppr (DotA path)       = text "DotA" <+> text path
   ppr (DotDLL path)     = text "DotDLL" <+> text path
   ppr (BCOs bco)        = text "BCOs" <+> ppr bco
@@ -306,7 +331,7 @@ linkablePartitionParts l = NE.partition isNativeCode (linkableParts l)
 
 -- | List the native objects (.o) of a linkable
 linkableObjs :: Linkable -> [FilePath]
-linkableObjs l = [ f | DotO f <- NE.toList (linkableParts l) ]
+linkableObjs l = concatMap linkablePartObjectPaths (linkableParts l)
 
 -- | List the native libraries (.so/.dll) of a linkable
 linkableLibs :: Linkable -> [LinkablePart]
@@ -314,7 +339,7 @@ linkableLibs l = NE.filter isNativeLib (linkableParts l)
 
 -- | List the paths of the native objects and libraries (.o/.so/.dll)
 linkableFiles :: Linkable -> [FilePath]
-linkableFiles l = mapMaybe linkablePartPath (NE.toList (linkableParts l))
+linkableFiles l = concatMap linkablePartNativePaths (NE.toList (linkableParts l))
 
 -------------------------------------------
 
@@ -338,31 +363,87 @@ isNativeLib = \case
   LazyBCOs{}      -> False
   CoreBindings {} -> False
 
--- | Is this a bytecode linkable with no file on disk?
-isInterpretable :: LinkablePart -> Bool
-isInterpretable = not . isNativeCode
-
 -- | Get the FilePath of linkable part (if applicable)
 linkablePartPath :: LinkablePart -> Maybe FilePath
 linkablePartPath = \case
-  DotO fn         -> Just fn
+  DotO fn _       -> Just fn
   DotA fn         -> Just fn
   DotDLL fn       -> Just fn
   CoreBindings {} -> Nothing
   LazyBCOs {}     -> Nothing
   BCOs {}         -> Nothing
 
+-- | Return the paths of all object code files (.o, .a, .so) contained in this
+-- 'LinkablePart'.
+linkablePartNativePaths :: LinkablePart -> [FilePath]
+linkablePartNativePaths = \case
+  DotO fn _       -> [fn]
+  DotA fn         -> [fn]
+  DotDLL fn       -> [fn]
+  CoreBindings {} -> []
+  LazyBCOs _ fos  -> fos
+  BCOs {}         -> []
+
+-- | Return the paths of all object files (.o) contained in this 'LinkablePart'.
+linkablePartObjectPaths :: LinkablePart -> [FilePath]
+linkablePartObjectPaths = \case
+  DotO fn _ -> [fn]
+  DotA _ -> []
+  DotDLL _ -> []
+  CoreBindings {} -> []
+  LazyBCOs _ fos -> fos
+  BCOs {} -> []
+
 -- | Retrieve the compiled byte-code from the linkable part.
 --
 -- Contrary to linkableBCOs, this includes byte-code from LazyBCOs.
---
--- Warning: this may force byte-code for LazyBCOs.
 linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode]
 linkablePartAllBCOs = \case
   BCOs bco    -> [bco]
-  LazyBCOs ps -> concatMap linkablePartAllBCOs (NE.toList ps)
+  LazyBCOs bcos _ -> [bcos]
   _           -> []
 
+linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable
+linkableFilter f linkable = do
+  new <- nonEmpty (concatMap f (linkableParts linkable))
+  Just linkable {linkableParts = new}
+
+linkablePartNative :: LinkablePart -> [LinkablePart]
+linkablePartNative = \case
+  u at DotO {}  -> [u]
+  u at DotA {} -> [u]
+  u at DotDLL {} -> [u]
+  LazyBCOs _ os -> [DotO f ForeignObject | f <- os]
+  _ -> []
+
+linkablePartByteCode :: LinkablePart -> [LinkablePart]
+linkablePartByteCode = \case
+  u at BCOs {}  -> [u]
+  LazyBCOs bcos _ -> [BCOs bcos]
+  _ -> []
+
+-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only
+-- object code files (.o, .a, .so) without 'LazyBCOs'.
+-- If no 'LinkablePart' remains, return 'Nothing'.
+linkableFilterNative :: Linkable -> Maybe Linkable
+linkableFilterNative = linkableFilter linkablePartNative
+
+-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only byte
+-- code without 'LazyBCOs'.
+-- If no 'LinkablePart' remains, return 'Nothing'.
+linkableFilterByteCode :: Linkable -> Maybe Linkable
+linkableFilterByteCode = linkableFilter linkablePartByteCode
+
+-- | Split the 'LinkablePart' lists in each 'Linkable' into only object code
+-- files (.o, .a, .so) and only byte code, without 'LazyBCOs', and return two
+-- lists containing the nonempty 'Linkable's for each.
+partitionLinkables :: [Linkable] -> ([Linkable], [Linkable])
+partitionLinkables linkables =
+  (
+    mapMaybe linkableFilterNative linkables,
+    mapMaybe linkableFilterByteCode linkables
+  )
+
 {- **********************************************************************
 
                 Loading packages


=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -748,7 +748,8 @@ findObjectLinkableMaybe mod locn
 -- Make an object linkable when we know the object file exists, and we know
 -- its modification time.
 findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
-findObjectLinkable mod obj_fn obj_time = return (Linkable obj_time mod (NE.singleton (DotO obj_fn)))
+findObjectLinkable mod obj_fn obj_time =
+  pure (Linkable obj_time mod (NE.singleton (DotO obj_fn ModuleObject)))
   -- We used to look for _stub.o files here, but that was a bug (#706)
   -- Now GHC merges the stub.o into the main .o (#3687)
 


=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -5,7 +5,8 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
-
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveAnyClass #-}
 
 module GHC.Unit.Module.ModIface
    ( ModIface
@@ -23,6 +24,7 @@ module GHC.Unit.Module.ModIface
       , mi_decls
       , mi_defaults
       , mi_extra_decls
+      , mi_foreign
       , mi_top_env
       , mi_insts
       , mi_fam_insts
@@ -58,6 +60,7 @@ module GHC.Unit.Module.ModIface
    , set_mi_decls
    , set_mi_defaults
    , set_mi_extra_decls
+   , set_mi_foreign
    , set_mi_top_env
    , set_mi_hpc
    , set_mi_trust
@@ -101,6 +104,7 @@ import GHC.Iface.Ext.Fields
 import GHC.Unit
 import GHC.Unit.Module.Deps
 import GHC.Unit.Module.Warnings
+import GHC.Unit.Module.WholeCoreBindings (IfaceForeign (..), emptyIfaceForeign)
 
 import GHC.Types.Avail
 import GHC.Types.Fixity
@@ -114,13 +118,14 @@ import GHC.Types.Unique.DSet
 import GHC.Types.Unique.FM
 
 import GHC.Data.Maybe
+import qualified GHC.Data.Strict as Strict
 
 import GHC.Utils.Fingerprint
 import GHC.Utils.Binary
 
 import Control.DeepSeq
 import Control.Exception
-import qualified GHC.Data.Strict as Strict
+
 
 {- Note [Interface file stages]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -287,6 +292,10 @@ data ModIface_ (phase :: ModIfacePhase)
                 -- combined with mi_decls allows us to restart code generation.
                 -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs]
 
+        mi_foreign_ :: !IfaceForeign,
+                -- ^ Foreign stubs and files to supplement 'mi_extra_decls_'.
+                -- See Note [Foreign stubs and TH bytecode linking]
+
         mi_defaults_ :: [IfaceDefault],
                 -- ^ default declarations exported by the module
 
@@ -461,6 +470,7 @@ instance Binary ModIface where
                  mi_anns_      = anns,
                  mi_decls_     = decls,
                  mi_extra_decls_ = extra_decls,
+                 mi_foreign_   = foreign_,
                  mi_defaults_  = defaults,
                  mi_insts_     = insts,
                  mi_fam_insts_ = fam_insts,
@@ -507,6 +517,7 @@ instance Binary ModIface where
         put_ bh decls
         put_ bh extra_decls
         put_ bh defaults
+        put_ bh foreign_
         put_ bh insts
         put_ bh fam_insts
         lazyPut bh rules
@@ -540,6 +551,7 @@ instance Binary ModIface where
         decls       <- {-# SCC "bin_tycldecls" #-} get bh
         extra_decls <- get bh
         defaults    <- get bh
+        foreign_    <- get bh
         insts       <- {-# SCC "bin_insts" #-} get bh
         fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
         rules       <- {-# SCC "bin_rules" #-} lazyGet bh
@@ -569,6 +581,7 @@ instance Binary ModIface where
                  mi_warns_       = warns,
                  mi_decls_       = decls,
                  mi_extra_decls_ = extra_decls,
+                 mi_foreign_     = foreign_,
                  mi_top_env_     = Nothing,
                  mi_defaults_    = defaults,
                  mi_insts_       = insts,
@@ -624,6 +637,7 @@ emptyPartialModIface mod
         mi_rules_       = [],
         mi_decls_       = [],
         mi_extra_decls_ = Nothing,
+        mi_foreign_     = emptyIfaceForeign,
         mi_top_env_     = Nothing,
         mi_hpc_         = False,
         mi_trust_       = noIfaceTrustInfo,
@@ -677,7 +691,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
   rnf (PrivateModIface
                { mi_module_, mi_sig_of_, mi_hsc_src_, mi_hi_bytes_, mi_deps_, mi_usages_
                , mi_exports_, mi_used_th_, mi_fixities_, mi_warns_, mi_anns_
-               , mi_decls_, mi_defaults_, mi_extra_decls_, mi_top_env_, mi_insts_
+               , mi_decls_, mi_defaults_, mi_extra_decls_, mi_foreign_, mi_top_env_, mi_insts_
                , mi_fam_insts_, mi_rules_, mi_hpc_, mi_trust_, mi_trust_pkg_
                , mi_complete_matches_, mi_docs_, mi_final_exts_
                , mi_ext_fields_, mi_src_hash_ })
@@ -695,6 +709,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
     `seq` rnf mi_decls_
     `seq` rnf mi_defaults_
     `seq` rnf mi_extra_decls_
+    `seq` rnf mi_foreign_
     `seq` rnf mi_top_env_
     `seq` rnf mi_insts_
     `seq` rnf mi_fam_insts_
@@ -861,6 +876,9 @@ set_mi_defaults val iface = clear_mi_hi_bytes $ iface { mi_defaults_ = val }
 set_mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> ModIface_ phase -> ModIface_ phase
 set_mi_extra_decls val iface = clear_mi_hi_bytes $ iface { mi_extra_decls_ = val }
 
+set_mi_foreign :: IfaceForeign -> ModIface_ phase -> ModIface_ phase
+set_mi_foreign foreign_ iface = clear_mi_hi_bytes $ iface { mi_foreign_ = foreign_ }
+
 set_mi_top_env :: Maybe IfaceTopEnv -> ModIface_ phase -> ModIface_ phase
 set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val }
 
@@ -957,6 +975,7 @@ However, with the pragma, the correct core is generated:
 {-# INLINE mi_anns #-}
 {-# INLINE mi_decls #-}
 {-# INLINE mi_extra_decls #-}
+{-# INLINE mi_foreign #-}
 {-# INLINE mi_top_env #-}
 {-# INLINE mi_insts #-}
 {-# INLINE mi_fam_insts #-}
@@ -975,7 +994,8 @@ However, with the pragma, the correct core is generated:
 pattern ModIface ::
   Module -> Maybe Module -> HscSource -> Dependencies -> [Usage] ->
   [IfaceExport] -> Bool -> [(OccName, Fixity)] -> IfaceWarnings ->
-  [IfaceAnnotation] -> [IfaceDeclExts phase] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] ->
+  [IfaceAnnotation] -> [IfaceDeclExts phase] ->
+  Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IfaceForeign ->
   [IfaceDefault] -> Maybe IfaceTopEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] ->
   AnyHpcUsage -> IfaceTrustInfo -> Bool -> [IfaceCompleteMatch] -> Maybe Docs ->
   IfaceBackendExts phase -> ExtensibleFields -> Fingerprint -> IfaceBinHandle phase ->
@@ -993,6 +1013,7 @@ pattern ModIface
   , mi_anns
   , mi_decls
   , mi_extra_decls
+  , mi_foreign
   , mi_defaults
   , mi_top_env
   , mi_insts
@@ -1020,6 +1041,7 @@ pattern ModIface
     , mi_anns_ = mi_anns
     , mi_decls_ = mi_decls
     , mi_extra_decls_ = mi_extra_decls
+    , mi_foreign_ = mi_foreign
     , mi_defaults_ = mi_defaults
     , mi_top_env_ = mi_top_env
     , mi_insts_ = mi_insts


=====================================
compiler/GHC/Unit/Module/WholeCoreBindings.hs
=====================================
@@ -1,8 +1,30 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
 module GHC.Unit.Module.WholeCoreBindings where
 
-import GHC.Unit.Types (Module)
-import GHC.Unit.Module.Location
+import GHC.Cmm.CLabel
+import GHC.Driver.DynFlags (DynFlags (targetPlatform), initSDocContext)
+import GHC.ForeignSrcLang (ForeignSrcLang (..))
 import GHC.Iface.Syntax
+import GHC.Prelude
+import GHC.Types.ForeignStubs
+import GHC.Unit.Module.Location
+import GHC.Unit.Types (Module)
+import GHC.Utils.Binary
+import GHC.Utils.Error (debugTraceMsg)
+import GHC.Utils.Logger (Logger)
+import GHC.Utils.Outputable
+import GHC.Utils.Panic (panic, pprPanic)
+import GHC.Utils.TmpFs
+
+import Control.DeepSeq (NFData (..))
+import Data.Traversable (for)
+import Data.Word (Word8)
+import Data.Maybe (fromMaybe)
+import System.FilePath (takeExtension)
 
 {-
 Note [Interface Files with Core Definitions]
@@ -60,4 +82,379 @@ data WholeCoreBindings = WholeCoreBindings
             { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings.
             , wcb_module   :: Module  -- ^ The module which the bindings are for
             , wcb_mod_location :: ModLocation -- ^ The location where the sources reside.
+              -- | Stubs for foreign declarations and files added via
+              -- 'GHC.Internal.TH.Syntax.addForeignFilePath'.
+            , wcb_foreign :: IfaceForeign
             }
+
+{-
+Note [Foreign stubs and TH bytecode linking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Foreign declarations may introduce additional build products called "stubs" that
+contain wrappers for the exposed functions.
+For example, consider a foreign import of a C function named @main_loop@ from
+the file @bindings.h@ in the module @CLibrary@:
+
+@
+foreign import capi "bindings.h main_loop" mainLoop :: IO Int
+@
+
+GHC will generate a snippet of C code containing a wrapper:
+
+@
+#include "bindings.h"
+HsInt ghczuwrapperZC0ZCmainZCCLibraryZCmainzuloop(void) {return main_loop();}
+@
+
+Wrappers like these are generated as 'ForeignStubs' by the desugarer in
+'dsForeign' and stored in the various @*Guts@ types; until they are compiled to
+temporary object files in 'runHscBackendPhase' during code generation and
+ultimately merged into the final object file for the module, @CLibrary.o at .
+
+This creates some problems with @-fprefer-byte-code@, which allows splices to
+execute bytecode instead of native code for dependencies that provide it.
+Usually, when some TH code depends on @CLibrary@, the linker would look for
+ at CLibrary.o@ and load that before executing the splice, but with this flag, it
+will first attempt to load bytecode from @CLibrary.hi@ and compile it in-memory.
+
+Problem 1:
+
+Code for splices is loaded from interfaces in the shape of Core bindings
+(see 'WholeCoreBindings'), rather than from object files.
+Those Core bindings are intermediate build products that do not contain the
+module's stubs, since those are separated from the Haskell code before Core is
+generated and only compiled and linked into the final object when native code is
+generated.
+
+Therefore, stubs have to be stored separately in interface files.
+Unfortunately, the type 'ForeignStubs' contains 'CLabel', which is a huge type
+with several 'Unique's used mainly by C--.
+Luckily, the only constructor used for foreign stubs is 'ModuleLabel', which
+contains the name of a foreign declaration's initializer, if it has one.
+So we convert a 'CLabel' to 'CStubLabel' in 'encodeIfaceForeign' and store only
+the simplified data.
+
+Problem 2:
+
+Given module B, which contains a splice that executes code from module A, both
+in the home package, consider these different circumstances:
+
+1. In make mode, both modules are recompiled
+2. In make mode, only B is recompiled
+3. In oneshot mode, B is compiled
+
+In case 1, 'runHscBackendPhase' directly generates bytecode from the 'CgGuts'
+that the main pipeline produced and stores it in the 'HomeModLinkable' that is
+one of its build products.
+The stubs are merged into a single object and added to the 'HomeModLinkable' in
+'hscGenBackendPipeline'.
+
+In case 2, 'hscRecompStatus' short-circuits the pipeline while checking A, since
+the module is up to date.
+Nevertheless, it calls 'checkByteCode', which extracts Core bindings from A's
+interface and adds them to the 'HomeModLinkable'.
+No stubs are generated in this case, since the desugarer wasn't run!
+
+In both of these cases, 'compileOne'' proceeds to call 'initWholeCoreBindings',
+applied to the 'HomeModLinkable', to compile Core bindings (lazily) to bytecode,
+which is then written back to the 'HomeModLinkable'.
+If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op.
+Otherwise, the stub objects from the interface are compiled to objects in
+'generateByteCode' and added to the 'HomeModLinkable' as well.
+
+Case 3 is not implemented yet (!13042).
+
+Problem 3:
+
+In all three cases, the final step before splice execution is linking.
+
+The function 'getLinkDeps' is responsible for assembling all of a splice's
+dependencies, looking up imported modules in the HPT and EPS, collecting all
+'HomeModLinkable's and object files that it can find.
+
+However, since splices are executed in the interpreter, the 'Way' of the current
+build may differ from the interpreter's.
+For example, the current GHC invocation might be building a static binary, but
+the internal interpreter requires dynamic linking; or profiling might be
+enabled.
+To adapt to the interpreter's 'Way', 'getLinkDeps' substitutes all object files'
+extensions with that corresponding to that 'Way' – e.g. changing @.o@ to
+ at .dyn_o@, which requires dependencies to be built with @-dynamic[-too]@, which
+in turn is enforced after downsweep in 'GHC.Driver.Make.enableCodeGenWhen'.
+
+This doesn't work for stub objects, though – they are compiled to temporary
+files with mismatching names, so simply switching out the suffix would refer to
+a nonexisting file.
+Even if that wasn't an issue, they are compiled for the session's 'Way', not its
+associated module's, so the dynamic variant wouldn't be available when building
+only static outputs.
+
+For now, this doesn't have much of an impact, since we're only supporting
+foreign imports initially, which produce very simple objects that can easily be
+handled by the linker when 'GHC.Linker.Loader.dynLoadObjs' creates a shared
+library from all object file inputs.
+However, for more complex circumstances, we should compile foreign stubs
+specially for TH according to the interpreter 'Way', or request dynamic products
+for TH dependencies like it happens for the conventional case.
+
+Problem 4:
+
+Foreign code may have dependencies on Haskell code.
+
+Both foreign exports and @StaticPointers@ produce stubs that contain @extern@
+declarations of values referring to STG closures.
+When those stub objects are loaded, the undefined symbols need to be provided to
+the linker.
+
+I have no insight into how this works, and whether we could provide the memory
+address of a BCO as a ccall symbol while linking, so it's unclear at the moment
+what to do about this.
+
+In addition to that, those objects would also have to be loaded _after_
+bytecode, and therefore 'DotO' would have to be marked additionally to separate
+them from those that are loaded before.
+If mutual dependencies between BCOs and foreign code are possible, this will be
+much more diffcult though.
+
+Problem 5:
+
+TH allows splices to add arbitrary files as additional linker inputs.
+
+Using the method `qAddForeignFilePath`, a foreign source file or a precompiled
+object file can be added to the current modules dependencies.
+These files will be processed by the pipeline and linked into the final object.
+
+Since the files may be temporarily created from a string, we have to read their
+contents in 'encodeIfaceForeign' and store them in the interface as well, and
+write them to temporary files when loading bytecode in 'decodeIfaceForeign'.
+-}
+
+-- | Wrapper for avoiding a dependency on 'Binary' and 'NFData' in 'CLabel'.
+newtype IfaceCLabel = IfaceCLabel CStubLabel
+
+instance Binary IfaceCLabel where
+  get bh = do
+    csl_is_initializer <- get bh
+    csl_module <- get bh
+    csl_name <- get bh
+    pure (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name})
+
+  put_ bh (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = do
+    put_ bh csl_is_initializer
+    put_ bh csl_module
+    put_ bh csl_name
+
+instance NFData IfaceCLabel where
+  rnf (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) =
+    rnf csl_is_initializer `seq` rnf csl_module `seq` rnf csl_name
+
+instance Outputable IfaceCLabel where
+  ppr (IfaceCLabel l) = ppr l
+
+-- | Simplified encoding of 'GHC.Types.ForeignStubs.ForeignStubs' for interface
+-- serialization.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+data IfaceCStubs =
+  IfaceCStubs {
+    header :: String,
+    source :: String,
+    initializers :: [IfaceCLabel],
+    finalizers :: [IfaceCLabel]
+  }
+
+instance Outputable IfaceCStubs where
+  ppr IfaceCStubs {header, source, initializers, finalizers} =
+    vcat [
+      hang (text "header:") 2 (vcat (text <$> lines header)),
+      hang (text "source:") 2 (vcat (text <$> lines source)),
+      hang (text "initializers:") 2 (ppr initializers),
+      hang (text "finalizers:") 2 (ppr finalizers)
+    ]
+
+-- | 'Binary' 'put_' for 'ForeignSrcLang'.
+binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO ()
+binary_put_ForeignSrcLang bh lang =
+  put_ @Word8 bh $ case lang of
+    LangC -> 0
+    LangCxx -> 1
+    LangObjc -> 2
+    LangObjcxx -> 3
+    LangAsm -> 4
+    LangJs -> 5
+    RawObject -> 6
+
+-- | 'Binary' 'get' for 'ForeignSrcLang'.
+binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang
+binary_get_ForeignSrcLang bh = do
+  b <- getByte bh
+  pure $ case b of
+    0 -> LangC
+    1 -> LangCxx
+    2 -> LangObjc
+    3 -> LangObjcxx
+    4 -> LangAsm
+    5 -> LangJs
+    6 -> RawObject
+    _ -> panic "invalid Binary value for ForeignSrcLang"
+
+instance Binary IfaceCStubs where
+  get bh = do
+    header <- get bh
+    source <- get bh
+    initializers <- get bh
+    finalizers <- get bh
+    pure IfaceCStubs {..}
+
+  put_ bh IfaceCStubs {..} = do
+    put_ bh header
+    put_ bh source
+    put_ bh initializers
+    put_ bh finalizers
+
+instance NFData IfaceCStubs where
+  rnf IfaceCStubs {..} =
+    rnf header
+    `seq`
+    rnf source
+    `seq`
+    rnf initializers
+    `seq`
+    rnf finalizers
+
+-- | A source file added from Template Haskell using 'qAddForeignFilePath', for
+-- storage in interfaces.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+data IfaceForeignFile =
+  IfaceForeignFile {
+    -- | The language is specified by the user.
+    lang :: ForeignSrcLang,
+
+    -- | The contents of the file, which will be written to a temporary file
+    -- when loaded from an interface.
+    source :: String,
+
+    -- | The extension used by the user is preserved, to avoid confusing
+    -- external tools with an unexpected @.c@ file or similar.
+    extension :: FilePath
+  }
+
+instance Outputable IfaceForeignFile where
+  ppr IfaceForeignFile {lang, source} =
+    hang (text (show lang) <> colon) 2 (vcat (text <$> lines source))
+
+instance Binary IfaceForeignFile where
+  get bh = do
+    lang <- binary_get_ForeignSrcLang bh
+    source <- get bh
+    extension <- get bh
+    pure IfaceForeignFile {lang, source, extension}
+
+  put_ bh IfaceForeignFile {lang, source, extension} = do
+    binary_put_ForeignSrcLang bh lang
+    put_ bh source
+    put_ bh extension
+
+instance NFData IfaceForeignFile where
+  rnf IfaceForeignFile {lang, source, extension} =
+    lang `seq` rnf source `seq` rnf extension
+
+data IfaceForeign =
+  IfaceForeign {
+    stubs :: Maybe IfaceCStubs,
+    files :: [IfaceForeignFile]
+  }
+
+instance Outputable IfaceForeign where
+  ppr IfaceForeign {stubs, files} =
+    hang (text "stubs:") 2 (maybe (text "empty") ppr stubs) $$
+    vcat (ppr <$> files)
+
+emptyIfaceForeign :: IfaceForeign
+emptyIfaceForeign = IfaceForeign {stubs = Nothing, files = []}
+
+-- | Convert foreign stubs and foreign files to a format suitable for writing to
+-- interfaces.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+encodeIfaceForeign ::
+  Logger ->
+  DynFlags ->
+  ForeignStubs ->
+  [(ForeignSrcLang, FilePath)] ->
+  IO IfaceForeign
+encodeIfaceForeign logger dflags foreign_stubs lang_paths = do
+  files <- read_foreign_files
+  stubs <- encode_stubs foreign_stubs
+  let iff = IfaceForeign {stubs, files}
+  debugTraceMsg logger 3 $
+    hang (text "Encoding foreign data for iface:") 2 (ppr iff)
+  pure iff
+  where
+    -- We can't just store the paths, since files may have been generated with
+    -- GHC session lifetime in 'GHC.Internal.TH.Syntax.addForeignSource'.
+    read_foreign_files =
+      for lang_paths $ \ (lang, path) -> do
+        source <- readFile path
+        pure IfaceForeignFile {lang, source, extension = takeExtension path}
+
+    encode_stubs = \case
+      NoStubs ->
+        pure Nothing
+      ForeignStubs (CHeader header) (CStub source inits finals) ->
+        pure $ Just IfaceCStubs {
+          header = render header,
+          source = render source,
+          initializers = encode_label <$> inits,
+          finalizers = encode_label <$> finals
+        }
+
+    encode_label clabel =
+      fromMaybe (invalid_label clabel) (IfaceCLabel <$> cStubLabel clabel)
+
+    invalid_label clabel =
+      pprPanic
+      "-fwrite-if-simplified-core is incompatible with this foreign stub:"
+      (pprCLabel (targetPlatform dflags) clabel)
+
+    render = renderWithContext (initSDocContext dflags PprCode)
+
+-- | Decode serialized foreign stubs and foreign files.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+decodeIfaceForeign ::
+  Logger ->
+  TmpFs ->
+  TempDir ->
+  IfaceForeign ->
+  IO (ForeignStubs, [(ForeignSrcLang, FilePath)])
+decodeIfaceForeign logger tmpfs tmp_dir iff at IfaceForeign {stubs, files} = do
+  debugTraceMsg logger 3 $
+    hang (text "Decoding foreign data from iface:") 2 (ppr iff)
+  lang_paths <- for files $ \ IfaceForeignFile {lang, source, extension} -> do
+    f <- newTempName logger tmpfs tmp_dir TFL_GhcSession extension
+    writeFile f source
+    pure (lang, f)
+  pure (maybe NoStubs decode_stubs stubs, lang_paths)
+  where
+    decode_stubs IfaceCStubs {header, source, initializers, finalizers} =
+      ForeignStubs
+      (CHeader (text header))
+      (CStub (text source) (labels initializers) (labels finalizers))
+
+    labels ls = [fromCStubLabel l | IfaceCLabel l <- ls]
+
+instance Binary IfaceForeign where
+  get bh = do
+    stubs <- get bh
+    files <- get bh
+    pure IfaceForeign {stubs, files}
+
+  put_ bh IfaceForeign {stubs, files} = do
+    put_ bh stubs
+    put_ bh files
+
+instance NFData IfaceForeign where
+  rnf IfaceForeign {stubs, files} = rnf stubs `seq` rnf files


=====================================
testsuite/tests/bytecode/T24634/Hello.hs
=====================================
@@ -7,10 +7,15 @@ module Hello where
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 
-foreign import capi "hello.h say_hello" say_hello :: IO Int
+foreign import capi "hello_c.h say_hello" say_hello :: IO Int
+
+foreign import ccall fromForeignFile :: Int -> IO Int
+
+[] <$ addForeignSource LangC "int fromForeignFile(int x) { return x * 23; }"
 
 mkHello :: DecsQ
 mkHello = do
   n <- runIO say_hello
+  m <- runIO (fromForeignFile n)
   [d| hello :: IO Int
-      hello = return $(lift n) |]
+      hello = return $(lift m) |]


=====================================
testsuite/tests/bytecode/T24634/Makefile
=====================================
@@ -2,8 +2,16 @@ TOP=../../..
 include $(TOP)/mk/boilerplate.mk
 include $(TOP)/mk/test.mk
 
-bytecode-capi:
-	$(TEST_HC) -c hello.c
-	$(TEST_HC) -c -fbyte-code-and-object-code Hello.hs
-	$(TEST_HC) -fprefer-byte-code hello.o Main.hs
+# This case loads bytecode from the interface file written in the second invocation.
+T24634a:
+	$(TEST_HC) -c hello_c.c -o hello_c.o
+	$(TEST_HC) -c -fbyte-code-and-object-code -fno-omit-interface-pragmas Hello.hs
+	$(TEST_HC) -fprefer-byte-code -fbyte-code-and-object-code -fno-ignore-interface-pragmas hello_c.o Main.hs
+	./Main
+
+# This case uses the bytecode generated in 'runHscBackendPhase', not involving the interface, since 'Hello' is compiled
+# in the same invocation as 'Main'.
+T24634b:
+	$(TEST_HC) -c hello_c.c -o hello_c.o
+	$(TEST_HC) -fprefer-byte-code -fbyte-code-and-object-code -fno-ignore-interface-pragmas hello_c.o Hello.hs Main.hs
 	./Main


=====================================
testsuite/tests/bytecode/T24634/T24634a.stdout
=====================================
@@ -0,0 +1,3 @@
+[2 of 3] Compiling Main             ( Main.hs, Main.o, interpreted )
+[3 of 3] Linking Main
+966


=====================================
testsuite/tests/bytecode/T24634/T24634b.stdout
=====================================
@@ -0,0 +1,4 @@
+[1 of 3] Compiling Hello            ( Hello.hs, Hello.o, interpreted )
+[2 of 3] Compiling Main             ( Main.hs, Main.o, interpreted )
+[3 of 3] Linking Main
+966


=====================================
testsuite/tests/bytecode/T24634/all.T
=====================================
@@ -1,7 +1,11 @@
-test('T24634',
-     [extra_files(['hello.h', 'hello.c', 'Hello.hs', 'Main.hs']),
-      req_interp,
-      expect_broken(24634),
+def test_T24634(name):
+    return test(name,
+     [extra_files(['hello_c.h', 'hello_c.c', 'Hello.hs', 'Main.hs']),
+      req_c,
+      req_th,
       ],
      makefile_test,
-     [''])
+     [])
+
+test_T24634('T24634a')
+test_T24634('T24634b')


=====================================
testsuite/tests/bytecode/T24634/hello.c → testsuite/tests/bytecode/T24634/hello_c.c
=====================================
@@ -1,4 +1,4 @@
-#include "hello.h"
+#include "hello_c.h"
 
 int say_hello() {
   return 42;


=====================================
testsuite/tests/bytecode/T24634/hello.h → testsuite/tests/bytecode/T24634/hello_c.h
=====================================


=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -197,6 +197,7 @@ GHC.Unit.Module.Imported
 GHC.Unit.Module.Location
 GHC.Unit.Module.ModIface
 GHC.Unit.Module.Warnings
+GHC.Unit.Module.WholeCoreBindings
 GHC.Unit.Parser
 GHC.Unit.Ppr
 GHC.Unit.State


=====================================
testsuite/tests/count-deps/CountDepsParser.stdout
=====================================
@@ -221,6 +221,7 @@ GHC.Unit.Module.Location
 GHC.Unit.Module.ModIface
 GHC.Unit.Module.ModSummary
 GHC.Unit.Module.Warnings
+GHC.Unit.Module.WholeCoreBindings
 GHC.Unit.Parser
 GHC.Unit.Ppr
 GHC.Unit.State



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/821d0a9ac2cc2fdfd3eef66a8e77838a11bd8ac8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/821d0a9ac2cc2fdfd3eef66a8e77838a11bd8ac8
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240822/e5b5cca5/attachment-0001.html>


More information about the ghc-commits mailing list