Fix interface version number printing in --show-iface
[ghc.git] / compiler / iface / BinIface.hs
1 {-# LANGUAGE BinaryLiterals, CPP, 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 BinIface (
13 writeBinIface,
14 readBinIface,
15 getSymtabName,
16 getDictFastString,
17 CheckHiWay(..),
18 TraceBinIFaceReading(..),
19 getWithUserData,
20 putWithUserData
21
22 ) where
23
24 #include "HsVersions.h"
25
26 import GhcPrelude
27
28 import TcRnMonad
29 import PrelInfo ( isKnownKeyName, lookupKnownKeyName )
30 import IfaceEnv
31 import HscTypes
32 import Module
33 import Name
34 import DynFlags
35 import UniqFM
36 import UniqSupply
37 import Panic
38 import Binary
39 import SrcLoc
40 import ErrUtils
41 import FastMutInt
42 import Unique
43 import Outputable
44 import NameCache
45 import Platform
46 import FastString
47 import Constants
48 import Util
49
50 import Data.Array
51 import Data.Array.ST
52 import Data.Array.Unsafe
53 import Data.Bits
54 import Data.Char
55 import Data.Word
56 import Data.IORef
57 import Data.Foldable
58 import Control.Monad
59 import Control.Monad.ST
60 import Control.Monad.Trans.Class
61 import qualified Control.Monad.Trans.State.Strict as State
62
63 -- ---------------------------------------------------------------------------
64 -- Reading and writing binary interface files
65 --
66
67 data CheckHiWay = CheckHiWay | IgnoreHiWay
68 deriving Eq
69
70 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
71 deriving Eq
72
73 -- | Read an interface file
74 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
75 -> TcRnIf a b ModIface
76 readBinIface checkHiWay traceBinIFaceReading hi_path = do
77 ncu <- mkNameCacheUpdater
78 dflags <- getDynFlags
79 liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
80
81 readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
82 -> NameCacheUpdater
83 -> IO ModIface
84 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
85 let printer :: SDoc -> IO ()
86 printer = case traceBinIFaceReading of
87 TraceBinIFaceReading -> \sd ->
88 putLogMsg dflags
89 NoReason
90 SevOutput
91 noSrcSpan
92 (defaultDumpStyle dflags)
93 sd
94 QuietBinIFaceReading -> \_ -> return ()
95
96 wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
97 wantedGot what wanted got ppr' =
98 printer (text what <> text ": " <>
99 vcat [text "Wanted " <> ppr' wanted <> text ",",
100 text "got " <> ppr' got])
101
102 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
103 errorOnMismatch what wanted got =
104 -- This will be caught by readIface which will emit an error
105 -- msg containing the iface module name.
106 when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
107 (what ++ " (wanted " ++ show wanted
108 ++ ", got " ++ show got ++ ")")
109 bh <- Binary.readBinMem hi_path
110
111 -- Read the magic number to check that this really is a GHC .hi file
112 -- (This magic number does not change when we change
113 -- GHC interface file format)
114 magic <- get bh
115 wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr
116 errorOnMismatch "magic number mismatch: old/corrupt interface file?"
117 (binaryInterfaceMagic dflags) magic
118
119 -- Note [dummy iface field]
120 -- read a dummy 32/64 bit value. This field used to hold the
121 -- dictionary pointer in old interface file formats, but now
122 -- the dictionary pointer is after the version (where it
123 -- should be). Also, the serialisation of value of type "Bin
124 -- a" used to depend on the word size of the machine, now they
125 -- are always 32 bits.
126 if wORD_SIZE dflags == 4
127 then do _ <- Binary.get bh :: IO Word32; return ()
128 else do _ <- Binary.get bh :: IO Word64; return ()
129
130 -- Check the interface file version and ways.
131 check_ver <- get bh
132 let our_ver = show hiVersion
133 wantedGot "Version" our_ver check_ver text
134 errorOnMismatch "mismatched interface file versions" our_ver check_ver
135
136 check_way <- get bh
137 let way_descr = getWayDescr dflags
138 wantedGot "Way" way_descr check_way ppr
139 when (checkHiWay == CheckHiWay) $
140 errorOnMismatch "mismatched interface file ways" way_descr check_way
141 getWithUserData ncu bh
142
143
144 -- | This performs a get action after reading the dictionary and symbol
145 -- table. It is necessary to run this before trying to deserialise any
146 -- Names or FastStrings.
147 getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
148 getWithUserData ncu bh = do
149 -- Read the dictionary
150 -- The next word in the file is a pointer to where the dictionary is
151 -- (probably at the end of the file)
152 dict_p <- Binary.get bh
153 data_p <- tellBin bh -- Remember where we are now
154 seekBin bh dict_p
155 dict <- getDictionary bh
156 seekBin bh data_p -- Back to where we were before
157
158 -- Initialise the user-data field of bh
159 bh <- do
160 bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
161 (getDictFastString dict)
162 symtab_p <- Binary.get bh -- Get the symtab ptr
163 data_p <- tellBin bh -- Remember where we are now
164 seekBin bh symtab_p
165 symtab <- getSymbolTable bh ncu
166 seekBin bh data_p -- Back to where we were before
167
168 -- It is only now that we know how to get a Name
169 return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
170 (getDictFastString dict)
171
172 -- Read the interface file
173 get bh
174
175 -- | Write an interface file
176 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
177 writeBinIface dflags hi_path mod_iface = do
178 bh <- openBinMem initBinMemSize
179 put_ bh (binaryInterfaceMagic dflags)
180
181 -- dummy 32/64-bit field before the version/way for
182 -- compatibility with older interface file formats.
183 -- See Note [dummy iface field] above.
184 if wORD_SIZE dflags == 4
185 then Binary.put_ bh (0 :: Word32)
186 else Binary.put_ bh (0 :: Word64)
187
188 -- The version and way descriptor go next
189 put_ bh (show hiVersion)
190 let way_descr = getWayDescr dflags
191 put_ bh way_descr
192
193
194 putWithUserData (debugTraceMsg dflags 3) bh mod_iface
195 -- And send the result to the file
196 writeBinMem bh hi_path
197
198 -- | Put a piece of data with an initialised `UserData` field. This
199 -- is necessary if you want to serialise Names or FastStrings.
200 -- It also writes a symbol table and the dictionary.
201 -- This segment should be read using `getWithUserData`.
202 putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
203 putWithUserData log_action bh payload = do
204 -- Remember where the dictionary pointer will go
205 dict_p_p <- tellBin bh
206 -- Placeholder for ptr to dictionary
207 put_ bh dict_p_p
208
209 -- Remember where the symbol table pointer will go
210 symtab_p_p <- tellBin bh
211 put_ bh symtab_p_p
212 -- Make some initial state
213 symtab_next <- newFastMutInt
214 writeFastMutInt symtab_next 0
215 symtab_map <- newIORef emptyUFM
216 let bin_symtab = BinSymbolTable {
217 bin_symtab_next = symtab_next,
218 bin_symtab_map = symtab_map }
219 dict_next_ref <- newFastMutInt
220 writeFastMutInt dict_next_ref 0
221 dict_map_ref <- newIORef emptyUFM
222 let bin_dict = BinDictionary {
223 bin_dict_next = dict_next_ref,
224 bin_dict_map = dict_map_ref }
225
226 -- Put the main thing,
227 bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
228 (putName bin_dict bin_symtab)
229 (putFastString bin_dict)
230 put_ bh payload
231
232 -- Write the symtab pointer at the front of the file
233 symtab_p <- tellBin bh -- This is where the symtab will start
234 putAt bh symtab_p_p symtab_p -- Fill in the placeholder
235 seekBin bh symtab_p -- Seek back to the end of the file
236
237 -- Write the symbol table itself
238 symtab_next <- readFastMutInt symtab_next
239 symtab_map <- readIORef symtab_map
240 putSymbolTable bh symtab_next symtab_map
241 log_action (text "writeBinIface:" <+> int symtab_next
242 <+> text "Names")
243
244 -- NB. write the dictionary after the symbol table, because
245 -- writing the symbol table may create more dictionary entries.
246
247 -- Write the dictionary pointer at the front of the file
248 dict_p <- tellBin bh -- This is where the dictionary will start
249 putAt bh dict_p_p dict_p -- Fill in the placeholder
250 seekBin bh dict_p -- Seek back to the end of the file
251
252 -- Write the dictionary itself
253 dict_next <- readFastMutInt dict_next_ref
254 dict_map <- readIORef dict_map_ref
255 putDictionary bh dict_next dict_map
256 log_action (text "writeBinIface:" <+> int dict_next
257 <+> text "dict entries")
258
259
260
261 -- | Initial ram buffer to allocate for writing interface files
262 initBinMemSize :: Int
263 initBinMemSize = 1024 * 1024
264
265 binaryInterfaceMagic :: DynFlags -> Word32
266 binaryInterfaceMagic dflags
267 | target32Bit (targetPlatform dflags) = 0x1face
268 | otherwise = 0x1face64
269
270
271 -- -----------------------------------------------------------------------------
272 -- The symbol table
273 --
274
275 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
276 putSymbolTable bh next_off symtab = do
277 put_ bh next_off
278 let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
279 -- It's OK to use nonDetEltsUFM here because the elements have
280 -- indices that array uses to create order
281 mapM_ (\n -> serialiseName bh n symtab) names
282
283 getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
284 getSymbolTable bh ncu = do
285 sz <- get bh
286 od_names <- sequence (replicate sz (get bh))
287 updateNameCache ncu $ \namecache ->
288 runST $ flip State.evalStateT namecache $ do
289 mut_arr <- lift $ newSTArray_ (0, sz-1)
290 for_ (zip [0..] od_names) $ \(i, odn) -> do
291 (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
292 lift $ writeArray mut_arr i n
293 State.put nc
294 arr <- lift $ unsafeFreeze mut_arr
295 namecache' <- State.get
296 return (namecache', arr)
297 where
298 -- This binding is required because the type of newArray_ cannot be inferred
299 newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
300 newSTArray_ = newArray_
301
302 type OnDiskName = (UnitId, ModuleName, OccName)
303
304 fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
305 fromOnDiskName nc (pid, mod_name, occ) =
306 let mod = mkModule pid mod_name
307 cache = nsNames nc
308 in case lookupOrigNameCache cache mod occ of
309 Just name -> (nc, name)
310 Nothing ->
311 let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
312 name = mkExternalName uniq mod occ noSrcSpan
313 new_cache = extendNameCache cache mod occ name
314 in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
315
316 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
317 serialiseName bh name _ = do
318 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
319 put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
320
321
322 -- Note [Symbol table representation of names]
323 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
324 --
325 -- An occurrence of a name in an interface file is serialized as a single 32-bit
326 -- word. The format of this word is:
327 -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
328 -- A normal name. x is an index into the symbol table
329 -- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
330 -- A known-key name. x is the Unique's Char, y is the int part. We assume that
331 -- all known-key uniques fit in this space. This is asserted by
332 -- PrelInfo.knownKeyNamesOkay.
333 --
334 -- During serialization we check for known-key things using isKnownKeyName.
335 -- During deserialization we use lookupKnownKeyName to get from the unique back
336 -- to its corresponding Name.
337
338
339 -- See Note [Symbol table representation of names]
340 putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
341 putName _dict BinSymbolTable{
342 bin_symtab_map = symtab_map_ref,
343 bin_symtab_next = symtab_next }
344 bh name
345 | isKnownKeyName name
346 , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
347 = -- ASSERT(u < 2^(22 :: Int))
348 put_ bh (0x80000000
349 .|. (fromIntegral (ord c) `shiftL` 22)
350 .|. (fromIntegral u :: Word32))
351
352 | otherwise
353 = do symtab_map <- readIORef symtab_map_ref
354 case lookupUFM symtab_map name of
355 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
356 Nothing -> do
357 off <- readFastMutInt symtab_next
358 -- MASSERT(off < 2^(30 :: Int))
359 writeFastMutInt symtab_next (off+1)
360 writeIORef symtab_map_ref
361 $! addToUFM symtab_map name (off,name)
362 put_ bh (fromIntegral off :: Word32)
363
364 -- See Note [Symbol table representation of names]
365 getSymtabName :: NameCacheUpdater
366 -> Dictionary -> SymbolTable
367 -> BinHandle -> IO Name
368 getSymtabName _ncu _dict symtab bh = do
369 i :: Word32 <- get bh
370 case i .&. 0xC0000000 of
371 0x00000000 -> return $! symtab ! fromIntegral i
372
373 0x80000000 ->
374 let
375 tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
376 ix = fromIntegral i .&. 0x003FFFFF
377 u = mkUnique tag ix
378 in
379 return $! case lookupKnownKeyName u of
380 Nothing -> pprPanic "getSymtabName:unknown known-key unique"
381 (ppr i $$ ppr (unpkUnique u))
382 Just n -> n
383
384 _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
385
386 data BinSymbolTable = BinSymbolTable {
387 bin_symtab_next :: !FastMutInt, -- The next index to use
388 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
389 -- indexed by Name
390 }
391
392 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
393 putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
394
395 allocateFastString :: BinDictionary -> FastString -> IO Word32
396 allocateFastString BinDictionary { bin_dict_next = j_r,
397 bin_dict_map = out_r} f = do
398 out <- readIORef out_r
399 let uniq = getUnique f
400 case lookupUFM out uniq of
401 Just (j, _) -> return (fromIntegral j :: Word32)
402 Nothing -> do
403 j <- readFastMutInt j_r
404 writeFastMutInt j_r (j + 1)
405 writeIORef out_r $! addToUFM out uniq (j, f)
406 return (fromIntegral j :: Word32)
407
408 getDictFastString :: Dictionary -> BinHandle -> IO FastString
409 getDictFastString dict bh = do
410 j <- get bh
411 return $! (dict ! fromIntegral (j :: Word32))
412
413 data BinDictionary = BinDictionary {
414 bin_dict_next :: !FastMutInt, -- The next index to use
415 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
416 -- indexed by FastString
417 }
418
419 getWayDescr :: DynFlags -> String
420 getWayDescr dflags
421 | platformUnregisterised (targetPlatform dflags) = 'u':tag
422 | otherwise = tag
423 where tag = buildTag dflags
424 -- if this is an unregisterised build, make sure our interfaces
425 -- can't be used by a registerised build.