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