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