From 9408b086775960a2e0a6b0b6f8091e79bcf9ddd5 Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Wed, 11 Oct 2023 15:27:51 +0200
Subject: [PATCH] Modularity: modularize external linker
Decouple runLink from DynFlags to allow calling runLink more easily.
This is preliminary work for calling Emscripten's linker (emcc) from
our JavaScript linker.
---
compiler/GHC/Driver/Config/Linker.hs | 82 +++++++++++++++++++++++++++-
compiler/GHC/Linker/Config.hs | 16 +++++-
compiler/GHC/Linker/Dynamic.hs | 10 ++--
compiler/GHC/Linker/External.hs | 26 +++++++++
compiler/GHC/Linker/Static.hs | 15 +++--
compiler/GHC/SysTools/Tasks.hs | 63 ---------------------
compiler/ghc.cabal.in | 1 +
7 files changed, 136 insertions(+), 77 deletions(-)
create mode 100644 compiler/GHC/Linker/External.hs
diff --git a/compiler/GHC/Driver/Config/Linker.hs b/compiler/GHC/Driver/Config/Linker.hs
index 55481f4c8657..4e22c0238437 100644
--- a/compiler/GHC/Driver/Config/Linker.hs
+++ b/compiler/GHC/Driver/Config/Linker.hs
@@ -1,13 +1,93 @@
module GHC.Driver.Config.Linker
( initFrameworkOpts
- ) where
+ , initLinkerConfig
+ )
+where
+import GHC.Prelude
+import GHC.Platform
import GHC.Linker.Config
import GHC.Driver.DynFlags
+import GHC.Driver.Session
+
+import Data.List (isPrefixOf)
initFrameworkOpts :: DynFlags -> FrameworkOpts
initFrameworkOpts dflags = FrameworkOpts
{ foFrameworkPaths = frameworkPaths dflags
, foCmdlineFrameworks = cmdlineFrameworks dflags
}
+
+-- | Initialize linker configuration from DynFlags
+initLinkerConfig :: DynFlags -> LinkerConfig
+initLinkerConfig dflags =
+ let
+ -- see Note [Solaris linker]
+ ld_filter = case platformOS (targetPlatform dflags) of
+ OSSolaris2 -> sunos_ld_filter
+ _ -> id
+ sunos_ld_filter :: String -> String
+ sunos_ld_filter = unlines . sunos_ld_filter' . lines
+ sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+ then (ld_prefix x) ++ (ld_postfix x)
+ else x
+ breakStartsWith x y = break (isPrefixOf x) y
+ ld_prefix = fst . breakStartsWith "Undefined"
+ undefined_found = not . null . snd . breakStartsWith "Undefined"
+ ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
+ ld_postfix = tail . snd . ld_warn_break
+ ld_warning_found = not . null . snd . ld_warn_break
+
+ -- program and arguments
+ --
+ -- `-optl` args come at the end, so that later `-l` options
+ -- given there manually can fill in symbols needed by
+ -- Haskell libraries coming in via `args`.
+ (p,pre_args) = pgm_l dflags
+ post_args = map Option (getOpts dflags opt_l)
+
+ in LinkerConfig
+ { linkerProgram = p
+ , linkerOptionsPre = pre_args
+ , linkerOptionsPost = post_args
+ , linkerTempDir = tmpDir dflags
+ , linkerFilter = ld_filter
+ }
+
+{- Note [Solaris linker]
+ ~~~~~~~~~~~~~~~~~~~~~
+ SunOS/Solaris ld emits harmless warning messages about unresolved
+ symbols in case of compiling into shared library when we do not
+ link against all the required libs. That is the case of GHC which
+ does not link against RTS library explicitly in order to be able to
+ choose the library later based on binary application linking
+ parameters. The warnings look like:
+
+Undefined first referenced
+ symbol in file
+stg_ap_n_fast ./T2386_Lib.o
+stg_upd_frame_info ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
+newCAF ./T2386_Lib.o
+stg_bh_upd_frame_info ./T2386_Lib.o
+stg_ap_ppp_fast ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
+stg_ap_p_fast ./T2386_Lib.o
+stg_ap_pp_fast ./T2386_Lib.o
+ld: warning: symbol referencing errors
+
+ this is actually coming from T2386 testcase. The emitting of those
+ warnings is also a reason why so many TH testcases fail on Solaris.
+
+ Following filter code is SunOS/Solaris linker specific and should
+ filter out only linker warnings. Please note that the logic is a
+ little bit more complex due to the simple reason that we need to preserve
+ any other linker emitted messages. If there are any. Simply speaking
+ if we see "Undefined" and later "ld: warning:..." then we omit all
+ text between (including) the marks. Otherwise we copy the whole output.
+-}
+
diff --git a/compiler/GHC/Linker/Config.hs b/compiler/GHC/Linker/Config.hs
index 8fbb300caa10..cfc0e0aa2798 100644
--- a/compiler/GHC/Linker/Config.hs
+++ b/compiler/GHC/Linker/Config.hs
@@ -2,12 +2,26 @@
module GHC.Linker.Config
( FrameworkOpts(..)
- ) where
+ , LinkerConfig(..)
+ )
+where
import GHC.Prelude
+import GHC.Utils.TmpFs
+import GHC.Utils.CliOption
-- used on darwin only
data FrameworkOpts = FrameworkOpts
{ foFrameworkPaths :: [String]
, foCmdlineFrameworks :: [String]
}
+
+-- | External linker configuration
+data LinkerConfig = LinkerConfig
+ { linkerProgram :: String -- ^ Linker program
+ , linkerOptionsPre :: [Option] -- ^ Linker options (before user options)
+ , linkerOptionsPost :: [Option] -- ^ Linker options (after user options)
+ , linkerTempDir :: TempDir -- ^ Temporary directory to use
+ , linkerFilter :: String -> String -- ^ Output filter
+ }
+
diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
index 171503d4d660..7cfd797d6b06 100644
--- a/compiler/GHC/Linker/Dynamic.hs
+++ b/compiler/GHC/Linker/Dynamic.hs
@@ -20,7 +20,7 @@ import GHC.Unit.Types
import GHC.Unit.State
import GHC.Linker.MacOS
import GHC.Linker.Unit
-import GHC.SysTools.Tasks
+import GHC.Linker.External
import GHC.Utils.Logger
import GHC.Utils.TmpFs
@@ -98,6 +98,8 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform
+ let linker_config = initLinkerConfig dflags
+
case os of
OSMinGW32 -> do
-------------------------------------------------------------
@@ -107,7 +109,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
Just s -> s
Nothing -> "HSdll.dll"
- runLink logger tmpfs dflags (
+ runLink logger tmpfs linker_config (
map Option verbFlags
++ [ Option "-o"
, FileOption "" output_fn
@@ -167,7 +169,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
instName <- case dylibInstallName dflags of
Just n -> return n
Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
- runLink logger tmpfs dflags (
+ runLink logger tmpfs linker_config (
map Option verbFlags
++ [ Option "-dynamiclib"
, Option "-o"
@@ -212,7 +214,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- See Note [-Bsymbolic assumptions by GHC]
["-Wl,-Bsymbolic" | not unregisterised]
- runLink logger tmpfs dflags (
+ runLink logger tmpfs linker_config (
map Option verbFlags
++ libmLinkOpts platform
++ [ Option "-o"
diff --git a/compiler/GHC/Linker/External.hs b/compiler/GHC/Linker/External.hs
new file mode 100644
index 000000000000..cd013971c7b8
--- /dev/null
+++ b/compiler/GHC/Linker/External.hs
@@ -0,0 +1,26 @@
+-- | External ("system") linker
+module GHC.Linker.External
+ ( LinkerConfig(..)
+ , runLink
+ )
+where
+
+import GHC.Prelude
+import GHC.Utils.TmpFs
+import GHC.Utils.Logger
+import GHC.Utils.Error
+import GHC.Utils.CliOption
+import GHC.SysTools.Process
+import GHC.Linker.Config
+
+-- | Run the external linker
+runLink :: Logger -> TmpFs -> LinkerConfig -> [Option] -> IO ()
+runLink logger tmpfs cfg args = traceSystoolCommand logger "linker" $ do
+ let all_args = linkerOptionsPre cfg ++ args ++ linkerOptionsPost cfg
+
+ -- on Windows, mangle environment variables to account for a bug in Windows
+ -- Vista
+ mb_env <- getGccEnv all_args
+
+ runSomethingResponseFile logger tmpfs (linkerTempDir cfg) (linkerFilter cfg)
+ "Linker" (linkerProgram cfg) all_args mb_env
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
index e4ebf7e2eafa..8e7c0d125993 100644
--- a/compiler/GHC/Linker/Static.hs
+++ b/compiler/GHC/Linker/Static.hs
@@ -26,6 +26,7 @@ import GHC.Linker.MacOS
import GHC.Linker.Unit
import GHC.Linker.Dynamic
import GHC.Linker.ExtraObj
+import GHC.Linker.External
import GHC.Linker.Windows
import GHC.Linker.Static.Utils
@@ -181,14 +182,12 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn
_ -> return []
- let link dflags args | platformOS platform == OSDarwin
- = do
- GHC.SysTools.runLink logger tmpfs dflags args
- -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
- when (gopt Opt_RPath dflags) $
- GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
- | otherwise
- = GHC.SysTools.runLink logger tmpfs dflags args
+ let linker_config = initLinkerConfig dflags
+ let link dflags args = do
+ runLink logger tmpfs linker_config args
+ -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
+ when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $
+ GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
link dflags (
map GHC.SysTools.Option verbFlags
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
index a64a2a6a2e43..3d2c5071c36b 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ b/compiler/GHC/SysTools/Tasks.hs
@@ -10,7 +10,6 @@
module GHC.SysTools.Tasks where
import GHC.Prelude
-import GHC.Platform
import GHC.ForeignSrcLang
import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
@@ -264,68 +263,6 @@ figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do
++ ")") ]
return Nothing)
-
-
-runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
-runLink logger tmpfs dflags args = traceSystoolCommand logger "linker" $ do
- -- `-optl` args come at the end, so that later `-l` options
- -- given there manually can fill in symbols needed by
- -- Haskell libraries coming in via `args`.
- let (p,args0) = pgm_l dflags
- optl_args = map Option (getOpts dflags opt_l)
- args2 = args0 ++ args ++ optl_args
- mb_env <- getGccEnv args2
- runSomethingResponseFile logger tmpfs (tmpDir dflags) ld_filter "Linker" p args2 mb_env
- where
- ld_filter = case (platformOS (targetPlatform dflags)) of
- OSSolaris2 -> sunos_ld_filter
- _ -> id
-{-
- SunOS/Solaris ld emits harmless warning messages about unresolved
- symbols in case of compiling into shared library when we do not
- link against all the required libs. That is the case of GHC which
- does not link against RTS library explicitly in order to be able to
- choose the library later based on binary application linking
- parameters. The warnings look like:
-
-Undefined first referenced
- symbol in file
-stg_ap_n_fast ./T2386_Lib.o
-stg_upd_frame_info ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
-newCAF ./T2386_Lib.o
-stg_bh_upd_frame_info ./T2386_Lib.o
-stg_ap_ppp_fast ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
-stg_ap_p_fast ./T2386_Lib.o
-stg_ap_pp_fast ./T2386_Lib.o
-ld: warning: symbol referencing errors
-
- this is actually coming from T2386 testcase. The emitting of those
- warnings is also a reason why so many TH testcases fail on Solaris.
-
- Following filter code is SunOS/Solaris linker specific and should
- filter out only linker warnings. Please note that the logic is a
- little bit more complex due to the simple reason that we need to preserve
- any other linker emitted messages. If there are any. Simply speaking
- if we see "Undefined" and later "ld: warning:..." then we omit all
- text between (including) the marks. Otherwise we copy the whole output.
--}
- sunos_ld_filter :: String -> String
- sunos_ld_filter = unlines . sunos_ld_filter' . lines
- sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
- then (ld_prefix x) ++ (ld_postfix x)
- else x
- breakStartsWith x y = break (isPrefixOf x) y
- ld_prefix = fst . breakStartsWith "Undefined"
- undefined_found = not . null . snd . breakStartsWith "Undefined"
- ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
- ld_postfix = tail . snd . ld_warn_break
- ld_warning_found = not . null . snd . ld_warn_break
-
-- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
runMergeObjects logger tmpfs dflags args =
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 03f2407abf6f..bc0e1ffd9d40 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -580,6 +580,7 @@ Library
GHC.Linker.Config
GHC.Linker.Deps
GHC.Linker.Dynamic
+ GHC.Linker.External
GHC.Linker.ExtraObj
GHC.Linker.Loader
GHC.Linker.MacOS
--
GitLab