From 58eaacc9967b7c627a66d49047fb447ac065706e Mon Sep 17 00:00:00 2001
From: Ian Lynagh <ian@well-typed.com>
Date: Mon, 1 Oct 2012 21:39:04 +0100
Subject: 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 0566d6ad65..e0bea39020 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 5e3f7e001b..97d0675802 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 87171545f8..f9927de2f0 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}
 
 %************************************************************************
-- 
cgit v1.2.1