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

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

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.

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}
 
 %************************************************************************