|
| 1 | +diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs |
| 2 | +index aa51a2b7d6..04ae43cdae 100644 |
| 3 | +--- a/compiler/GHC/Linker/Static.hs |
| 4 | ++++ b/compiler/GHC/Linker/Static.hs |
| 5 | +@@ -32,6 +32,8 @@ import GHC.Linker.Static.Utils |
| 6 | + import GHC.Driver.Config.Linker |
| 7 | + import GHC.Driver.Session |
| 8 | + |
| 9 | ++import qualified GHC.Data.ShortText as ST |
| 10 | ++ |
| 11 | + import System.FilePath |
| 12 | + import System.Directory |
| 13 | + import Control.Monad |
| 14 | +@@ -294,11 +296,9 @@ linkStaticLib logger dflags unit_env o_files dep_units = do |
| 15 | + | otherwise |
| 16 | + = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init |
| 17 | + |
| 18 | +- archives <- concatMapM (collectArchives namever ways_) pkg_cfgs |
| 19 | +- |
| 20 | +- ar <- foldl mappend |
| 21 | +- <$> (Archive <$> mapM loadObj modules) |
| 22 | +- <*> mapM loadAr archives |
| 23 | ++ arFromArchives <- mconcat <$> mapM (loadArchives namever ways_) pkg_cfgs |
| 24 | ++ arFromObjects <- Archive <$> mapM loadObj modules |
| 25 | ++ let ar = arFromObjects `mappend` arFromArchives |
| 26 | + |
| 27 | + if toolSettings_ldIsGnuLd (toolSettings dflags) |
| 28 | + then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar |
| 29 | +@@ -306,3 +306,18 @@ linkStaticLib logger dflags unit_env o_files dep_units = do |
| 30 | + |
| 31 | + -- run ranlib over the archive. write*Ar does *not* create the symbol index. |
| 32 | + runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] |
| 33 | ++ |
| 34 | ++loadArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO Archive |
| 35 | ++loadArchives namever ways pc = loadArchivesFromLibs libs |
| 36 | ++ where |
| 37 | ++ libs = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc) |
| 38 | ++ loadArchivesFromLibs :: [LibName] -> IO Archive |
| 39 | ++ loadArchivesFromLibs libs = do |
| 40 | ++ arPaths <- collectArchivesFromLibs namever ways pc libs |
| 41 | ++ fmap mconcat $ forM arPaths $ \arPath -> do |
| 42 | ++ arOrScript <- loadArchiveOrScript arPath |
| 43 | ++ case arOrScript of |
| 44 | ++ Ar ar -> return ar |
| 45 | ++ ImplicitLinkerScript linkerScript -> |
| 46 | ++ case linkerScript of |
| 47 | ++ INPUT libNames -> loadArchivesFromLibs libNames |
| 48 | +\ No newline at end of file |
| 49 | +diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs |
| 50 | +index 6965edd707..7266bd0082 100644 |
| 51 | +--- a/compiler/GHC/Linker/Unit.hs |
| 52 | ++++ b/compiler/GHC/Linker/Unit.hs |
| 53 | +@@ -2,7 +2,7 @@ |
| 54 | + -- | Linking Haskell units |
| 55 | + module GHC.Linker.Unit |
| 56 | + ( collectLinkOpts |
| 57 | +- , collectArchives |
| 58 | ++ , collectArchivesFromLibs |
| 59 | + , getUnitLinkOpts |
| 60 | + , getLibs |
| 61 | + ) |
| 62 | +@@ -39,13 +39,12 @@ collectLinkOpts namever ways ps = |
| 63 | + concatMap (map ST.unpack . unitLinkerOptions) ps |
| 64 | + ) |
| 65 | + |
| 66 | +-collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath] |
| 67 | +-collectArchives namever ways pc = |
| 68 | ++collectArchivesFromLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String] -> IO [FilePath] |
| 69 | ++collectArchivesFromLibs namever ways pc libs = |
| 70 | + filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a") |
| 71 | + | searchPath <- searchPaths |
| 72 | + , lib <- libs ] |
| 73 | + where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc |
| 74 | +- libs = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc) |
| 75 | + |
| 76 | + -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. |
| 77 | + libraryDirsForWay :: Ways -> UnitInfo -> [String] |
| 78 | +diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs |
| 79 | +index adba60b53c..351103fd4c 100644 |
| 80 | +--- a/compiler/GHC/SysTools/Ar.hs |
| 81 | ++++ b/compiler/GHC/SysTools/Ar.hs |
| 82 | +@@ -20,11 +20,15 @@ of libtool across different platforms. |
| 83 | + module GHC.SysTools.Ar |
| 84 | + (ArchiveEntry(..) |
| 85 | + ,Archive(..) |
| 86 | ++ ,ArchiveOrScript(..) |
| 87 | ++ ,LinkerScript(..) |
| 88 | ++ ,LibName |
| 89 | + ,afilter |
| 90 | + |
| 91 | + ,parseAr |
| 92 | + |
| 93 | + ,loadAr |
| 94 | ++ ,loadArchiveOrScript |
| 95 | + ,loadObj |
| 96 | + ,writeBSDAr |
| 97 | + ,writeGNUAr |
| 98 | +@@ -45,6 +49,7 @@ import Control.Applicative |
| 99 | + import qualified Data.ByteString as B |
| 100 | + import qualified Data.ByteString.Char8 as C |
| 101 | + import qualified Data.ByteString.Lazy as L |
| 102 | ++import qualified Text.ParserCombinators.ReadP as R |
| 103 | + #if !defined(mingw32_HOST_OS) |
| 104 | + import qualified System.Posix.Files as POSIX |
| 105 | + #endif |
| 106 | +@@ -230,6 +235,68 @@ putGNUArch (Archive as) = do |
| 107 | + processEntries = |
| 108 | + uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty) |
| 109 | + |
| 110 | ++-- | Some systems have archives that are not really archives but contain so |
| 111 | ++-- called linker scripts. These scripts contain textual commands to the |
| 112 | ++-- linker. This data type represents this choice between an actual archive or |
| 113 | ++-- implicit linker script. |
| 114 | ++-- |
| 115 | ++-- See: https://sourceware.org/binutils/docs/ld/Implicit-Linker-Scripts.html#Implicit-Linker-Scripts |
| 116 | ++data ArchiveOrScript = Ar Archive | ImplicitLinkerScript LinkerScript |
| 117 | ++ deriving (Eq, Show) |
| 118 | ++ |
| 119 | ++-- | An AST for a linker script. |
| 120 | ++-- |
| 121 | ++-- At the moment this AST only supports linker scripts of the form: |
| 122 | ++-- |
| 123 | ++-- @INPUT(-lc++_static -lc++abi)@ |
| 124 | ++-- |
| 125 | ++-- Since this is exactly what is used in @nixpkgs@ for @libc++.a@. |
| 126 | ++-- |
| 127 | ++-- For more information on linker scripts see: |
| 128 | ++-- https://sourceware.org/binutils/docs/ld/Scripts.html |
| 129 | ++data LinkerScript = INPUT [LibName] |
| 130 | ++ deriving (Eq, Show) |
| 131 | ++ |
| 132 | ++-- | Name of a library to link with. |
| 133 | ++-- |
| 134 | ++-- This is everything after the @-l@ prefix. |
| 135 | ++type LibName = String |
| 136 | ++ |
| 137 | ++linkerScriptReadP :: R.ReadP LinkerScript |
| 138 | ++linkerScriptReadP = skipSpaceChars *> inputReadP <* R.skipSpaces |
| 139 | ++ where |
| 140 | ++ inputReadP :: R.ReadP LinkerScript |
| 141 | ++ inputReadP = fmap INPUT $ R.between (symbol "INPUT(") (symbol ")") $ |
| 142 | ++ R.sepBy libReadP sep <* skipSpaceChars |
| 143 | ++ where |
| 144 | ++ libReadP :: R.ReadP LibName |
| 145 | ++ libReadP = R.string "-l" *> R.many1 (R.satisfy isLibNameChar) |
| 146 | ++ where |
| 147 | ++ isLibNameChar c = c /= ')' && c /= ',' && c /= ' ' |
| 148 | ++ |
| 149 | ++ sep :: R.ReadP () |
| 150 | ++ sep = R.char ' ' *> skipSpaceChars |
| 151 | ++ |
| 152 | ++ symbol :: String -> R.ReadP () |
| 153 | ++ symbol str = R.string str *> skipSpaceChars |
| 154 | ++ |
| 155 | ++ skipSpaceChars :: R.ReadP () |
| 156 | ++ skipSpaceChars = do |
| 157 | ++ s <- R.look |
| 158 | ++ skip s |
| 159 | ++ where |
| 160 | ++ skip (' ':s) = do _ <- R.get; skip s |
| 161 | ++ skip _ = do return () |
| 162 | ++ |
| 163 | ++parseArOrScript :: B.ByteString -> Either (ByteOffset, String) ArchiveOrScript |
| 164 | ++parseArOrScript bs = |
| 165 | ++ case runGetOrFail getArch $ L.fromChunks $ pure bs of |
| 166 | ++ Left (_, pos, msg) -> |
| 167 | ++ case R.readP_to_S linkerScriptReadP $ C.unpack bs of |
| 168 | ++ [(linkerScript, "")] -> Right $ ImplicitLinkerScript linkerScript |
| 169 | ++ _ -> Left (pos, msg) |
| 170 | ++ Right (_, _, ar) -> Right $ Ar ar |
| 171 | ++ |
| 172 | + parseAr :: B.ByteString -> Archive |
| 173 | + parseAr = runGet getArch . L.fromChunks . pure |
| 174 | + |
| 175 | +@@ -240,6 +307,18 @@ writeGNUAr fp = L.writeFile fp . runPut . putGNUArch |
| 176 | + loadAr :: FilePath -> IO Archive |
| 177 | + loadAr fp = parseAr <$> B.readFile fp |
| 178 | + |
| 179 | ++loadArchiveOrScript :: FilePath -> IO ArchiveOrScript |
| 180 | ++loadArchiveOrScript fp = do |
| 181 | ++ bs <- B.readFile fp |
| 182 | ++ case parseArOrScript bs of |
| 183 | ++ Left (pos, msg) -> |
| 184 | ++ error $ |
| 185 | ++ "Error while decoding archive: " <> fp <> |
| 186 | ++ " is neither an archive because decoding failed at position " <> |
| 187 | ++ show pos <> " with error " <> msg <> |
| 188 | ++ ", nor is it an implicit linker script!" |
| 189 | ++ Right arOrScript -> return arOrScript |
| 190 | ++ |
| 191 | + loadObj :: FilePath -> IO ArchiveEntry |
| 192 | + loadObj fp = do |
| 193 | + payload <- B.readFile fp |
0 commit comments