Skip to content
GitLab
Commit 83f5c6c6 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

When dynamic-by-default, don't use the GHCi linker 

We instead link objects into a temporary DLL and dlopen that
parent 5c43947b
Hide whitespace changes
Inline Side-by-side
compiler/ghci/Linker.lhs
View file @ 83f5c6c6
......@@ -415,11 +415,17 @@ preloadLib dflags lib_paths framework_paths lib_spec
preload_static _paths name
= do b <- doesFileExist name
if not b then return False
else loadObj name >> return True
else do if dYNAMIC_BY_DEFAULT dflags
then dynLoadObjs dflags [name]
else loadObj name
return True
preload_static_archive _paths name
= do b <- doesFileExist name
if not b then return False
else loadArchive name >> return True
else do if dYNAMIC_BY_DEFAULT dflags
then panic "Loading archives not supported"
else loadArchive name
return True
\end{code}
......@@ -783,20 +789,45 @@ dynLinkObjs dflags pls objs = do
let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
mapM_ loadObj (map nameOfObject unlinkeds)
-- Link them all together
ok <- resolveObjs
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then do
return (pls1, Succeeded)
else do
pls2 <- unload_wkr dflags [] pls1
return (pls2, Failed)
wanted_objs = map nameOfObject unlinkeds
if dYNAMIC_BY_DEFAULT dflags
then do dynLoadObjs dflags wanted_objs
return (pls, Succeeded)
else do mapM_ loadObj wanted_objs
-- Link them all together
ok <- resolveObjs
-- If resolving failed, unload all our
-- object modules and carry on
if succeeded ok then do
return (pls1, Succeeded)
else do
pls2 <- unload_wkr dflags [] pls1
return (pls2, Failed)
dynLoadObjs :: DynFlags -> [FilePath] -> IO ()
dynLoadObjs dflags objs = do
let platform = targetPlatform dflags
soFile <- newTempName dflags (soExt platform)
let -- When running TH for a non-dynamic way, we still need to make
-- -l flags to link against the dynamic libraries, so we turn
-- Opt_Static off
dflags1 = dopt_unset dflags Opt_Static
dflags2 = dflags1 {
-- We don't want to link the ldInputs in; we'll
-- be calling dynLoadObjs with any objects that
-- need to be linked.
ldInputs = [],
outputFile = Just soFile
}
linkDynLib dflags2 objs []
consIORef (filesToNotIntermediateClean dflags) soFile
m <- loadDLL soFile
case m of
Nothing -> return ()
Just err -> panic ("Loading temp shared object failed: " ++ err)
rmDupLinkables :: [Linkable] -- Already loaded
-> [Linkable] -- New linkables
......
compiler/main/DriverPipeline.hs
View file @ 83f5c6c6
......@@ -330,7 +330,7 @@ link' dflags batch_attempt_linking hpt
-- Don't showPass in Batch mode; doLink will do that for us.
let link = case ghcLink dflags of
LinkBinary -> linkBinary
LinkDynLib -> linkDynLib
LinkDynLib -> linkDynLibCheck
other -> panicBadLink other
link dflags obj_files pkg_deps
......@@ -465,8 +465,8 @@ doLink dflags stop_phase o_files
| otherwise
= case ghcLink dflags of
NoLink -> return ()
LinkBinary -> linkBinary dflags o_files []
LinkDynLib -> linkDynLib dflags o_files []
LinkBinary -> linkBinary dflags o_files []
LinkDynLib -> linkDynLibCheck dflags o_files []
other -> panicBadLink other
......@@ -1884,176 +1884,15 @@ maybeCreateManifest dflags exe_filename
| otherwise = return []
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages
linkDynLibCheck :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
let verbFlags = getVerbFlags dflags
let o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
let pkg_lib_paths = collectLibraryPaths pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| osElfTarget (platformOS (targetPlatform dflags)) &&
dynLibLoader dflags == SystemDependent &&
not (dopt Opt_Static dflags)
= ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
| otherwise = ["-L" ++ l]
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
-- We don't want to link our dynamic libs against the RTS package,
-- because the RTS lib comes in several flavours and we want to be
-- able to pick the flavour when a binary is linked.
-- On Windows we need to link the RTS import lib as Windows does
-- not allow undefined symbols.
-- The RTS library path is still added to the library search path
-- above in case the RTS is being explicitly linked in (see #3807).
let platform = targetPlatform dflags
os = platformOS platform
pkgs_no_rts = case os of
OSMinGW32 ->
pkgs
_ ->
filter ((/= rtsPackageId) . packageConfigId) pkgs
let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
-- probably _stub.o files
let extra_ld_inputs = ldInputs dflags
let extra_ld_opts = getOpts dflags opt_l
case os of
OSMinGW32 -> do
-------------------------------------------------------------
-- Making a DLL
-------------------------------------------------------------
let output_fn = case o_file of
Just s -> s
Nothing -> "HSdll.dll"
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
, SysTools.Option "-shared"
] ++
[ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| dopt Opt_SharedImplib dflags
]
++ map (SysTools.FileOption "") o_files
++ map SysTools.Option (
-- Permit the linker to auto link _symbol to _imp_symbol
-- This lets us link against DLLs without needing an "import library"
["-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
OSDarwin -> do
-------------------------------------------------------------------
-- Making a darwin dylib
-------------------------------------------------------------------
-- About the options used for Darwin:
-- -dynamiclib
-- Apple's way of saying -shared
-- -undefined dynamic_lookup:
-- Without these options, we'd have to specify the correct
-- dependencies for each of the dylibs. Note that we could
-- (and should) do without this for all libraries except
-- the RTS; all we need to do is to pass the correct
-- HSfoo_dyn.dylib files to the link command.
-- This feature requires Mac OS X 10.3 or later; there is
-- a similar feature, -flat_namespace -undefined suppress,
-- which works on earlier versions, but it has other
-- disadvantages.
-- -single_module
-- Build the dynamic library as a single "module", i.e. no
-- dynamic binding nonsense when referring to symbols from
-- within the library. The NCG assumes that this option is
-- specified (on i386, at least).
-- -install_name
-- Mac OS/X stores the path where a dynamic library is (to
-- be) installed in the library itself. It's called the
-- "install name" of the library. Then any library or
-- executable that links against it before it's installed
-- will search for it in its ultimate install location.
-- By default we set the install name to the absolute path
-- at build time, but it can be overridden by the
-- -dylib-install-name option passed to ghc. Cabal does
-- this.
-------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
instName <- case dylibInstallName dflags of
Just n -> return n
Nothing -> do
pwd <- getCurrentDirectory
return $ pwd `combine` output_fn
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-dynamiclib"
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
o_files
++ [ "-undefined", "dynamic_lookup", "-single_module" ]
++ (if platformArch platform == ArchX86_64
then [ ]
else [ "-Wl,-read_only_relocs,suppress" ])
++ [ "-install_name", instName ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
_ -> do
-------------------------------------------------------------------
-- Making a DSO
-------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
let buildingRts = thisPackage dflags == rtsPackageId
let bsymbolicFlag = if buildingRts
then -- -Bsymbolic breaks the way we implement
-- hooks in the RTS
[]
else -- we need symbolic linking to resolve
-- non-PIC intra-package-relocations
["-Wl,-Bsymbolic"]
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
o_files
++ [ "-shared" ]
++ bsymbolicFlag
-- Set the library soname. We use -h rather than -soname as
-- Solaris 10 doesn't support the latter:
++ [ "-Wl,-h," ++ takeFileName output_fn ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
linkDynLib dflags o_files dep_packages
-- -----------------------------------------------------------------------------
-- Running CPP
......
compiler/main/DynFlags.hs
View file @ 83f5c6c6
......@@ -641,6 +641,8 @@ data DynFlags = DynFlags {
-- know what to clean when an exception happens
filesToClean :: IORef [FilePath],
dirsToClean :: IORef (Map FilePath FilePath),
filesToNotIntermediateClean :: IORef [FilePath],
-- Names of files which were generated from -ddump-to-file; used to
-- track which ones we need to truncate because it's our first run
......@@ -908,7 +910,7 @@ data PackageFlag
| IgnorePackage String
| TrustPackage String
| DistrustPackage String
deriving Eq
deriving (Eq, Show)
defaultHscTarget :: Platform -> HscTarget
defaultHscTarget = defaultObjectTarget
......@@ -1022,29 +1024,35 @@ wayDesc WayPar = "Parallel"
wayDesc WayGran = "GranSim"
wayDesc WayNDP = "Nested data parallelism"
wayDynFlags :: Platform -> Way -> [DynFlag]
wayDynFlags _ WayThreaded = []
wayDynFlags _ WayDebug = []
wayDynFlags platform WayDyn =
case platformOS platform of
-- On Windows, code that is to be linked into a dynamic
-- library must be compiled with -fPIC. Labels not in
-- the current package are assumed to be in a DLL
-- different from the current one.
OSMinGW32 -> [Opt_PIC]
OSDarwin -> [Opt_PIC]
OSLinux -> [Opt_PIC]
_ -> []
wayDynFlags _ WayProf = [Opt_SccProfilingOn]
wayDynFlags _ WayEventLog = []
wayDynFlags _ WayPar = [Opt_Parallel]
wayDynFlags _ WayGran = [Opt_GranMacros]
wayDynFlags _ WayNDP = []
wayExtras :: Platform -> Way -> DynP ()
wayExtras _ WayThreaded = return ()
wayExtras _ WayDebug = return ()
wayExtras platform WayDyn =
case platformOS platform of
OSMinGW32 ->
-- On Windows, code that is to be linked into a dynamic
-- library must be compiled with -fPIC. Labels not in
-- the current package are assumed to be in a DLL
-- different from the current one.
setFPIC
OSDarwin ->
setFPIC
_ ->
return ()
wayExtras _ WayProf = setDynFlag Opt_SccProfilingOn
wayExtras _ WayDebug = return ()
wayExtras _ WayDyn = return ()
wayExtras _ WayProf = return ()
wayExtras _ WayEventLog = return ()
wayExtras _ WayPar = do setDynFlag Opt_Parallel
exposePackage "concurrent"
wayExtras _ WayGran = do setDynFlag Opt_GranMacros
exposePackage "concurrent"
wayExtras _ WayNDP = do setExtensionFlag Opt_ParallelArrays
setDynFlag Opt_Vectorise
wayExtras _ WayPar = exposePackage "concurrent"
wayExtras _ WayGran = exposePackage "concurrent"
wayExtras _ WayNDP = do setExtensionFlag Opt_ParallelArrays
setDynFlag Opt_Vectorise
wayOptc :: Platform -> Way -> [String]
wayOptc platform WayThreaded = case platformOS platform of
......@@ -1106,11 +1114,13 @@ initDynFlags :: DynFlags -> IO DynFlags
initDynFlags dflags = do
refFilesToClean <- newIORef []
refDirsToClean <- newIORef Map.empty
refFilesToNotIntermediateClean <- newIORef []
refGeneratedDumps <- newIORef Set.empty
refLlvmVersion <- newIORef 28
return dflags{
filesToClean = refFilesToClean,
dirsToClean = refDirsToClean,
filesToNotIntermediateClean = refFilesToNotIntermediateClean,
generatedDumps = refGeneratedDumps,
llvmVersion = refLlvmVersion
}
......@@ -1192,6 +1202,7 @@ defaultDynFlags mySettings =
-- end of ghc -M values
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
filesToNotIntermediateClean = panic "defaultDynFlags: No filesToNotIntermediateClean",
generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
flags = IntSet.fromList (map fromEnum (defaultFlags mySettings)),
......@@ -2130,8 +2141,8 @@ dynamic_flags = [
------ Safe Haskell flags -------------------------------------------
, Flag "fpackage-trust" (NoArg setPackageTrust)
, Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None))
, Flag "fPIC" (NoArg setFPIC)
, Flag "fno-PIC" (NoArg unSetFPIC)
, Flag "fPIC" (NoArg (setDynFlag Opt_PIC))
, Flag "fno-PIC" (NoArg (unSetDynFlag Opt_PIC))
]
++ map (mkFlag turnOn "" setDynFlag ) negatableFlags
++ map (mkFlag turnOff "no-" unSetDynFlag) negatableFlags
......@@ -2532,7 +2543,7 @@ defaultFlags settings
_ -> [])
++ (if pc_dYNAMIC_BY_DEFAULT (sPlatformConstants settings)
then []
then wayDynFlags platform WayDyn
else [Opt_Static])
where platform = sTargetPlatform settings
......@@ -2803,7 +2814,9 @@ setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
addWay :: Way -> DynP ()
addWay w = do upd (\dfs -> dfs { ways = w : ways dfs })
dfs <- liftEwM getCmdLineState
wayExtras (targetPlatform dfs) w
let platform = targetPlatform dfs
wayExtras platform w
mapM_ setDynFlag $ wayDynFlags platform w
removeWay :: Way -> DynP ()
removeWay w = upd (\dfs -> dfs { ways = filter (w /=) (ways dfs) })
......@@ -2943,14 +2956,6 @@ setObjTarget l = updM set
= return $ dflags { hscTarget = l }
| otherwise = return dflags
setFPIC :: DynP ()
setFPIC = updM set
where set dflags = return $ dopt_set dflags Opt_PIC
unSetFPIC :: DynP ()
unSetFPIC = updM set
where set dflags = return $ dopt_unset dflags Opt_PIC
setOptLevel :: Int -> DynFlags -> DynP DynFlags
setOptLevel n dflags
| hscTarget dflags == HscInterpreted && n > 0
......
compiler/main/GhcMake.hs
View file @ 83f5c6c6
......@@ -55,6 +55,7 @@ import qualified Data.Map as Map
import qualified FiniteMap as Map ( insertListWith )
import Control.Monad
import Data.IORef
import Data.List
import qualified Data.List as List
import Data.Maybe
......@@ -364,7 +365,8 @@ discardIC hsc_env
intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
intermediateCleanTempFiles dflags summaries hsc_env
= cleanTempFilesExcept dflags except
= do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)
cleanTempFilesExcept dflags (notIntermediate ++ except)
where
except =
-- Save preprocessed files. The preprocessed file *might* be
......
compiler/main/HscTypes.lhs
View file @ 83f5c6c6
......@@ -37,7 +37,7 @@ module HscTypes (
PackageInstEnv, PackageRuleBase,
mkSOName,
mkSOName, soExt,
-- * Annotations
prepareAnnotations,
......@@ -1788,6 +1788,13 @@ mkSOName platform root
OSDarwin -> ("lib" ++ root) <.> "dylib"
OSMinGW32 -> root <.> "dll"
_ -> ("lib" ++ root) <.> "so"
soExt :: Platform -> FilePath
soExt platform
= case platformOS platform of
OSDarwin -> "dylib"
OSMinGW32 -> "dll"
_ -> "so"
\end{code}
......
compiler/main/SysTools.lhs
View file @ 83f5c6c6
......@@ -24,6 +24,8 @@ module SysTools (
figureLlvmVersion,
readElfSection,
linkDynLib,
askCc,
touch, -- String -> String -> IO ()
......@@ -43,6 +45,8 @@ module SysTools (
#include "HsVersions.h"
import DriverPhases
import Module
import Packages
import Config
import Outputable
import ErrUtils
......@@ -1036,4 +1040,170 @@ linesPlatform xs =
#endif
linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
linkDynLib dflags o_files dep_packages
= do
let verbFlags = getVerbFlags dflags
let o_file = outputFile dflags
pkgs <- getPreloadPackagesAnd dflags dep_packages
let pkg_lib_paths = collectLibraryPaths pkgs
let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l
| osElfTarget (platformOS (targetPlatform dflags)) &&
dynLibLoader dflags == SystemDependent &&
not (dopt Opt_Static dflags)
= ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
| otherwise = ["-L" ++ l]
let lib_paths = libraryPaths dflags
let lib_path_opts = map ("-L"++) lib_paths
-- We don't want to link our dynamic libs against the RTS package,
-- because the RTS lib comes in several flavours and we want to be
-- able to pick the flavour when a binary is linked.
-- On Windows we need to link the RTS import lib as Windows does
-- not allow undefined symbols.
-- The RTS library path is still added to the library search path
-- above in case the RTS is being explicitly linked in (see #3807).
let platform = targetPlatform dflags
os = platformOS platform
pkgs_no_rts = case os of
OSMinGW32 ->
pkgs
_ ->
filter ((/= rtsPackageId) . packageConfigId) pkgs
let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
-- probably _stub.o files
let extra_ld_inputs = ldInputs dflags
let extra_ld_opts = getOpts dflags opt_l
case os of
OSMinGW32 -> do
-------------------------------------------------------------
-- Making a DLL
-------------------------------------------------------------
let output_fn = case o_file of
Just s -> s
Nothing -> "HSdll.dll"
runLink dflags (
map Option verbFlags
++ [ Option "-o"
, FileOption "" output_fn
, Option "-shared"
] ++
[ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
| dopt Opt_SharedImplib dflags
]
++ map (FileOption "") o_files
++ map Option (
-- Permit the linker to auto link _symbol to _imp_symbol
-- This lets us link against DLLs without needing an "import library"
["-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
OSDarwin -> do
-------------------------------------------------------------------
-- Making a darwin dylib
-------------------------------------------------------------------
-- About the options used for Darwin:
-- -dynamiclib
-- Apple's way of saying -shared
-- -undefined dynamic_lookup:
-- Without these options, we'd have to specify the correct
-- dependencies for each of the dylibs. Note that we could
-- (and should) do without this for all libraries except
-- the RTS; all we need to do is to pass the correct
-- HSfoo_dyn.dylib files to the link command.
-- This feature requires Mac OS X 10.3 or later; there is
-- a similar feature, -flat_namespace -undefined suppress,
-- which works on earlier versions, but it has other
-- disadvantages.
-- -single_module
-- Build the dynamic library as a single "module", i.e. no
-- dynamic binding nonsense when referring to symbols from
-- within the library. The NCG assumes that this option is
-- specified (on i386, at least).
-- -install_name
-- Mac OS/X stores the path where a dynamic library is (to
-- be) installed in the library itself. It's called the
-- "install name" of the library. Then any library or
-- executable that links against it before it's installed
-- will search for it in its ultimate install location.
-- By default we set the install name to the absolute path
-- at build time, but it can be overridden by the
-- -dylib-install-name option passed to ghc. Cabal does
-- this.
-------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
instName <- case dylibInstallName dflags of
Just n -> return n
Nothing -> do
pwd <- getCurrentDirectory
return $ pwd `combine` output_fn
runLink dflags (
map Option verbFlags
++ [ Option "-dynamiclib"
, Option "-o"
, FileOption "" output_fn
]
++ map Option (
o_files
++ [ "-undefined", "dynamic_lookup", "-single_module" ]
++ (if platformArch platform == ArchX86_64
then [ ]
else [ "-Wl,-read_only_relocs,suppress" ])
++ [ "-install_name", instName ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
++ pkg_lib_path_opts
++ pkg_link_opts
))
_ -> do
-------------------------------------------------------------------
-- Making a DSO
-------------------------------------------------------------------
let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
let buildingRts = thisPackage dflags == rtsPackageId
let bsymbolicFlag = if buildingRts
then -- -Bsymbolic breaks the way we implement
-- hooks in the RTS
[]