Commit 58eaacc9 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Add a flag to tell ghc to use $ORIGIN when linking program dynamically

parent 483c7633
...@@ -1662,13 +1662,23 @@ linkBinary dflags o_files dep_packages = do ...@@ -1662,13 +1662,23 @@ linkBinary dflags o_files dep_packages = do
-- explicit packages with the auto packages and all of their -- explicit packages with the auto packages and all of their
-- dependencies, and eliminating duplicates. -- dependencies, and eliminating duplicates.
full_output_fn <- if isAbsolute output_fn
then return output_fn
else do d <- getCurrentDirectory
return $ normalise (d </> output_fn)
pkg_lib_paths <- getPackageLibraryPath dflags dep_packages pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
get_pkg_lib_path_opts l get_pkg_lib_path_opts l
| osElfTarget (platformOS platform) && | osElfTarget (platformOS platform) &&
dynLibLoader dflags == SystemDependent && dynLibLoader dflags == SystemDependent &&
not (dopt Opt_Static dflags) not (dopt Opt_Static dflags)
= ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] = let libpath = if dopt Opt_RelativeDynlibPaths dflags
then "$ORIGIN" </>
(l `makeRelativeTo` full_output_fn)
else l
in ["-L" ++ l,
"-Wl,-rpath", "-Wl," ++ libpath,
"-Wl,-rpath-link", "-Wl," ++ l]
| otherwise = ["-L" ++ l] | otherwise = ["-L" ++ l]
let lib_paths = libraryPaths dflags let lib_paths = libraryPaths dflags
......
...@@ -339,6 +339,7 @@ data DynFlag ...@@ -339,6 +339,7 @@ data DynFlag
| Opt_SccProfilingOn | Opt_SccProfilingOn
| Opt_Ticky | Opt_Ticky
| Opt_Static | Opt_Static
| Opt_RelativeDynlibPaths
| Opt_Hpc | Opt_Hpc
-- output style opts -- output style opts
...@@ -1780,6 +1781,7 @@ dynamic_flags = [ ...@@ -1780,6 +1781,7 @@ dynamic_flags = [
addWay WayDyn)) addWay WayDyn))
-- ignored for compat w/ gcc: -- ignored for compat w/ gcc:
, Flag "rdynamic" (NoArg (return ())) , Flag "rdynamic" (NoArg (return ()))
, Flag "relative-dynlib-paths" (NoArg (setDynFlag Opt_RelativeDynlibPaths))
------- Specific phases -------------------------------------------- ------- Specific phases --------------------------------------------
-- need to appear before -pgmL to be parsed as LLVM flags. -- need to appear before -pgmL to be parsed as LLVM flags.
......
...@@ -87,6 +87,7 @@ module Util ( ...@@ -87,6 +87,7 @@ module Util (
escapeSpaces, escapeSpaces,
parseSearchPath, parseSearchPath,
Direction(..), reslash, Direction(..), reslash,
makeRelativeTo,
-- * Utils for defining Data instances -- * Utils for defining Data instances
abstractConstr, abstractDataType, mkNoRepType, abstractConstr, abstractDataType, mkNoRepType,
...@@ -1006,6 +1007,17 @@ reslash d = f ...@@ -1006,6 +1007,17 @@ reslash d = f
slash = case d of slash = case d of
Forwards -> '/' Forwards -> '/'
Backwards -> '\\' Backwards -> '\\'
makeRelativeTo :: FilePath -> FilePath -> FilePath
this `makeRelativeTo` that = directory </> thisFilename
where (thisDirectory, thisFilename) = splitFileName this
thatDirectory = dropFileName that
directory = joinPath $ f (splitPath thisDirectory)
(splitPath thatDirectory)
f (x : xs) (y : ys)
| x == y = f xs ys
f xs ys = replicate (length ys) ".." ++ xs
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment