diff options
| -rw-r--r-- | hadrian/src/Context.hs | 13 | ||||
| -rw-r--r-- | hadrian/src/Hadrian/Utilities.hs | 71 | ||||
| -rw-r--r-- | hadrian/src/Settings/Builders/Ghc.hs | 45 |
3 files changed, 120 insertions, 9 deletions
diff --git a/hadrian/src/Context.hs b/hadrian/src/Context.hs index 3269714c29..745901159d 100644 --- a/hadrian/src/Context.hs +++ b/hadrian/src/Context.hs @@ -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 diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs index 88b5bad911..3e5d7b37db 100644 --- a/hadrian/src/Hadrian/Utilities.hs +++ b/hadrian/src/Hadrian/Utilities.hs @@ -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 diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs index 8212b5fbcf..04aea32d07 100644 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -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 |