diff options
Diffstat (limited to 'compiler/GHC/Linker/Unit.hs')
| -rw-r--r-- | compiler/GHC/Linker/Unit.hs | 95 |
1 files changed, 12 insertions, 83 deletions
diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs index 90326859f4..7aec5263e3 100644 --- a/compiler/GHC/Linker/Unit.hs +++ b/compiler/GHC/Linker/Unit.hs @@ -3,11 +3,8 @@ module GHC.Linker.Unit ( collectLinkOpts , collectArchives - , collectLibraryPaths , getUnitLinkOpts - , getUnitLibraryPath , getLibs - , packageHsLibs ) where @@ -16,35 +13,28 @@ import GHC.Platform.Ways import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.State -import GHC.Unit.Home -import GHC.Utils.Outputable -import GHC.Utils.Panic +import GHC.Unit.Env import GHC.Utils.Misc import qualified GHC.Data.ShortText as ST import GHC.Driver.Session -import qualified Data.Set as Set -import Data.List (isPrefixOf, stripPrefix) import Control.Monad import System.Directory import System.FilePath -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String]) -getUnitLinkOpts dflags pkgs = - collectLinkOpts dflags `fmap` getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - pkgs +getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String]) +getUnitLinkOpts dflags unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs + return (collectLinkOpts dflags ps) collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) collectLinkOpts dflags ps = ( - concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps, concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps, concatMap (map ST.unpack . unitLinkerOptions) ps ) @@ -55,11 +45,7 @@ collectArchives dflags pc = | searchPath <- searchPaths , lib <- libs ] where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc - libs = packageHsLibs dflags pc ++ map ST.unpack (unitExtDepLibsSys pc) - -collectLibraryPaths :: Ways -> [UnitInfo] -> [FilePath] -collectLibraryPaths ws = ordNub . filter notNull - . concatMap (libraryDirsForWay ws) + libs = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc) -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] @@ -67,68 +53,11 @@ libraryDirsForWay ws | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs | otherwise = map ST.unpack . unitLibraryDirs -getLibs :: DynFlags -> [UnitId] -> IO [(String,String)] -getLibs dflags pkgs = do - ps <- getPreloadUnitsAnd - (initSDocContext dflags defaultUserStyle) - (unitState dflags) - (mkHomeUnitFromFlags dflags) - pkgs +getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)] +getLibs dflags unit_env pkgs = do + ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs fmap concat . forM ps $ \p -> do - let candidates = [ (l </> f, f) | l <- collectLibraryPaths (ways dflags) [p] - , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + let candidates = [ (l </> f, f) | l <- collectLibraryDirs (ways dflags) [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways dflags) p ] filterM (doesFileExist . fst) candidates --- | Find all the library paths in these and the preload packages -getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String] -getUnitLibraryPath ctx unit_state home_unit ws pkgs = - collectLibraryPaths ws `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs - -packageHsLibs :: DynFlags -> UnitInfo -> [String] -packageHsLibs dflags p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) - where - ways0 = ways dflags - - ways1 = Set.filter (/= WayDyn) ways0 - -- the name of a shared library is libHSfoo-ghc<version>.so - -- we leave out the _dyn, because it is superfluous - - -- debug and profiled RTSs include support for -eventlog - ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1 - = Set.filter (/= WayTracing) ways1 - | otherwise - = ways1 - - tag = waysTag (fullWays ways2) - rts_tag = waysTag ways2 - - mkDynName x - | not (ways dflags `hasWay` WayDyn) = x - | "HS" `isPrefixOf` x = - x ++ '-':programName dflags ++ projectVersion dflags - -- For non-Haskell libraries, we use the name "Cfoo". The .a - -- file is libCfoo.a, and the .so is libfoo.so. That way the - -- linker knows what we mean for the vanilla (-lCfoo) and dyn - -- (-lfoo) ways. We therefore need to strip the 'C' off here. - | Just x' <- stripPrefix "C" x = x' - | otherwise - = panic ("Don't understand library name " ++ x) - - -- Add _thr and other rts suffixes to packages named - -- `rts` or `rts-1.0`. Why both? Traditionally the rts - -- package is called `rts` only. However the tooling - -- usually expects a package name to have a version. - -- As such we will gradually move towards the `rts-1.0` - -- package name, at which point the `rts` package name - -- will eventually be unused. - -- - -- This change elevates the need to add custom hooks - -- and handling specifically for the `rts` package for - -- example in ghc-cabal. - addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) - addSuffix other_lib = other_lib ++ (expandTag tag) - - expandTag t | null t = "" - | otherwise = '_':t - |