[commit: ghc] master: Add a flag to tell ghc to use $ORIGIN when linking program dynamically (58eaacc)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/58eaacc9967b7c627a66d49047fb447ac065706e

>---------------------------------------------------------------

commit 58eaacc9967b7c627a66d49047fb447ac065706e
Author: Ian Lynagh <[email protected]>
Date:   Mon Oct 1 21:39:04 2012 +0100

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

>---------------------------------------------------------------

 compiler/main/DriverPipeline.hs |   14 ++++++++++++--
 compiler/main/DynFlags.hs       |    2 ++
 compiler/utils/Util.lhs         |   12 ++++++++++++
 3 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 0566d6a..e0bea39 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1662,13 +1662,23 @@ linkBinary dflags o_files dep_packages = do
     -- explicit packages with the auto packages and all of their
     -- 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
-    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
          | osElfTarget (platformOS platform) &&
            dynLibLoader dflags == SystemDependent &&
            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]
 
     let lib_paths = libraryPaths dflags
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5e3f7e0..97d0675 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -339,6 +339,7 @@ data DynFlag
    | Opt_SccProfilingOn
    | Opt_Ticky
    | Opt_Static
+   | Opt_RelativeDynlibPaths
    | Opt_Hpc
 
    -- output style opts
@@ -1780,6 +1781,7 @@ dynamic_flags = [
                                      addWay WayDyn))
     -- ignored for compat w/ gcc:
   , Flag "rdynamic"       (NoArg (return ()))
+  , Flag "relative-dynlib-paths"  (NoArg (setDynFlag Opt_RelativeDynlibPaths))
 
         ------- Specific phases  --------------------------------------------
     -- need to appear before -pgmL to be parsed as LLVM flags.
diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index 8717154..f9927de 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -87,6 +87,7 @@ module Util (
         escapeSpaces,
         parseSearchPath,
         Direction(..), reslash,
+        makeRelativeTo,
 
         -- * Utils for defining Data instances
         abstractConstr, abstractDataType, mkNoRepType,
@@ -1006,6 +1007,17 @@ reslash d = f
           slash = case d of
                   Forwards -> '/'
                   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}
 
 %************************************************************************