Commit 79d5427e authored by David Eichmann's avatar David Eichmann 🏋 Committed by Alp Mestanogullari

Hadrian: support dynamically linking ghc

* (#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
parent fb997160
......@@ -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
......
......@@ -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
......
......@@ -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
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