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