[Git][ghc/ghc][wip/torsten.schmits/bc-stubs-dyn] 3 commits: Store ForeignStubs and foreign C files in interfaces
Torsten Schmits (@torsten.schmits)
gitlab at gitlab.haskell.org
Wed Aug 14 16:34:06 UTC 2024
Torsten Schmits pushed to branch wip/torsten.schmits/bc-stubs-dyn at Glasgow Haskell Compiler / GHC
Commits:
e60615ee by Torsten Schmits at 2024-08-14T18:30:52+02:00
Store ForeignStubs and foreign C files in interfaces
Metric Decrease:
T13701
- - - - -
16d333c4 by Torsten Schmits at 2024-08-14T18:30:52+02:00
normalize the API for Linkable and Unlinked a bit
- - - - -
9b0cd16f by Torsten Schmits at 2024-08-14T18:33:28+02:00
build dynamic deps even when linking bc for TH
- - - - -
29 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.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/Runtime/Interpreter.hs
- compiler/GHC/Unit/Home/ModInfo.hs
- compiler/GHC/Unit/Module/ModIface.hs
- compiler/GHC/Unit/Module/WholeCoreBindings.hs
- ghc/GHCi/Leak.hs
- libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- testsuite/tests/bytecode/T24634/Hello.hs
- testsuite/tests/bytecode/T24634/Makefile
- testsuite/tests/bytecode/T24634/T24634.stdout → testsuite/tests/bytecode/T24634/T24634a.stdout
- + testsuite/tests/bytecode/T24634/T24634b.stdout
- testsuite/tests/bytecode/T24634/all.T
- 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/Backpack.hs
=====================================
@@ -346,8 +346,7 @@ buildUnit session cid insts lunit = do
linkables = map (expectJust "bkp link" . homeModInfoObject)
. filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
$ home_mod_infos
- getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
- obj_files = concatMap getOfiles linkables
+ obj_files = concatMap linkableObjectCodePaths linkables
state = hsc_units hsc_env
let compat_fs = unitIdFS cid
=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -5,12 +5,14 @@
-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Driver.CodeOutput
( codeOutput
, outputForeignStubs
, profilingInitCode
, ipInitCode
+ , renderForeignStubs
)
where
@@ -63,6 +65,7 @@ import System.FilePath
import System.IO
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Traversable (for)
{-
************************************************************************
@@ -256,16 +259,33 @@ outputForeignStubs
-> Module
-> ModLocation
-> ForeignStubs
- -> IO (Bool, -- Header file created
+ -> IO (Bool, -- Header file created
Maybe FilePath) -- C file created
-outputForeignStubs logger tmpfs dflags unit_state mod location stubs
- = do
- let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
- stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
-
- case stubs of
+outputForeignStubs logger tmpfs dflags unit_state mod location stubs = do
+ (stub_h_rendered, stub_c_rendered) <-
+ renderForeignStubs logger dflags unit_state stubs
+ createDirectoryIfMissing True (takeDirectory stub_h)
+ stub_h_result <- case stub_h_rendered of
+ Just content -> True <$ writeFile stub_h content
+ Nothing -> pure False
+ stub_c_result <- for stub_c_rendered $ \ content -> do
+ stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
+ writeFile stub_c content
+ pure stub_c
+ pure (stub_h_result, stub_c_result)
+ where
+ stub_h = unsafeDecodeUtf $
+ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+
+renderForeignStubs
+ :: Logger
+ -> DynFlags
+ -> UnitState
+ -> ForeignStubs
+ -> IO (Maybe String, Maybe String)
+renderForeignStubs logger dflags unit_state = \case
NoStubs ->
- return (False, Nothing)
+ return (Nothing, Nothing)
ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do
let
@@ -276,8 +296,6 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
stub_h_output_d = pprCode h_code
stub_h_output_w = showSDoc dflags stub_h_output_d
- createDirectoryIfMissing True (takeDirectory stub_h)
-
putDumpFileMaybe logger Opt_D_dump_foreign
"Foreign export header file"
FormatC
@@ -299,15 +317,14 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
| platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"
| otherwise = ""
- stub_h_file_exists
- <- outputForeignStubs_help stub_h stub_h_output_w
+ stub_h_rendered = render_nonempty stub_h_output_w
("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
putDumpFileMaybe logger Opt_D_dump_foreign
"Foreign export stubs" FormatC stub_c_output_d
- stub_c_file_exists
- <- outputForeignStubs_help stub_c stub_c_output_w
+ let
+ stub_c_rendered = render_nonempty stub_c_output_w
("#define IN_STG_CODE 0\n" ++
"#include <Rts.h>\n" ++
rts_includes ++
@@ -318,21 +335,19 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs
-- isn't really HC code, so we need to define IN_STG_CODE==0 to
-- avoid the register variables etc. being enabled.
- return (stub_h_file_exists, if stub_c_file_exists
- then Just stub_c
- else Nothing )
+ return (stub_h_rendered, stub_c_rendered)
where
cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
+ -- It is more than likely that the stubs file will
+ -- turn out to be empty, in which case no file should be created.
+ render_nonempty doc_str header footer
+ | null doc_str
+ = Nothing
+ | otherwise
+ = Just (header ++ doc_str ++ '\n':footer ++ "\n")
--- It is more than likely that the stubs file will
--- turn out to be empty, in which case no file should be created.
-outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
-outputForeignStubs_help _fname "" _header _footer = return False
-outputForeignStubs_help fname doc_str header footer
- = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
- return True
-- -----------------------------------------------------------------------------
-- Initialising cost centres
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -292,8 +292,6 @@ import GHC.Types.TypeEnv
import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
-import Data.Traversable
-import qualified Data.ByteString as BS
import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
@@ -958,8 +956,8 @@ checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated
checkByteCode iface mod_sum mb_old_linkable =
case mb_old_linkable of
Just old_linkable
- | not (isObjectLinkable old_linkable)
- -> return $ (UpToDateItem old_linkable)
+ | linkableContainsByteCode old_linkable
+ -> return (UpToDateItem old_linkable)
_ -> loadByteCode iface mod_sum
loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
@@ -970,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 (LM if_date this_mod [CoreBindings fi]))
_ -> return $ outOfDateItemBecause MissingBytecode Nothing
--------------------------------------------------------------
@@ -993,34 +992,31 @@ initModDetails hsc_env iface =
-- Hydrate any WholeCoreBindings linkables into BCOs
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do
- -- If a module is compiled with -fbyte-code-and-object-code and it
- -- makes use of foreign stubs, then the interface file will also
- -- contain serialized stub dynamic objects, and we can simply write
- -- them to temporary objects and refer to them as unlinked items
- -- directly.
- stub_uls <- for (mi_stub_objs mod_iface) $ \stub_obj -> do
- f <- newTempName (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (tmpDir (hsc_dflags hsc_env)) TFL_GhcSession "dyn_o"
- BS.writeFile f stub_obj
- pure $ DotO f
- bytecode_uls <- for uls go
- pure $ LM utc_time this_mod $ stub_uls ++ bytecode_uls
+initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) =
+ LM 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
+ -- If a module is compiled with -fbyte-code-and-object-code and it makes
+ -- use of foreign stubs, then the interface file will also contain
+ -- serialized stub objects, and we can simply write them to temporary
+ -- objects and refer to them as unlinked items directly.
+ -- See Note [Foreign stubs and TH bytecode linking]
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 }
+ 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 }
-- 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.
- LoadedBCOs <$> (unsafeInterleaveIO $ do
- core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
- 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))
+ ~(bcos, fos) <- unsafeInterleaveIO $ do
+ core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var wcb
+ (stubs, foreign_files) <- decodeIfaceForeign (hsc_logger hsc_env) (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 (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
+ generateByteCode hsc_env cgi_guts wcb_mod_location
+ pure (LoadedBCOs bcos fos)
go ul = return ul
{-
@@ -1989,13 +1985,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
@@ -2047,21 +2044,12 @@ hscInteractive hsc_env cgguts location = do
generateByteCode :: HscEnv
-> CgInteractiveGuts
-> ModLocation
- -> IO [Unlinked]
+ -> IO (Unlinked, [FilePath])
generateByteCode hsc_env cgguts mod_location = do
(hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
-
- stub_o <- case hasStub of
- Nothing -> return []
- Just stub_c -> do
- -- Always compile foreign stubs as shared objects so
- -- they can be properly loaded later when the bytecode
- -- is loaded.
- stub_o <- compileForeign (hscUpdateFlags setDynamicNow hsc_env) LangC stub_c
- return [DotO stub_o]
-
- let hs_unlinked = [BCOs comp_bc spt_entries]
- return (hs_unlinked ++ stub_o)
+ stub_o <- traverse (compileForeign hsc_env LangC) hasStub
+ foreign_files_o <- traverse (uncurry (compileForeign hsc_env)) (cgi_foreign_files cgguts)
+ pure (BCOs comp_bc spt_entries, maybeToList stub_o ++ foreign_files_o)
generateFreshByteCode :: HscEnv
-> ModuleName
@@ -2069,10 +2057,9 @@ generateFreshByteCode :: HscEnv
-> ModLocation
-> IO Linkable
generateFreshByteCode hsc_env mod_name cgguts mod_location = do
- ul <- generateByteCode hsc_env cgguts mod_location
+ (bcos, fos) <- generateByteCode hsc_env cgguts mod_location
unlinked_time <- getCurrentTime
- let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul
- return linkable
+ return (LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) (bcos : (DotO <$> fos)))
------------------------------
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
@@ -2762,8 +2749,7 @@ 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 isObjectLinkable
- (concatMap partitionLinkable (ldNeededLinkables deps))
+ let objs = mapMaybe linkableFilterObjectCode (ldNeededLinkables deps)
let (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1321,9 +1321,12 @@ addSptEntries hsc_env mlinkable =
[ spt
| Just linkable <- [mlinkable]
, unlinked <- linkableUnlinked linkable
- , BCOs _ spts <- pure unlinked
+ , spts <- bco_spts unlinked
, spt <- spts
]
+ where
+ bco_spts (BCOs _ spts) = [spts]
+ bco_spts _ = []
{- Note [-fno-code mode]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1916,20 +1919,15 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-- the linker can correctly load the object files. This isn't necessary
-- when using -fexternal-interpreter.
- dynamic_too_enable enable_spec ms
+ dynamic_too_enable _ ms
= hostIsDynamic && not hostIsProfiled && internalInterpreter &&
not isDynWay && not isProfWay && not dyn_too_enabled
- && enable_object
where
lcl_dflags = ms_hspp_opts ms
internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags
isDynWay = hasWay (ways lcl_dflags) WayDyn
isProfWay = hasWay (ways lcl_dflags) WayProf
- enable_object = case enable_spec of
- EnableByteCode -> False
- EnableByteCodeAndObject -> True
- EnableObject -> True
-- #16331 - when no "internal interpreter" is available but we
-- need to process some TemplateHaskell or QuasiQuotes, we automatically
=====================================
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
@@ -421,8 +422,7 @@ link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt
return Succeeded
else do
- let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
- obj_files = concatMap getOfiles linkables
+ let obj_files = concatMap linkableObjectCodePaths linkables
platform = targetPlatform dflags
arch_os = platformArchOS platform
exe_file = exeFileName arch_os staticLink (outputFile_ dflags)
@@ -778,7 +778,7 @@ hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction
hscBackendPipeline pipe_env hsc_env mod_sum result =
if backendGeneratesCode (backend (hsc_dflags hsc_env)) then
do
- res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result
+ (iface, hml) <- hscGenBackendPipeline pipe_env hsc_env mod_sum result
-- Only run dynamic-too if the backend generates object files
-- See Note [Writing interface files]
-- If we are writing a simple interface (not . backendWritesFiles), then
@@ -787,16 +787,16 @@ hscBackendPipeline pipe_env hsc_env mod_sum result =
-- generating a duplicate linkable.
-- We must not run the backend a second time with `dynamicNow` enable because
-- all the work has already been done in the first pipeline.
- when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do
+ if (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) )
+ then do
let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"
- () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
- return res
+ (_, hmi_dyn) <- hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
+ pure (iface, hml {homeMod_bytecodeDyn = homeMod_bytecode hmi_dyn})
+ else return (iface, hml)
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
@@ -815,7 +815,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
-- No object file produced, bytecode or NoBackend
Nothing -> return mlinkable
Just o_fp -> do
- unlinked_time <- liftIO (liftIO getCurrentTime)
+ unlinked_time <- liftIO getCurrentTime
final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
-- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
=====================================
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
@@ -584,23 +586,20 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
(outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
hscGenHardCode hsc_env cgguts mod_location output_fn
- -- When compiling with -fprefer-byte-code, always
- -- compile foreign stubs as shared objects to ensure
- -- they can be properly loaded.
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_fos
- | gopt Opt_WriteIfSimplifiedCore dflags = fos
- | otherwise = []
+ (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_fos
+ 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 }
@@ -617,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
=====================================
@@ -166,7 +166,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/Load.hs
=====================================
@@ -111,12 +111,12 @@ import GHC.Unit.Env
import GHC.Data.Maybe
import Control.Monad
+import Data.Function ((&))
import Data.Map ( toList )
import System.FilePath
import System.Directory
import GHC.Driver.Env.KnotVars
import GHC.Iface.Errors.Types
-import Data.Function ((&))
{-
************************************************************************
=====================================
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,12 +89,11 @@ import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Deps
-import qualified Data.ByteString as BS
-import Data.Traversable
import Data.Function
import Data.List ( sortBy )
import Data.Ord
import Data.IORef
+import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign)
{-
@@ -134,15 +134,16 @@ 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 -> [FilePath] -> IO ModIface
-mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos fos = 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
- stub_objs <- for fos BS.readFile
+ -- See Note [Foreign stubs and TH bytecode linking]
+ stub_objs <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files
full_iface <-
{-# SCC "addFingerprints" #-}
@@ -277,7 +278,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
+ -- - stub objs
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
=====================================
@@ -251,9 +251,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
=====================================
@@ -52,6 +52,7 @@ import Control.Applicative
import qualified Data.Set as Set
import qualified Data.Map as M
+import Data.List (isSuffixOf)
import System.FilePath
import System.Directory
@@ -139,7 +140,7 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
-- 3. For each dependent module, find its linkable
-- This will either be in the HPT or (in the case of one-shot
-- compilation) we may need to use maybe_getFileLinkable
- lnks_needed <- mapM get_linkable mods_needed
+ lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed
return $ LinkDeps
{ ldNeededLinkables = lnks_needed
@@ -262,10 +263,17 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
homeModLinkable :: HomeModInfo -> Maybe Linkable
homeModLinkable hmi =
if ldUseByteCode opts
- then homeModInfoByteCode hmi <|> homeModInfoObject hmi
- else homeModInfoObject hmi <|> homeModInfoByteCode hmi
+ then homeModByteCodeLinkable hmi <|> homeModInfoObject hmi
+ else homeModInfoObject hmi <|> homeModByteCodeLinkable hmi
- get_linkable mod -- A home-package module
+ homeModByteCodeLinkable :: HomeModInfo -> Maybe Linkable
+ homeModByteCodeLinkable
+ | Just _ <- maybe_normal_osuf
+ = homeModInfoByteCodeDyn
+ | otherwise
+ = homeModInfoByteCode
+
+ get_linkable osuf mod -- A home-package module
| Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env)
= adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info))
| otherwise
@@ -299,15 +307,11 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
return lnk
adjust_ul new_osuf (DotO file) = do
- -- file may already has new_osuf suffix. One example
- -- is when we load bytecode from whole core bindings,
- -- then the corresponding foreign stub objects are
- -- compiled as shared objects and file may already has
- -- .dyn_o suffix. And it's okay as long as the file to
- -- load is already there.
- let new_file = file -<.> new_osuf
+ massert (osuf `isSuffixOf` file)
+ let file_base = fromJust (stripExtension osuf file)
+ new_file = file_base <.> new_osuf
ok <- doesFileExist new_file
- if (not ok)
+ if not ok
then dieWith opts span $
text "cannot find object file "
<> quotes (text new_file) $$ while_linking_expr
@@ -316,7 +320,8 @@ get_link_deps opts pls maybe_normal_osuf span mods = do
adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)
adjust_ul _ l@(BCOs {}) = return l
adjust_ul _ l at LoadedBCOs{} = return l
- adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _)) = pprPanic "Unhydrated core bindings" (ppr mod)
+ adjust_ul _ (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
@@ -725,8 +724,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 isObjectLinkable
- (concatMap partitionLinkable linkables)
+ debugTraceMsg (hsc_logger hsc_env) 4 $
+ 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
@@ -736,20 +738,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
- = let li_uls = linkableUnlinked li
- li_uls_obj = filter isObject li_uls
- li_uls_bco = filter isInterpretable li_uls
- in
- case (li_uls_obj, li_uls_bco) of
- (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
- li {linkableUnlinked=li_uls_bco}]
- _ -> [li]
-
linkableInSet :: Linkable -> LinkableSet -> Bool
linkableInSet l objs_loaded =
case lookupModuleEnv objs_loaded (linkableModule l) of
@@ -776,8 +768,7 @@ loadObjects
loadObjects interp hsc_env pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
- unlinkeds = concatMap linkableUnlinked new_objs
- wanted_objs = map nameOfObject unlinkeds
+ wanted_objs = concatMap linkableObjectCodePaths new_objs
if interpreterDynamic interp
then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
@@ -893,11 +884,9 @@ dynLinkBCOs interp pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
- unlinkeds :: [Unlinked]
- unlinkeds = concatMap linkableUnlinked new_bcos
cbcs :: [CompiledByteCode]
- cbcs = concatMap byteCodeOfObject unlinkeds
+ cbcs = concatMap linkableByteCode new_bcos
le1 = linker_env pls
@@ -1004,7 +993,7 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- we're unloading some code. -fghci-leak-check with the tests in
-- testsuite/ghci can detect space leaks here.
- let (objs_to_keep', bcos_to_keep') = partition isObjectLinkable keep_linkables
+ let (objs_to_keep', bcos_to_keep') = partitionLinkables keep_linkables
objs_to_keep = mkLinkableSet objs_to_keep'
bcos_to_keep = mkLinkableSet bcos_to_keep'
@@ -1045,7 +1034,7 @@ unload_wkr interp keep_linkables pls at LoaderState{..} = do
-- not much benefit.
| otherwise
- = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]
+ = mapM_ (unloadObj interp) (linkableObjs lnk)
-- The components of a BCO linkable may contain
-- dot-o files. Which is very confusing.
--
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -6,6 +6,7 @@
--
-----------------------------------------------------------------------------
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Linker.Types
( Loader (..)
, LoaderState (..)
@@ -26,13 +27,17 @@ module GHC.Linker.Types
, isObjectLinkable
, linkableObjs
, isObject
- , nameOfObject
, nameOfObject_maybe
- , isInterpretable
- , byteCodeOfObject
, LibrarySpec(..)
, LoadedPkgInfo(..)
, PkgsLoaded
+ , linkableFilter
+ , linkableFilterObjectCode
+ , linkableFilterByteCode
+ , partitionLinkables
+ , linkableObjectCodePaths
+ , linkableByteCode
+ , linkableContainsByteCode
)
where
@@ -48,15 +53,14 @@ import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filte
import GHC.Types.Name ( Name )
import GHC.Utils.Outputable
-import GHC.Utils.Panic
import Control.Concurrent.MVar
import Data.Time ( UTCTime )
-import Data.Maybe
import GHC.Unit.Module.Env
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
import GHC.Unit.Module.WholeCoreBindings
+import Data.Maybe (mapMaybe)
{- **********************************************************************
@@ -233,7 +237,7 @@ unionLinkableSet = plusModuleEnv_C go
instance Outputable Linkable where
ppr (LM when_made mod unlinkeds)
- = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
+ = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod)
$$ nest 3 (ppr unlinkeds)
type ObjFile = FilePath
@@ -245,8 +249,18 @@ data Unlinked
| DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib)
| CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend
-- See Note [Interface Files with Core Definitions]
- | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid
- -- being too strict.
+
+ -- | Bytecode and object files generated from data loaded from interfaces
+ -- with @-fprefer-byte-code at .
+ -- Both fields are outputs of a lazy IO thunk in
+ -- 'GHC.Driver.Main.initWholeCoreBindings', to avoid the overhead of
+ -- compiling Core bindings when the bytecode isn't used by TH.
+ | LoadedBCOs
+ -- | A 'BCOs' value.
+ Unlinked
+ -- | Objects generated from foreign stubs and files.
+ [FilePath]
+
| BCOs CompiledByteCode
[SptEntry] -- ^ A byte-code object, lives only in memory. Also
-- carries some static pointer table entries which
@@ -255,7 +269,7 @@ data Unlinked
-- "GHC.Iface.Tidy.StaticPtrTable".
instance Outputable Unlinked where
- ppr (DotO path) = text "DotO" <+> text path
+ ppr (DotO path) = text "DotO" <+> text path
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt
@@ -269,31 +283,45 @@ data SptEntry = SptEntry Id Fingerprint
instance Outputable SptEntry where
ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr
+-------------------------------------------
+-- TODO still dodgy: Since it used @all isObject@ before, there might be some
+-- other use case with multiple @Unlinked@ that I'm not aware of, or not.
+--
+-- It had quite a few consumers, and it seems unlikely that those all
+-- specifically wanted "Linkables that contain one or more objects but not mixed
+-- with other Unlinked".
+--
+-- Consumers: several in @HomeModInfo@, @checkObjects@
isObjectLinkable :: Linkable -> Bool
isObjectLinkable l = not (null unlinked) && all isObject unlinked
where unlinked = linkableUnlinked l
-- A linkable with no Unlinked's is treated as a BCO. We can
-- generate a linkable with no Unlinked's as a result of
- -- compiling a module in NoBackend mode, and this choice
- -- happens to work well with checkStability in module GHC.
+ -- compiling a module in NoBackend mode.
-linkableObjs :: Linkable -> [FilePath]
-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
--------------------------------------------
+-- TODO still dodgy: this used to only match on DotO, so we'll have to decide
+-- whether foreign stubs are desired by its consumers.
+--
+-- Consumers: Twice used in @unload_wkr@
+linkableObjs :: Linkable -> [FilePath]
+linkableObjs l = concatMap unlinkedObjectPaths (linkableUnlinked l)
-- | Is this an actual file on disk we can link in somehow?
+--
+-- TODO still dodgy: Used in many places, but those probably don't expect
+-- LoadedBCOs.
isObject :: Unlinked -> Bool
-isObject (DotO _) = True
-isObject (DotA _) = True
-isObject (DotDLL _) = True
-isObject _ = False
-
--- | Is this a bytecode linkable with no file on disk?
-isInterpretable :: Unlinked -> Bool
-isInterpretable = not . isObject
-
+isObject = \case
+ DotO _ -> True
+ DotA _ -> True
+ DotDLL _ -> True
+ LoadedBCOs _ _ -> True
+ _ -> False
+
+-- TODO still dodgy: Used in HsToCore.Usage. Unclear what that would want to do
+-- with foreign stubs.
nameOfObject_maybe :: Unlinked -> Maybe FilePath
nameOfObject_maybe (DotO fn) = Just fn
nameOfObject_maybe (DotA fn) = Just fn
@@ -302,15 +330,99 @@ nameOfObject_maybe (CoreBindings {}) = Nothing
nameOfObject_maybe (LoadedBCOs{}) = Nothing
nameOfObject_maybe (BCOs {}) = Nothing
--- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object
-nameOfObject :: Unlinked -> FilePath
-nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o)
-
--- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable
-byteCodeOfObject :: Unlinked -> [CompiledByteCode]
-byteCodeOfObject (BCOs bc _) = [bc]
-byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul
-byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
+-- | Return the paths of all object files (.o) contained in this 'Unlinked'.
+unlinkedObjectPaths :: Unlinked -> [FilePath]
+unlinkedObjectPaths = \case
+ DotO f -> [f]
+ LoadedBCOs _ os -> os
+ _ -> []
+
+-- | Return the paths of all object code files (.o, .a, .so) contained in this
+-- 'Unlinked'.
+unlinkedObjectCodePaths :: Unlinked -> [FilePath]
+unlinkedObjectCodePaths = \case
+ DotO f -> [f]
+ DotA f -> [f]
+ DotDLL f -> [f]
+ LoadedBCOs _ os -> os
+ _ -> []
+
+-- | Return the paths of all object code files (.o, .a, .so) contained in this
+-- 'Unlinked'.
+linkableObjectCodePaths :: Linkable -> [FilePath]
+linkableObjectCodePaths = concatMap unlinkedObjectCodePaths . linkableUnlinked
+
+-- | Produce a flat list of 'Unlinked' containing only object code files (.o,
+-- .a, .so), eliminating 'LoadedBCOs'.
+unlinkedFilterObjectCode :: Unlinked -> [Unlinked]
+unlinkedFilterObjectCode = \case
+ u at DotO {} -> [u]
+ u at DotA {} -> [u]
+ u at DotDLL {} -> [u]
+ LoadedBCOs _ os -> DotO <$> os
+ _ -> []
+
+-- | Produce a flat list of 'Unlinked' containing only byte code, eliminating
+-- 'LoadedBCOs'.
+unlinkedFilterByteCode :: Unlinked -> [Unlinked]
+unlinkedFilterByteCode = \case
+ u at BCOs {} -> [u]
+ LoadedBCOs bcos _ -> [bcos]
+ _ -> []
+
+-- | Transform the 'Unlinked' list in this 'Linkable' by applying the supplied
+-- function.
+-- If the result is empty, return 'Nothing'.
+linkableFilter :: (Unlinked -> [Unlinked]) -> Linkable -> Maybe Linkable
+linkableFilter f linkable =
+ case concatMap f (linkableUnlinked linkable) of
+ [] -> Nothing
+ new -> Just linkable {linkableUnlinked = new}
+
+-- | Transform the 'Unlinked' list in this 'Linkable' to contain only object
+-- code files (.o, .a, .so) without 'LoadedBCOs'.
+-- If no 'Unlinked' remains, return 'Nothing'.
+linkableFilterObjectCode :: Linkable -> Maybe Linkable
+linkableFilterObjectCode = linkableFilter unlinkedFilterObjectCode
+
+-- | Transform the 'Unlinked' list in this 'Linkable' to contain only byte code
+-- without 'LoadedBCOs'.
+-- If no 'Unlinked' remains, return 'Nothing'.
+linkableFilterByteCode :: Linkable -> Maybe Linkable
+linkableFilterByteCode = linkableFilter unlinkedFilterByteCode
+
+-- | Split the 'Unlinked' lists in each 'Linkable' into only object code files
+-- (.o, .a, .so) and only byte code, without 'LoadedBCOs', and return two lists
+-- containing the nonempty 'Linkable's for each.
+partitionLinkables :: [Linkable] -> ([Linkable], [Linkable])
+partitionLinkables linkables =
+ (
+ mapMaybe linkableFilterObjectCode linkables,
+ mapMaybe linkableFilterByteCode linkables
+ )
+
+-- | Return the 'CompiledByteCode' if the argument contains any, or 'Nothing'.
+unlinkedByteCode :: Unlinked -> Maybe CompiledByteCode
+unlinkedByteCode = \case
+ BCOs bc _ -> Just bc
+ LoadedBCOs bcos _ -> unlinkedByteCode bcos
+ _ -> Nothing
+
+-- | Return all 'CompiledByteCode' values contained in this 'Linkable'.
+linkableByteCode :: Linkable -> [CompiledByteCode]
+linkableByteCode = mapMaybe unlinkedByteCode . linkableUnlinked
+
+-- | Indicate whether the argument is one of the byte code constructors.
+unlinkedContainsByteCode :: Unlinked -> Bool
+unlinkedContainsByteCode = \case
+ BCOs {} -> True
+ LoadedBCOs {} -> True
+ _ -> False
+
+-- | Indicate whether any 'Unlinked' in this 'Linkable' is one of the byte code
+-- constructors.
+linkableContainsByteCode :: Linkable -> Bool
+linkableContainsByteCode = any unlinkedContainsByteCode . linkableUnlinked
{- **********************************************************************
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -685,15 +685,11 @@ fromEvalResult (EvalSuccess a) = return a
getModBreaks :: HomeModInfo -> ModBreaks
getModBreaks hmi
| Just linkable <- homeModInfoByteCode hmi,
- [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable
+ -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
+ [cbc] <- linkableByteCode linkable
= fromMaybe emptyModBreaks (bc_breaks cbc)
| otherwise
= emptyModBreaks -- probably object code
- where
- -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.
- onlyBCOs :: Unlinked -> Maybe CompiledByteCode
- onlyBCOs (BCOs cbc _) = Just cbc
- onlyBCOs _ = Nothing
-- | Interpreter uses Profiling way
interpreterProfiled :: Interp -> Bool
=====================================
compiler/GHC/Unit/Home/ModInfo.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Unit.Home.ModInfo
, listToHpt
, listHMIToHpt
, pprHPT
+ , homeModInfoByteCodeDyn
)
where
@@ -44,6 +45,7 @@ import GHC.Utils.Outputable
import Data.List (sortOn)
import Data.Ord
import GHC.Utils.Panic
+import Control.Applicative ((<|>))
-- | Information about modules in the package being compiled
data HomeModInfo = HomeModInfo
@@ -76,18 +78,23 @@ data HomeModInfo = HomeModInfo
homeModInfoByteCode :: HomeModInfo -> Maybe Linkable
homeModInfoByteCode = homeMod_bytecode . hm_linkable
+homeModInfoByteCodeDyn :: HomeModInfo -> Maybe Linkable
+homeModInfoByteCodeDyn HomeModInfo {hm_linkable} =
+ homeMod_bytecodeDyn hm_linkable <|> homeMod_bytecode hm_linkable
+
homeModInfoObject :: HomeModInfo -> Maybe Linkable
homeModInfoObject = homeMod_object . hm_linkable
emptyHomeModInfoLinkable :: HomeModLinkable
-emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing
+emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing Nothing
-- See Note [Home module build products]
data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable)
+ , homeMod_bytecodeDyn :: !(Maybe Linkable)
, homeMod_object :: !(Maybe Linkable) }
instance Outputable HomeModLinkable where
- ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2
+ ppr (HomeModLinkable l1 l2 l3) = ppr l1 $$ ppr l2 $$ ppr l3
justBytecode :: Linkable -> HomeModLinkable
justBytecode lm =
@@ -102,7 +109,7 @@ justObjects lm =
bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects bc o =
assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o)
- (HomeModLinkable (Just bc) (Just o))
+ (HomeModLinkable (Just bc) (Just o) Nothing)
{-
=====================================
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
@@ -22,7 +23,7 @@ module GHC.Unit.Module.ModIface
, mi_anns
, mi_decls
, mi_extra_decls
- , mi_stub_objs
+ , mi_foreign
, mi_top_env
, mi_insts
, mi_fam_insts
@@ -101,6 +102,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,14 +116,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
-import Data.ByteString (ByteString)
+
{- Note [Interface file stages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -285,7 +287,7 @@ 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_stub_objs_ :: ![ByteString],
+ mi_foreign_ :: !IfaceForeign,
-- ^ Serialized foreign stub dynamic objects when
-- compiled with -fbyte-code-and-object-code, empty
-- and unused in other cases. This is required to make
@@ -463,7 +465,7 @@ instance Binary ModIface where
mi_anns_ = anns,
mi_decls_ = decls,
mi_extra_decls_ = extra_decls,
- mi_stub_objs_ = stub_objs,
+ mi_foreign_ = stub_objs,
mi_insts_ = insts,
mi_fam_insts_ = fam_insts,
mi_rules_ = rules,
@@ -571,7 +573,7 @@ instance Binary ModIface where
mi_warns_ = warns,
mi_decls_ = decls,
mi_extra_decls_ = extra_decls,
- mi_stub_objs_ = stub_objs,
+ mi_foreign_ = stub_objs,
mi_top_env_ = Nothing,
mi_insts_ = insts,
mi_fam_insts_ = fam_insts,
@@ -625,7 +627,7 @@ emptyPartialModIface mod
mi_rules_ = [],
mi_decls_ = [],
mi_extra_decls_ = Nothing,
- mi_stub_objs_ = [],
+ mi_foreign_ = emptyIfaceForeign,
mi_top_env_ = Nothing,
mi_hpc_ = False,
mi_trust_ = noIfaceTrustInfo,
@@ -679,7 +681,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_extra_decls_, mi_stub_objs_, mi_top_env_, mi_insts_
+ , mi_decls_, 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_ })
@@ -696,7 +698,7 @@ instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
`seq` rnf mi_anns_
`seq` rnf mi_decls_
`seq` rnf mi_extra_decls_
- `seq` rnf mi_stub_objs_
+ `seq` rnf mi_foreign_
`seq` rnf mi_top_env_
`seq` rnf mi_insts_
`seq` rnf mi_fam_insts_
@@ -860,8 +862,8 @@ set_mi_decls val iface = clear_mi_hi_bytes $ iface { mi_decls_ = 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_stub_objs :: [ByteString] -> ModIface_ phase -> ModIface_ phase
-set_mi_stub_objs stub_objs iface = clear_mi_hi_bytes $ iface { mi_stub_objs_ = stub_objs }
+set_mi_stub_objs :: IfaceForeign -> ModIface_ phase -> ModIface_ phase
+set_mi_stub_objs stub_objs iface = clear_mi_hi_bytes $ iface { mi_foreign_ = stub_objs }
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 }
@@ -959,7 +961,7 @@ However, with the pragma, the correct core is generated:
{-# INLINE mi_anns #-}
{-# INLINE mi_decls #-}
{-# INLINE mi_extra_decls #-}
-{-# INLINE mi_stub_objs #-}
+{-# INLINE mi_foreign #-}
{-# INLINE mi_top_env #-}
{-# INLINE mi_insts #-}
{-# INLINE mi_fam_insts #-}
@@ -978,7 +980,7 @@ 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] -> [ByteString] ->
+ [IfaceAnnotation] -> [IfaceDeclExts phase] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IfaceForeign ->
Maybe IfaceTopEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] ->
AnyHpcUsage -> IfaceTrustInfo -> Bool -> [IfaceCompleteMatch] -> Maybe Docs ->
IfaceBackendExts phase -> ExtensibleFields -> Fingerprint -> IfaceBinHandle phase ->
@@ -996,7 +998,7 @@ pattern ModIface
, mi_anns
, mi_decls
, mi_extra_decls
- , mi_stub_objs
+ , mi_foreign
, mi_top_env
, mi_insts
, mi_fam_insts
@@ -1023,7 +1025,7 @@ pattern ModIface
, mi_anns_ = mi_anns
, mi_decls_ = mi_decls
, mi_extra_decls_ = mi_extra_decls
- , mi_stub_objs_ = mi_stub_objs
+ , mi_foreign_ = mi_foreign
, mi_top_env_ = mi_top_env
, mi_insts_ = mi_insts
, mi_fam_insts_ = mi_fam_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 (..), foreignSrcLangSuffix)
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 Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Traversable (for)
+import Data.Word (Word8)
+import Data.Maybe (fromMaybe)
{-
Note [Interface Files with Core Definitions]
@@ -60,4 +82,335 @@ 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 TH to use
+bytecode instead of native code, if possible.
+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 would require dependencies to be built with @-dynamic[-too]@.
+
+This doesn't work for stub objects, though – they are only ever compiled to @.o@
+files.
+TODO conclusion depends on how we fix the remaining issues
+
+Problem 4:
+
+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
+
+data IfaceForeignFile =
+ IfaceForeignFile {
+ lang :: ForeignSrcLang,
+ source :: String
+ }
+
+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
+ pure IfaceForeignFile {lang, source}
+
+ put_ bh IfaceForeignFile {lang, source} = do
+ binary_put_ForeignSrcLang bh lang
+ put_ bh source
+
+instance NFData IfaceForeignFile where
+ rnf IfaceForeignFile {lang, source} = lang `seq` rnf source
+
+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 ::
+ MonadIO m =>
+ Logger ->
+ DynFlags ->
+ ForeignStubs ->
+ [(ForeignSrcLang, FilePath)] ->
+ m IfaceForeign
+encodeIfaceForeign logger dflags foreign_stubs lang_paths = do
+ files <- read_foreign_files
+ stubs <- encode_stubs foreign_stubs
+ let iff = IfaceForeign {stubs, files}
+ liftIO $ 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 =
+ liftIO $ for lang_paths $ \ (lang, path) -> do
+ source <- readFile path
+ pure IfaceForeignFile {lang, source}
+
+ 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 ::
+ MonadIO m =>
+ Logger ->
+ TmpFs ->
+ TempDir ->
+ IfaceForeign ->
+ m (ForeignStubs, [(ForeignSrcLang, FilePath)])
+decodeIfaceForeign logger tmpfs tmp_dir iff at IfaceForeign {stubs, files} = do
+ liftIO $ debugTraceMsg logger 3 $
+ hang (text "Decoding foreign data from iface:") 2 (ppr iff)
+ lang_paths <- liftIO $ for files $ \ IfaceForeignFile {lang, source} -> do
+ f <- newTempName logger tmpfs tmp_dir TFL_GhcSession (foreignSrcLangSuffix lang)
+ 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
=====================================
ghc/GHCi/Leak.hs
=====================================
@@ -49,7 +49,7 @@ getLeakIndicators hsc_env =
return $ LeakModIndicators{..}
where
mkWeakLinkables :: HomeModLinkable -> IO [Maybe (Weak Linkable)]
- mkWeakLinkables (HomeModLinkable mbc mo) =
+ mkWeakLinkables (HomeModLinkable mbc mo _) =
mapM (\ln -> traverse (flip mkWeakPtr Nothing <=< evaluate) ln) [mbc, mo]
-- | Look at the LeakIndicators collected by an earlier call to
=====================================
libraries/ghc-internal/src/GHC/Internal/ForeignSrcLang.hs
=====================================
@@ -1,7 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
module GHC.Internal.ForeignSrcLang
( ForeignSrcLang(..)
+ , foreignSrcLangSuffix
) where
#ifdef BOOTSTRAP_TH
@@ -23,3 +25,13 @@ data ForeignSrcLang
| LangJs -- ^ JavaScript
| RawObject -- ^ Object (.o)
deriving (Eq, Show, Generic)
+
+foreignSrcLangSuffix :: ForeignSrcLang -> String
+foreignSrcLangSuffix = \case
+ LangC -> "c"
+ LangCxx -> "cpp"
+ LangObjc -> "m"
+ LangObjcxx -> "mm"
+ LangAsm -> "s"
+ LangJs -> "js"
+ RawObject -> "a"
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -872,15 +872,7 @@ addForeignFile = addForeignSource
-- > ]
addForeignSource :: ForeignSrcLang -> String -> Q ()
addForeignSource lang src = do
- let suffix = case lang of
- LangC -> "c"
- LangCxx -> "cpp"
- LangObjc -> "m"
- LangObjcxx -> "mm"
- LangAsm -> "s"
- LangJs -> "js"
- RawObject -> "a"
- path <- addTempFile suffix
+ path <- addTempFile (foreignSrcLangSuffix lang)
runIO $ writeFile path src
addForeignFilePath lang path
=====================================
testsuite/tests/bytecode/T24634/Hello.hs
=====================================
@@ -9,8 +9,13 @@ import Language.Haskell.TH.Syntax
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
-T24634:
- $(TEST_HC) -c -dynamic hello_c.c -o hello_c.o
+# 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/T24634.stdout → testsuite/tests/bytecode/T24634/T24634a.stdout
=====================================
@@ -1,3 +1,3 @@
[2 of 3] Compiling Main ( Main.hs, Main.o, interpreted )
[3 of 3] Linking Main
-42
+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,8 +1,11 @@
-test('T24634',
+def test_T24634(name):
+ return test(name,
[extra_files(['hello_c.h', 'hello_c.c', 'Hello.hs', 'Main.hs']),
req_c,
req_th,
- ignore_stderr,
],
makefile_test,
[])
+
+test_T24634('T24634a')
+test_T24634('T24634b')
=====================================
testsuite/tests/count-deps/CountDepsAst.stdout
=====================================
@@ -196,6 +196,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
=====================================
@@ -218,6 +218,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/-/compare/f8aa5bb3cffc42ff01d15c168d7897dee9cb972a...9b0cd16f01a1ee8b1e41db8feb7bab33bd4f65a9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f8aa5bb3cffc42ff01d15c168d7897dee9cb972a...9b0cd16f01a1ee8b1e41db8feb7bab33bd4f65a9
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/20240814/b31887ba/attachment-0001.html>
More information about the ghc-commits
mailing list