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