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