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