Make “sublibrary” standard terminology in docs
[cabal.git] / Cabal / src / Distribution / Simple / Program / Ar.hs
blobb5d1cfe65e66dff4b722f62adc2083e4bc532b3c
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE NondecreasingIndentation #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE RankNTypes #-}
6 -----------------------------------------------------------------------------
8 -- |
9 -- Module : Distribution.Simple.Program.Ar
10 -- Copyright : Duncan Coutts 2009
12 -- Maintainer : cabal-devel@haskell.org
13 -- Portability : portable
15 -- This module provides an library interface to the @ar@ program.
16 module Distribution.Simple.Program.Ar
17 ( createArLibArchive
18 , multiStageProgramInvocation
19 ) where
21 import Distribution.Compat.Prelude
22 import Prelude ()
24 import qualified Data.ByteString as BS
25 import qualified Data.ByteString.Char8 as BS8
26 import Distribution.Compat.CopyFile (filesEqual)
27 import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)
28 import Distribution.Simple.Flag
29 ( fromFlagOrDefault
31 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
32 import Distribution.Simple.Program
33 ( ProgramInvocation
34 , arProgram
35 , requireProgram
37 import Distribution.Simple.Program.ResponseFile
38 ( withResponseFile
40 import Distribution.Simple.Program.Run
41 ( multiStageProgramInvocation
42 , programInvocation
43 , runProgramInvocation
45 import Distribution.Simple.Setup.Config
46 ( configUseResponseFiles
48 import Distribution.Simple.Utils
49 ( defaultTempFileOptions
50 , dieWithLocation'
51 , withTempDirectory
53 import Distribution.System
54 ( Arch (..)
55 , OS (..)
56 , Platform (..)
58 import Distribution.Verbosity
59 ( Verbosity
60 , deafening
61 , verbose
63 import System.Directory (doesFileExist, renameFile)
64 import System.FilePath (splitFileName, (</>))
65 import System.IO
66 ( Handle
67 , IOMode (ReadWriteMode)
68 , SeekMode (AbsoluteSeek)
69 , hFileSize
70 , hSeek
71 , withBinaryFile
74 -- | Call @ar@ to create a library archive from a bunch of object files.
75 createArLibArchive
76 :: Verbosity
77 -> LocalBuildInfo
78 -> FilePath
79 -> [FilePath]
80 -> IO ()
81 createArLibArchive verbosity lbi targetPath files = do
82 (ar, _) <- requireProgram verbosity arProgram progDb
84 let (targetDir, targetName) = splitFileName targetPath
85 withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do
86 let tmpPath = tmpDir </> targetName
88 -- The args to use with "ar" are actually rather subtle and system-dependent.
89 -- In particular we have the following issues:
91 -- -- On OS X, "ar q" does not make an archive index. Archives with no
92 -- index cannot be used.
94 -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us
95 -- do that. We have duplicates because of modules like "A.M" and "B.M"
96 -- both make an object file "M.o" and ar does not consider the directory.
98 -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier
99 -- in "q" mode which compels the archiver to add the members of an input
100 -- archive to the output, rather than the archive itself. This is
101 -- necessary as GHC may produce .o files that are actually archives. See
102 -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068.
104 -- Our solution is to use "ar r" in the simple case when one call is enough.
105 -- When we need to call ar multiple times we use "ar q" and for the last
106 -- call on OSX we use "ar qs" so that it'll make the index.
108 let simpleArgs = case hostOS of
109 OSX -> ["-r", "-s"]
110 _ | dashLSupported -> ["-qL"]
111 _ -> ["-r"]
113 initialArgs = ["-q"]
114 finalArgs = case hostOS of
115 OSX -> ["-q", "-s"]
116 _ | dashLSupported -> ["-qL"]
117 _ -> ["-q"]
119 extraArgs = verbosityOpts verbosity ++ [tmpPath]
121 simple = programInvocation ar (simpleArgs ++ extraArgs)
122 initial = programInvocation ar (initialArgs ++ extraArgs)
123 middle = initial
124 final = programInvocation ar (finalArgs ++ extraArgs)
126 oldVersionManualOverride =
127 fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
128 responseArgumentsNotSupported =
129 not (arResponseFilesSupported (compiler lbi))
130 dashLSupported =
131 arDashLSupported (compiler lbi)
133 invokeWithResponesFile :: FilePath -> ProgramInvocation
134 invokeWithResponesFile atFile =
135 programInvocation ar $
136 simpleArgs ++ extraArgs ++ ['@' : atFile]
138 if oldVersionManualOverride || responseArgumentsNotSupported
139 then
140 sequence_
141 [ runProgramInvocation verbosity inv
142 | inv <-
143 multiStageProgramInvocation
144 simple
145 (initial, middle, final)
146 files
148 else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $
149 \path -> runProgramInvocation verbosity $ invokeWithResponesFile path
151 unless
152 ( hostArch == Arm -- See #1537
153 || hostOS == AIX
155 $ wipeMetadata verbosity tmpPath -- AIX uses its own "ar" format variant
156 equal <- filesEqual tmpPath targetPath
157 unless equal $ renameFile tmpPath targetPath
158 where
159 progDb = withPrograms lbi
160 Platform hostArch hostOS = hostPlatform lbi
161 verbosityOpts v
162 | v >= deafening = ["-v"]
163 | v >= verbose = []
164 | otherwise = ["-c"] -- Do not warn if library had to be created.
166 -- | @ar@ by default includes various metadata for each object file in their
167 -- respective headers, so the output can differ for the same inputs, making
168 -- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode
169 -- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644
170 -- for the file mode. However detecting whether @-D@ is supported seems
171 -- rather harder than just re-implementing this feature.
172 wipeMetadata :: Verbosity -> FilePath -> IO ()
173 wipeMetadata verbosity path = do
174 -- Check for existence first (ReadWriteMode would create one otherwise)
175 exists <- doesFileExist path
176 unless exists $ wipeError "Temporary file disappeared"
177 withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h
178 where
179 wipeError msg =
180 dieWithLocation' verbosity path Nothing $
181 "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
182 archLF = "!<arch>\x0a" -- global magic, 8 bytes
183 x60LF = "\x60\x0a" -- header magic, 2 bytes
184 metadata =
185 BS.concat
186 [ "0 " -- mtime, 12 bytes
187 , "0 " -- UID, 6 bytes
188 , "0 " -- GID, 6 bytes
189 , "0644 " -- mode, 8 bytes
191 headerSize :: Int
192 headerSize = 60
194 -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
195 wipeArchive :: Handle -> Integer -> IO ()
196 wipeArchive h archiveSize = do
197 global <- BS.hGet h (BS.length archLF)
198 unless (global == archLF) $ wipeError "Bad global header"
199 wipeHeader (toInteger $ BS.length archLF)
200 where
201 wipeHeader :: Integer -> IO ()
202 wipeHeader offset = case compare offset archiveSize of
203 EQ -> return ()
204 GT -> wipeError (atOffset "Archive truncated")
205 LT -> do
206 header <- BS.hGet h headerSize
207 unless (BS.length header == headerSize) $
208 wipeError (atOffset "Short header")
209 let magic = BS.drop 58 header
210 unless (magic == x60LF) . wipeError . atOffset $
211 "Bad magic " ++ show magic ++ " in header"
213 let name = BS.take 16 header
214 let size = BS.take 10 $ BS.drop 48 header
215 objSize <- case reads (BS8.unpack size) of
216 [(n, s)] | all isSpace s -> return n
217 _ -> wipeError (atOffset "Bad file size in header")
219 let replacement = BS.concat [name, metadata, size, magic]
220 unless (BS.length replacement == headerSize) $
221 wipeError (atOffset "Something has gone terribly wrong")
222 hSeek h AbsoluteSeek offset
223 BS.hPut h replacement
225 let nextHeader =
226 offset
227 + toInteger headerSize
229 -- Odd objects are padded with an extra '\x0a'
230 if odd objSize then objSize + 1 else objSize
231 hSeek h AbsoluteSeek nextHeader
232 wipeHeader nextHeader
233 where
234 atOffset msg = msg ++ " at offset " ++ show offset