never executed always true always false
1 {-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-}
2
3 --
4 -- (c) The University of Glasgow 2002-2006
5 --
6
7 {-# OPTIONS_GHC -O2 #-}
8 -- We always optimise this, otherwise performance of a non-optimised
9 -- compiler is severely affected
10
11 -- | Binary interface file support.
12 module GHC.Iface.Binary (
13 -- * Public API for interface file serialisation
14 writeBinIface,
15 readBinIface,
16 readBinIfaceHeader,
17 getSymtabName,
18 getDictFastString,
19 CheckHiWay(..),
20 TraceBinIFace(..),
21 getWithUserData,
22 putWithUserData,
23
24 -- * Internal serialisation functions
25 getSymbolTable,
26 putName,
27 putDictionary,
28 putFastString,
29 putSymbolTable,
30 BinSymbolTable(..),
31 BinDictionary(..)
32 ) where
33
34 import GHC.Prelude
35
36 import GHC.Tc.Utils.Monad
37 import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName )
38 import GHC.Unit
39 import GHC.Unit.Module.ModIface
40 import GHC.Types.Name
41 import GHC.Platform.Profile
42 import GHC.Types.Unique.FM
43 import GHC.Utils.Panic
44 import GHC.Utils.Binary as Binary
45 import GHC.Data.FastMutInt
46 import GHC.Types.Unique
47 import GHC.Utils.Outputable
48 import GHC.Types.Name.Cache
49 import GHC.Types.SrcLoc
50 import GHC.Platform
51 import GHC.Data.FastString
52 import GHC.Settings.Constants
53 import GHC.Utils.Fingerprint
54
55 import Data.Array
56 import Data.Array.IO
57 import Data.Array.Unsafe
58 import Data.Char
59 import Data.Word
60 import Data.IORef
61 import Control.Monad
62
63 -- ---------------------------------------------------------------------------
64 -- Reading and writing binary interface files
65 --
66
67 data CheckHiWay = CheckHiWay | IgnoreHiWay
68 deriving Eq
69
70 data TraceBinIFace
71 = TraceBinIFace (SDoc -> IO ())
72 | QuietBinIFace
73
74 -- | Read an interface file header, checking the magic number, version, and
75 -- way. Returns the hash of the source file and a BinHandle which points at the
76 -- start of the rest of the interface file data.
77 readBinIfaceHeader
78 :: Profile
79 -> NameCache
80 -> CheckHiWay
81 -> TraceBinIFace
82 -> FilePath
83 -> IO (Fingerprint, BinHandle)
84 readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
85 let platform = profilePlatform profile
86
87 wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
88 wantedGot what wanted got ppr' =
89 case traceBinIFace of
90 QuietBinIFace -> return ()
91 TraceBinIFace printer -> printer $
92 text what <> text ": " <>
93 vcat [text "Wanted " <> ppr' wanted <> text ",",
94 text "got " <> ppr' got]
95
96 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
97 errorOnMismatch what wanted got =
98 -- This will be caught by readIface which will emit an error
99 -- msg containing the iface module name.
100 when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
101 (what ++ " (wanted " ++ show wanted
102 ++ ", got " ++ show got ++ ")")
103 bh <- Binary.readBinMem hi_path
104
105 -- Read the magic number to check that this really is a GHC .hi file
106 -- (This magic number does not change when we change
107 -- GHC interface file format)
108 magic <- get bh
109 wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
110 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
111 (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
112
113 -- Check the interface file version and profile tag.
114 check_ver <- get bh
115 let our_ver = show hiVersion
116 wantedGot "Version" our_ver check_ver text
117 errorOnMismatch "mismatched interface file versions" our_ver check_ver
118
119 check_tag <- get bh
120 let tag = profileBuildTag profile
121 wantedGot "Way" tag check_tag ppr
122 when (checkHiWay == CheckHiWay) $
123 errorOnMismatch "mismatched interface file profile tag" tag check_tag
124
125 src_hash <- get bh
126 pure (src_hash, bh)
127
128 -- | Read an interface file.
129 readBinIface
130 :: Profile
131 -> NameCache
132 -> CheckHiWay
133 -> TraceBinIFace
134 -> FilePath
135 -> IO ModIface
136 readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
137 (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path
138
139 extFields_p <- get bh
140
141 mod_iface <- getWithUserData name_cache bh
142
143 seekBin bh extFields_p
144 extFields <- get bh
145
146 return mod_iface
147 { mi_ext_fields = extFields
148 , mi_src_hash = src_hash
149 }
150
151 -- | This performs a get action after reading the dictionary and symbol
152 -- table. It is necessary to run this before trying to deserialise any
153 -- Names or FastStrings.
154 getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
155 getWithUserData name_cache bh = do
156 -- Read the dictionary
157 -- The next word in the file is a pointer to where the dictionary is
158 -- (probably at the end of the file)
159 dict_p <- Binary.get bh
160 data_p <- tellBin bh -- Remember where we are now
161 seekBin bh dict_p
162 dict <- getDictionary bh
163 seekBin bh data_p -- Back to where we were before
164
165 -- Initialise the user-data field of bh
166 bh <- do
167 bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
168 (getDictFastString dict)
169 symtab_p <- Binary.get bh -- Get the symtab ptr
170 data_p <- tellBin bh -- Remember where we are now
171 seekBin bh symtab_p
172 symtab <- getSymbolTable bh name_cache
173 seekBin bh data_p -- Back to where we were before
174
175 -- It is only now that we know how to get a Name
176 return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
177 (getDictFastString dict)
178
179 -- Read the interface file
180 get bh
181
182 -- | Write an interface file
183 writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
184 writeBinIface profile traceBinIface hi_path mod_iface = do
185 bh <- openBinMem initBinMemSize
186 let platform = profilePlatform profile
187 put_ bh (binaryInterfaceMagic platform)
188
189 -- The version, profile tag, and source hash go next
190 put_ bh (show hiVersion)
191 let tag = profileBuildTag profile
192 put_ bh tag
193 put_ bh (mi_src_hash mod_iface)
194
195 extFields_p_p <- tellBin bh
196 put_ bh extFields_p_p
197
198 putWithUserData traceBinIface bh mod_iface
199
200 extFields_p <- tellBin bh
201 putAt bh extFields_p_p extFields_p
202 seekBin bh extFields_p
203 put_ bh (mi_ext_fields mod_iface)
204
205 -- And send the result to the file
206 writeBinMem bh hi_path
207
208 -- | Put a piece of data with an initialised `UserData` field. This
209 -- is necessary if you want to serialise Names or FastStrings.
210 -- It also writes a symbol table and the dictionary.
211 -- This segment should be read using `getWithUserData`.
212 putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
213 putWithUserData traceBinIface bh payload = do
214 -- Remember where the dictionary pointer will go
215 dict_p_p <- tellBin bh
216 -- Placeholder for ptr to dictionary
217 put_ bh dict_p_p
218
219 -- Remember where the symbol table pointer will go
220 symtab_p_p <- tellBin bh
221 put_ bh symtab_p_p
222 -- Make some initial state
223 symtab_next <- newFastMutInt 0
224 symtab_map <- newIORef emptyUFM
225 let bin_symtab = BinSymbolTable {
226 bin_symtab_next = symtab_next,
227 bin_symtab_map = symtab_map }
228 dict_next_ref <- newFastMutInt 0
229 dict_map_ref <- newIORef emptyUFM
230 let bin_dict = BinDictionary {
231 bin_dict_next = dict_next_ref,
232 bin_dict_map = dict_map_ref }
233
234 -- Put the main thing,
235 bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
236 (putName bin_dict bin_symtab)
237 (putFastString bin_dict)
238 put_ bh payload
239
240 -- Write the symtab pointer at the front of the file
241 symtab_p <- tellBin bh -- This is where the symtab will start
242 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
243 seekBin bh symtab_p -- Seek back to the end of the file
244
245 -- Write the symbol table itself
246 symtab_next <- readFastMutInt symtab_next
247 symtab_map <- readIORef symtab_map
248 putSymbolTable bh symtab_next symtab_map
249 case traceBinIface of
250 QuietBinIFace -> return ()
251 TraceBinIFace printer ->
252 printer (text "writeBinIface:" <+> int symtab_next
253 <+> text "Names")
254
255 -- NB. write the dictionary after the symbol table, because
256 -- writing the symbol table may create more dictionary entries.
257
258 -- Write the dictionary pointer at the front of the file
259 dict_p <- tellBin bh -- This is where the dictionary will start
260 putAt bh dict_p_p dict_p -- Fill in the placeholder
261 seekBin bh dict_p -- Seek back to the end of the file
262
263 -- Write the dictionary itself
264 dict_next <- readFastMutInt dict_next_ref
265 dict_map <- readIORef dict_map_ref
266 putDictionary bh dict_next dict_map
267 case traceBinIface of
268 QuietBinIFace -> return ()
269 TraceBinIFace printer ->
270 printer (text "writeBinIface:" <+> int dict_next
271 <+> text "dict entries")
272
273
274
275 -- | Initial ram buffer to allocate for writing interface files
276 initBinMemSize :: Int
277 initBinMemSize = 1024 * 1024
278
279 binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
280 binaryInterfaceMagic platform
281 | target32Bit platform = FixedLengthEncoding 0x1face
282 | otherwise = FixedLengthEncoding 0x1face64
283
284
285 -- -----------------------------------------------------------------------------
286 -- The symbol table
287 --
288
289 putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
290 putSymbolTable bh next_off symtab = do
291 put_ bh next_off
292 let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
293 -- It's OK to use nonDetEltsUFM here because the elements have
294 -- indices that array uses to create order
295 mapM_ (\n -> serialiseName bh n symtab) names
296
297
298 getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
299 getSymbolTable bh name_cache = do
300 sz <- get bh :: IO Int
301 -- create an array of Names for the symbols and add them to the NameCache
302 updateNameCache' name_cache $ \cache0 -> do
303 mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
304 cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
305 let mod = mkModule uid mod_name
306 case lookupOrigNameCache cache mod occ of
307 Just name -> do
308 writeArray mut_arr (fromIntegral i) name
309 return cache
310 Nothing -> do
311 uniq <- takeUniqFromNameCache name_cache
312 let name = mkExternalName uniq mod occ noSrcSpan
313 new_cache = extendOrigNameCache cache mod occ name
314 writeArray mut_arr (fromIntegral i) name
315 return new_cache
316 arr <- unsafeFreeze mut_arr
317 return (cache, arr)
318
319 serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
320 serialiseName bh name _ = do
321 let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
322 put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
323
324
325 -- Note [Symbol table representation of names]
326 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
327 --
328 -- An occurrence of a name in an interface file is serialized as a single 32-bit
329 -- word. The format of this word is:
330 -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
331 -- A normal name. x is an index into the symbol table
332 -- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
333 -- A known-key name. x is the Unique's Char, y is the int part. We assume that
334 -- all known-key uniques fit in this space. This is asserted by
335 -- GHC.Builtin.Utils.knownKeyNamesOkay.
336 --
337 -- During serialization we check for known-key things using isKnownKeyName.
338 -- During deserialization we use lookupKnownKeyName to get from the unique back
339 -- to its corresponding Name.
340
341
342 -- See Note [Symbol table representation of names]
343 putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
344 putName _dict BinSymbolTable{
345 bin_symtab_map = symtab_map_ref,
346 bin_symtab_next = symtab_next }
347 bh name
348 | isKnownKeyName name
349 , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
350 = -- assert (u < 2^(22 :: Int))
351 put_ bh (0x80000000
352 .|. (fromIntegral (ord c) `shiftL` 22)
353 .|. (fromIntegral u :: Word32))
354
355 | otherwise
356 = do symtab_map <- readIORef symtab_map_ref
357 case lookupUFM symtab_map name of
358 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
359 Nothing -> do
360 off <- readFastMutInt symtab_next
361 -- massert (off < 2^(30 :: Int))
362 writeFastMutInt symtab_next (off+1)
363 writeIORef symtab_map_ref
364 $! addToUFM symtab_map name (off,name)
365 put_ bh (fromIntegral off :: Word32)
366
367 -- See Note [Symbol table representation of names]
368 getSymtabName :: NameCache
369 -> Dictionary -> SymbolTable
370 -> BinHandle -> IO Name
371 getSymtabName _name_cache _dict symtab bh = do
372 i :: Word32 <- get bh
373 case i .&. 0xC0000000 of
374 0x00000000 -> return $! symtab ! fromIntegral i
375
376 0x80000000 ->
377 let
378 tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
379 ix = fromIntegral i .&. 0x003FFFFF
380 u = mkUnique tag ix
381 in
382 return $! case lookupKnownKeyName u of
383 Nothing -> pprPanic "getSymtabName:unknown known-key unique"
384 (ppr i $$ ppr (unpkUnique u))
385 Just n -> n
386
387 _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
388
389 data BinSymbolTable = BinSymbolTable {
390 bin_symtab_next :: !FastMutInt, -- The next index to use
391 bin_symtab_map :: !(IORef (UniqFM Name (Int,Name)))
392 -- indexed by Name
393 }
394
395 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
396 putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
397
398 allocateFastString :: BinDictionary -> FastString -> IO Word32
399 allocateFastString BinDictionary { bin_dict_next = j_r,
400 bin_dict_map = out_r} f = do
401 out <- readIORef out_r
402 let !uniq = getUnique f
403 case lookupUFM_Directly out uniq of
404 Just (j, _) -> return (fromIntegral j :: Word32)
405 Nothing -> do
406 j <- readFastMutInt j_r
407 writeFastMutInt j_r (j + 1)
408 writeIORef out_r $! addToUFM_Directly out uniq (j, f)
409 return (fromIntegral j :: Word32)
410
411 getDictFastString :: Dictionary -> BinHandle -> IO FastString
412 getDictFastString dict bh = do
413 j <- get bh
414 return $! (dict ! fromIntegral (j :: Word32))
415
416 data BinDictionary = BinDictionary {
417 bin_dict_next :: !FastMutInt, -- The next index to use
418 bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
419 -- indexed by FastString
420 }
421