Add dump flag for timing output
[ghc.git] / compiler / main / Ar.hs
1 {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
2 {- Note: [The need for Ar.hs]
3 Building `-staticlib` required the presence of libtool, and was a such
4 restricted to mach-o only. As libtool on macOS and gnu libtool are very
5 different, there was no simple portable way to support this.
6
7 libtool for static archives does essentially: concatinate the input archives,
8 add the input objects, and create a symbol index. Using `ar` for this task
9 fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
10 features across platforms (e.g. index prefixed retrieval of objects with
11 the same name.)
12
13 As Archives are rather simple structurally, we can just build the archives
14 with Haskell directly and use ranlib on the final result to get the symbol
15 index. This should allow us to work around with the differences/abailability
16 of libtool across differet platforms.
17 -}
18 module Ar
19 (ArchiveEntry(..)
20 ,Archive(..)
21 ,afilter
22
23 ,parseAr
24
25 ,loadAr
26 ,loadObj
27 ,writeBSDAr
28 ,writeGNUAr
29
30 ,isBSDSymdef
31 ,isGNUSymdef
32 )
33 where
34
35 import GhcPrelude
36
37 import Data.Semigroup (Semigroup)
38 import Data.List (mapAccumL, isPrefixOf)
39 import Data.Monoid ((<>))
40 import Data.Binary.Get
41 import Data.Binary.Put
42 import Control.Monad
43 import Control.Applicative
44 import qualified Data.ByteString as B
45 import qualified Data.ByteString.Char8 as C
46 import qualified Data.ByteString.Lazy as L
47 #if !defined(mingw32_HOST_OS)
48 import qualified System.Posix.Files as POSIX
49 #endif
50 import System.FilePath (takeFileName)
51
52 data ArchiveEntry = ArchiveEntry
53 { filename :: String -- ^ File name.
54 , filetime :: Int -- ^ File modification time.
55 , fileown :: Int -- ^ File owner.
56 , filegrp :: Int -- ^ File group.
57 , filemode :: Int -- ^ File mode.
58 , filesize :: Int -- ^ File size.
59 , filedata :: B.ByteString -- ^ File bytes.
60 } deriving (Eq, Show)
61
62 newtype Archive = Archive [ArchiveEntry]
63 deriving (Eq, Show, Semigroup, Monoid)
64
65 afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
66 afilter f (Archive xs) = Archive (filter f xs)
67
68 isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
69 isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
70 isGNUSymdef a = "/" == (filename a)
71
72 -- | Archives have numeric values padded with '\x20' to the right.
73 getPaddedInt :: B.ByteString -> Int
74 getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
75
76 putPaddedInt :: Int -> Int -> Put
77 putPaddedInt padding i = putPaddedString '\x20' padding (show i)
78
79 putPaddedString :: Char -> Int -> String -> Put
80 putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
81
82 getBSDArchEntries :: Get [ArchiveEntry]
83 getBSDArchEntries = do
84 empty <- isEmpty
85 if empty then
86 return []
87 else do
88 name <- getByteString 16
89 when ('/' `C.elem` name && C.take 3 name /= "#1/") $
90 fail "Looks like GNU Archive"
91 time <- getPaddedInt <$> getByteString 12
92 own <- getPaddedInt <$> getByteString 6
93 grp <- getPaddedInt <$> getByteString 6
94 mode <- getPaddedInt <$> getByteString 8
95 st_size <- getPaddedInt <$> getByteString 10
96 end <- getByteString 2
97 when (end /= "\x60\x0a") $
98 fail "Invalid archive header end marker"
99 off1 <- liftM fromIntegral bytesRead :: Get Int
100 -- BSD stores extended filenames, by writing #1/<length> into the
101 -- name field, the first @length@ bytes then represent the file name
102 -- thus the payload size is filesize + file name length.
103 name <- if C.unpack (C.take 3 name) == "#1/" then
104 liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
105 else
106 return $ C.unpack $ C.takeWhile (/= ' ') name
107 off2 <- liftM fromIntegral bytesRead :: Get Int
108 file <- getByteString (st_size - (off2 - off1))
109 rest <- getBSDArchEntries
110 return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
111
112 -- | GNU Archives feature a special '//' entry that contains the
113 -- extended names. Those are referred to as /<num>, where num is the
114 -- offset into the '//' entry.
115 -- In addition, filenames are terminated with '/' in the archive.
116 getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
117 getGNUArchEntries extInfo = do
118 empty <- isEmpty
119 if empty
120 then return []
121 else
122 do
123 name <- getByteString 16
124 time <- getPaddedInt <$> getByteString 12
125 own <- getPaddedInt <$> getByteString 6
126 grp <- getPaddedInt <$> getByteString 6
127 mode <- getPaddedInt <$> getByteString 8
128 st_size <- getPaddedInt <$> getByteString 10
129 end <- getByteString 2
130 when (end /= "\x60\x0a") $
131 fail "Invalid archive header end marker"
132 file <- getByteString st_size
133 name <- return . C.unpack $
134 if C.unpack (C.take 1 name) == "/"
135 then case C.takeWhile (/= ' ') name of
136 name@"/" -> name -- symbol table
137 name@"//" -> name -- extendedn file names table
138 name -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
139 else C.takeWhile (/= '/') name
140 case name of
141 "/" -> getGNUArchEntries extInfo
142 "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
143 _ -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
144
145 where
146 getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
147 getExtName Nothing _ = error "Invalid extended filename reference."
148 getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
149
150 -- | put an Archive Entry. This assumes that the entries
151 -- have been preprocessed to account for the extenden file name
152 -- table section "//" e.g. for GNU Archives. Or that the names
153 -- have been move into the payload for BSD Archives.
154 putArchEntry :: ArchiveEntry -> PutM ()
155 putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
156 putPaddedString ' ' 16 name
157 putPaddedInt 12 time
158 putPaddedInt 6 own
159 putPaddedInt 6 grp
160 putPaddedInt 8 mode
161 putPaddedInt 10 (st_size + pad)
162 putByteString "\x60\x0a"
163 putByteString file
164 when (pad == 1) $
165 putWord8 0x0a
166 where
167 pad = st_size `mod` 2
168
169 getArchMagic :: Get ()
170 getArchMagic = do
171 magic <- liftM C.unpack $ getByteString 8
172 if magic /= "!<arch>\n"
173 then fail $ "Invalid magic number " ++ show magic
174 else return ()
175
176 putArchMagic :: Put
177 putArchMagic = putByteString $ C.pack "!<arch>\n"
178
179 getArch :: Get Archive
180 getArch = Archive <$> do
181 getArchMagic
182 getBSDArchEntries <|> getGNUArchEntries Nothing
183
184 putBSDArch :: Archive -> PutM ()
185 putBSDArch (Archive as) = do
186 putArchMagic
187 mapM_ putArchEntry (processEntries as)
188
189 where
190 padStr pad size str = take size $ str <> repeat pad
191 nameSize name = case length name `divMod` 4 of
192 (n, 0) -> 4 * n
193 (n, _) -> 4 * (n + 1)
194 needExt name = length name > 16 || ' ' `elem` name
195 processEntry :: ArchiveEntry -> ArchiveEntry
196 processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
197 | needExt name = archive { filename = "#1/" <> show sz
198 , filedata = C.pack (padStr '\0' sz name) <> filedata archive
199 , filesize = st_size + sz }
200 | otherwise = archive
201
202 where sz = nameSize name
203
204 processEntries = map processEntry
205
206 putGNUArch :: Archive -> PutM ()
207 putGNUArch (Archive as) = do
208 putArchMagic
209 mapM_ putArchEntry (processEntries as)
210
211 where
212 processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
213 processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
214 | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
215 , filedata = filedata extInfo <> C.pack name <> "/\n" }
216 , archive { filename = "/" <> show (filesize extInfo) } )
217 | otherwise = ( extInfo, archive { filename = name <> "/" } )
218
219 processEntries :: [ArchiveEntry] -> [ArchiveEntry]
220 processEntries =
221 uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
222
223 parseAr :: B.ByteString -> Archive
224 parseAr = runGet getArch . L.fromChunks . pure
225
226 writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
227 writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
228 writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
229
230 loadAr :: FilePath -> IO Archive
231 loadAr fp = parseAr <$> B.readFile fp
232
233 loadObj :: FilePath -> IO ArchiveEntry
234 loadObj fp = do
235 payload <- B.readFile fp
236 (modt, own, grp, mode) <- fileInfo fp
237 return $ ArchiveEntry
238 (takeFileName fp) modt own grp mode
239 (B.length payload) payload
240
241 -- | Take a filePath and return (mod time, own, grp, mode in decimal)
242 fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
243 #if defined(mingw32_HOST_OS)
244 -- on windows mod time, owner group and mode are zero.
245 fileInfo _ = pure (0,0,0,0)
246 #else
247 fileInfo fp = go <$> POSIX.getFileStatus fp
248 where go status = ( fromEnum $ POSIX.modificationTime status
249 , fromIntegral $ POSIX.fileOwner status
250 , fromIntegral $ POSIX.fileGroup status
251 , oct2dec . fromIntegral $ POSIX.fileMode status
252 )
253
254 oct2dec :: Int -> Int
255 oct2dec = foldl (\a b -> a * 10 + b) 0 . reverse . dec 8
256 where dec _ 0 = []
257 dec b i = let (rest, last) = i `quotRem` b
258 in last:dec b rest
259
260 #endif