Hadrian: support dynamically linking ghc
authorDavid Eichmann <EichmannD@gmail.com>
Thu, 29 Nov 2018 17:22:16 +0000 (18:22 +0100)
committerAlp Mestanogullari <alpmestan@gmail.com>
Thu, 29 Nov 2018 17:22:17 +0000 (18:22 +0100)
* (#15837 point 5) Use the -rpath gcc option and using the $ORIGIN
variable which the dynamic linker sets to the location of the ghc
binary.
* (#15837 point 4) "-fPIC -dynamic" options are used when building ghc
when either ghc or the rts have a dynamic way.
* (#15837 point 7) "-shared -dynload deploy" options are only used when
linking a library (no longer when linking a program).

Reviewers: bgamari, alpmestan

Reviewed By: alpmestan

Subscribers: adamse, rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5281

hadrian/src/Context.hs
hadrian/src/Hadrian/Utilities.hs
hadrian/src/Settings/Builders/Ghc.hs

index 3269714..7459011 100644 (file)
@@ -8,7 +8,7 @@ module Context (
     -- * Paths
     contextDir, buildPath, buildDir, pkgInplaceConfig, pkgSetupConfigFile,
     pkgHaddockFile, pkgLibraryFile, pkgGhciLibraryFile, pkgConfFile, objectPath,
-    contextPath, getContextPath, libDir, libPath
+    contextPath, getContextPath, libDir, libPath, distDir
     ) where
 
 import Base
@@ -46,10 +46,19 @@ getStagedSettingList f = getSettingList . f =<< getStage
 libDir :: Context -> FilePath
 libDir Context {..} = stageString stage -/- "lib"
 
--- | Path to the directory containg the final artifact in a given 'Context'
+-- | Path to the directory containg the final artifact in a given 'Context'.
 libPath :: Context -> Action FilePath
 libPath context = buildRoot <&> (-/- libDir context)
 
+-- | Get the directory name for binary distribution files
+-- <arch>-<os>-ghc-<version>.
+distDir :: Action FilePath
+distDir = do
+    version        <- setting ProjectVersion
+    hostOs         <- setting BuildOs
+    hostArch       <- setting BuildArch
+    return $ hostArch ++ "-" ++ hostOs ++ "-ghc-" ++ version
+
 pkgFile :: Context -> String -> String -> Action FilePath
 pkgFile context@Context {..} prefix suffix = do
     path <- buildPath context
index 88b5bad..3e5d7b3 100644 (file)
@@ -7,7 +7,7 @@ module Hadrian.Utilities (
     quote, yesNo, parseYesNo, zeroOne,
 
     -- * FilePath manipulation
-    unifyPath, (-/-),
+    unifyPath, (-/-), makeRelativeNoSysLink,
 
     -- * Accessing Shake's type-indexed map
     insertExtra, lookupExtra, userSetting,
@@ -37,6 +37,7 @@ import Control.Monad.Extra
 import Data.Char
 import Data.Dynamic (Dynamic, fromDynamic, toDyn)
 import Data.HashMap.Strict (HashMap)
+import Data.List (isPrefixOf)
 import Data.List.Extra
 import Data.Maybe
 import Data.Typeable (TypeRep, typeOf)
@@ -139,6 +140,74 @@ a  -/- b
 
 infixr 6 -/-
 
+-- | This is like Posix makeRelative, but assumes no sys links in the input
+-- paths. This allows the result to start with possibly many "../"s. Input
+-- paths must both be relative, or be on the same drive
+makeRelativeNoSysLink :: FilePath -> FilePath  -> FilePath
+makeRelativeNoSysLink a b
+    | aDrive == bDrive
+        = if aToB == []
+            then "."
+            else joinPath aToB
+    | otherwise
+        = error $ if isRelative a /= isRelative b
+            then "Paths must both be relative or both be absolute, but got"
+                    ++ " \"" ++ a      ++ "\" and \"" ++ b      ++ "\""
+            else "Paths are on different drives "
+                    ++ " \"" ++ aDrive ++ "\" and \"" ++ bDrive ++ "\""
+    where
+        (aDrive, aRelPath) = splitDrive a
+        (bDrive, bRelPath) = splitDrive b
+
+        aRelSplit = removeIndirections (splitPath aRelPath)
+        bRelSplit = removeIndirections (splitPath bRelPath)
+
+        -- Use removePrefix to get the relative paths relative to a new
+        -- base directory as high in the directory tree as possible.
+        (baseToA, baseToB) = removePrefix aRelSplit bRelSplit
+        aToBase = if isDirUp (head baseToA)
+                    -- if baseToA contains any '..' then there is no way to get
+                    -- a path from a to the base directory.
+                    -- E.g. if   baseToA == "../u/v"
+                    --      then aToBase == "../../<UnknownDir>"
+                    then error $ "Impossible to find relatieve path from "
+                                    ++ a ++ " to " ++ b
+                    else".." <$ baseToA
+        aToB = aToBase ++ baseToB
+
+        -- removePrefix "pre123" "prefix456" == ("123", "fix456")
+        removePrefix :: Eq a => [a] -> [a] -> ([a], [a])
+        removePrefix as [] = (as, [])
+        removePrefix [] bs = ([], bs)
+        removePrefix (a:as) (b:bs)
+            | a == b    = removePrefix as bs
+            | otherwise = (a:as, b:bs)
+
+        -- Removes all '.', and tries to remove all '..'. In some cases '..'s
+        -- cannot be removes, but will all appear to the left.
+        -- e.g. removeIndirections "../a/./b/../../../c" == "../../c"
+        removeIndirections :: [String] -> [String]
+        removeIndirections [] = []
+        removeIndirections (x:xs)
+            -- Remove all '.'
+            | isDot   x = removeIndirections xs
+            -- Bubble all '..' to the left
+            | otherwise = case removeIndirections xs of
+                        []     -> [x]
+                        -- Only when x /= '..' and y == '..' do we need to
+                        -- bubble to the left. In that case they cancel out
+                        (y:ys) -> if not (isDirUp x) && isDirUp y
+                                    then ys
+                                    else x : y : ys
+
+        isDirUp ".." = True
+        isDirUp "../" = True
+        isDirUp _ = False
+
+        isDot "." = True
+        isDot "./" = True
+        isDot _ = False
+
 -- | Like Shake's '%>' but gives higher priority to longer patterns. Useful
 -- in situations when a family of build rules, e.g. @"//*.a"@ and @"//*_p.a"@
 -- can be matched by the same file, such as @library_p.a@. We break the tie
index 8212b5f..04aea32 100644 (file)
@@ -7,6 +7,7 @@ import Flavour
 import Packages
 import Settings.Builders.Common
 import Settings.Warnings
+import qualified Context as Context
 
 ghcBuilderArgs :: Args
 ghcBuilderArgs = mconcat [compileAndLinkHs, compileC, findHsDependencies]
@@ -41,13 +42,30 @@ compileC = builder (Ghc CompileCWithGhc) ? do
 
 ghcLinkArgs :: Args
 ghcLinkArgs = builder (Ghc LinkHs) ? do
-    way     <- getWay
     pkg     <- getPackage
     libs    <- pkg == hp2ps ? pure ["m"]
     intLib  <- getIntegerPackage
     gmpLibs <- notStage0 ? intLib == integerGmp ? pure ["gmp"]
-    mconcat [ (Dynamic `wayUnit` way) ?
-              pure [ "-shared", "-dynamic", "-dynload", "deploy" ]
+    dynamic <- requiresDynamic
+
+    -- Relative path from the output (rpath $ORIGIN).
+    originPath <- dropFileName <$> getOutput
+    context <- getContext
+    libPath' <- expr (libPath context)
+    distDir <- expr Context.distDir
+    let
+        distPath = libPath' -/- distDir
+        originToLibsDir = makeRelativeNoSysLink originPath distPath
+
+    mconcat [ dynamic ? mconcat
+                [ arg "-dynamic"
+                -- TODO what about windows / OSX?
+                , notStage0 ? pure
+                    [ "-optl-Wl,-rpath"
+                    , "-optl-Wl," ++ ("$ORIGIN" -/- originToLibsDir) ]
+                ]
+            , (dynamic && isLibrary pkg) ?
+                pure [ "-shared", "-dynload", "deploy" ]
             , arg "-no-auto-link-packages"
             ,      nonHsMainPackage pkg  ? arg "-no-hs-main"
             , not (nonHsMainPackage pkg) ? arg "-rtsopts"
@@ -96,9 +114,10 @@ commonGhcArgs = do
 wayGhcArgs :: Args
 wayGhcArgs = do
     way <- getWay
-    mconcat [ if (Dynamic `wayUnit` way)
-              then pure ["-fPIC", "-dynamic"]
-              else arg "-static"
+    dynamic <- requiresDynamic
+    mconcat [ if dynamic
+                then pure ["-fPIC", "-dynamic"]
+                else arg "-static"
             , (Threaded  `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
             , (Debug     `wayUnit` way) ? arg "-optc-DDEBUG"
             , (Profiling `wayUnit` way) ? arg "-prof"
@@ -132,3 +151,17 @@ includeGhcArgs = do
             , arg $      "-I" ++ root -/- generatedDir
             , arg $ "-optc-I" ++ root -/- generatedDir
             , pure ["-optP-include", "-optP" ++ autogen -/- "cabal_macros.h"] ]
+
+-- Check if building dynamically is required. GHC is a special case that needs
+-- to be built dynamically if any of the RTS ways is dynamic.
+requiresDynamic :: Expr Bool
+requiresDynamic = do
+    pkg <- getPackage
+    way <- getWay
+    rtsWays <- getRtsWays
+    let
+        dynRts = any (Dynamic `wayUnit`) rtsWays
+        dynWay = Dynamic `wayUnit` way
+    return $ if pkg == ghc
+                then dynRts || dynWay
+                else dynWay