Implement unboxed sum primitive type
[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 TcRnMonad
24 import TyCon
25 import ConLike
26 import PrelInfo ( knownKeyNames )
27 import Id ( idName, isDataConWorkId_maybe )
28 import TysWiredIn
29 import IfaceEnv
30 import HscTypes
31 import BasicTypes
32 import Module
33 import Name
34 import DynFlags
35 import UniqFM
36 import UniqSupply
37 import Panic
38 import Binary
39 import SrcLoc
40 import ErrUtils
41 import FastMutInt
42 import Unique
43 import Outputable
44 import Platform
45 import FastString
46 import Constants
47 import Util
48 import DataCon
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 -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
298 -- A normal name. x is an index into the symbol table
299 -- 01xxxxxx xxyyyyyy yyyyyyyy yyyyyyyyyy
300 -- A known-key name. x is the Unique's Char, y is the int part
301 -- 100xxyyz zzzzzzzz zzzzzzzz zzzzzzzz
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 --
307 -- 10100xxx xxxxxxxx xxxxxxxx xxxxxxxx
308 -- A sum tycon name:
309 -- x is the arity
310 -- 10101xxx xxxxxxxx xxyyyyyy yyyyyyyy
311 -- A sum datacon name:
312 -- x is the arity
313 -- y is the alternative
314 -- 10110xxx xxxxxxxx xxyyyyyy yyyyyyyy
315 -- worker
316 -- 11xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
317 -- An implicit parameter TyCon name. x is an index into the FastString *dictionary*
318 --
319 -- Note that we have to have special representation for tuples, sums, and IP
320 -- TyCons because they form an "infinite" family and hence are not recorded
321 -- explicitly in wiredInTyThings or basicKnownKeyNames.
322
323 knownKeyNamesMap :: UniqFM Name
324 knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
325
326 -- See Note [Symbol table representation of names]
327 putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
328 putName _dict BinSymbolTable{
329 bin_symtab_map = symtab_map_ref,
330 bin_symtab_next = symtab_next } bh name
331 | name `elemUFM` knownKeyNamesMap
332 , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
333 = -- ASSERT(u < 2^(22 :: Int))
334 put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32))
335 | otherwise
336 = case wiredInNameTyThing_maybe name of
337 Just (ATyCon tc)
338 | Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 0
339 | isUnboxedSumTyCon tc -> putSumTyConName_ bh tc
340 Just (AConLike (RealDataCon dc))
341 | let tc = dataConTyCon dc
342 , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 1
343 | isUnboxedSumCon dc -> putSumDataConName_ bh dc
344 Just (AnId x)
345 | Just dc <- isDataConWorkId_maybe x
346 , let tc = dataConTyCon dc
347 , Just sort <- tyConTuple_maybe tc -> putTupleName_ bh tc sort 2
348 Just (AnId x)
349 | Just dc <- isDataConWorkId_maybe x
350 , isUnboxedSumCon dc
351 -> putSumWorkerId_ bh dc
352 _ -> do
353 symtab_map <- readIORef symtab_map_ref
354 case lookupUFM symtab_map name of
355 Just (off,_) -> put_ bh (fromIntegral off :: Word32)
356 Nothing -> do
357 off <- readFastMutInt symtab_next
358 -- MASSERT(off < 2^(30 :: Int))
359 writeFastMutInt symtab_next (off+1)
360 writeIORef symtab_map_ref
361 $! addToUFM symtab_map name (off,name)
362 put_ bh (fromIntegral off :: Word32)
363
364 putTupleName_ :: BinHandle -> TyCon -> TupleSort -> Word32 -> IO ()
365 putTupleName_ bh tc tup_sort thing_tag
366 = ASSERT(arity < 2^(25 :: Int))
367 put_ bh (0x80000000 .|. (sort_tag `shiftL` 27) .|. (thing_tag `shiftL` 25) .|. arity)
368 where
369 (sort_tag, arity) = case tup_sort of
370 BoxedTuple -> (0, fromIntegral (tyConArity tc))
371 UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2))
372 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
373 ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
374
375 putSumTyConName_ :: BinHandle -> TyCon -> IO ()
376 putSumTyConName_ bh tc
377 = ASSERT(arity < 2^(27 :: Int))
378 put_ bh (0xA0000000 .|. arity)
379 where
380 arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32
381
382 putSumDataConName_ :: BinHandle -> DataCon -> IO ()
383 putSumDataConName_ bh dc
384 = ASSERT(arity < 2^(13 :: Int) && alt < 2^(14 :: Int))
385 put_ bh (0xA8000000 .|. (arity `shiftL` 14) .|. alt)
386 where
387 tc = dataConTyCon dc
388 alt = fromIntegral (dataConTag dc)
389 arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32
390
391 putSumWorkerId_ :: BinHandle -> DataCon -> IO ()
392 putSumWorkerId_ bh dc
393 = put_ bh (0xB0000000 .|. (arity `shiftL` 14) .|. alt)
394 where
395 tc = dataConTyCon dc
396 alt = fromIntegral (dataConTag dc)
397 arity = (fromIntegral (tyConArity tc) `div` 2) :: Word32
398
399 -- See Note [Symbol table representation of names]
400 getSymtabName :: NameCacheUpdater
401 -> Dictionary -> SymbolTable
402 -> BinHandle -> IO Name
403 getSymtabName _ncu _dict symtab bh = do
404 i :: Word32 <- get bh
405 case i .&. 0xC0000000 of
406 0x00000000 -> return $! symtab ! fromIntegral i
407
408 0x40000000 ->
409 let
410 tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
411 ix = fromIntegral i .&. 0x003FFFFF
412 in
413 return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of
414 Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i)
415 Just n -> n
416
417 0x80000000 ->
418 case i .&. 0x20000000 of
419 0x00000000 ->
420 let
421 dc = tupleDataCon sort arity
422 sort = case (i .&. 0x18000000) `shiftR` 27 of
423 0 -> Boxed
424 1 -> Unboxed
425 _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
426 arity = fromIntegral (i .&. 0x01FFFFFF)
427 in
428 return $! case ( (i .&. 0x06FFFFFF) `shiftR` 25 ) of
429 0 -> tyConName (tupleTyCon sort arity)
430 1 -> dataConName dc
431 2 -> idName (dataConWorkId dc)
432 _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i)
433
434 0x20000000 ->
435 return $! case ((i .&. 0x18000000) `shiftR` 27) of
436 0 -> tyConName $ sumTyCon ( fromIntegral (i .&. 0x7ffffff) )
437 1 -> let
438 alt =
439 -- first (least significant) 14 bits
440 fromIntegral (i .&. 0b11111111111111)
441 arity =
442 -- next 13 bits
443 fromIntegral ((i `shiftR` 14) .&. 0b1111111111111)
444 in
445 ASSERT( arity >= alt )
446 dataConName (sumDataCon alt arity)
447 2 -> let
448 alt =
449 -- first (least significant) 14 bits
450 fromIntegral (i .&. 0b11111111111111)
451 arity =
452 -- next 13 bits
453 fromIntegral ((i `shiftR` 14) .&. 0b1111111111111)
454 in
455 ASSERT( arity >= alt )
456 idName (dataConWorkId (sumDataCon alt arity))
457
458 _ -> pprPanic "getSymtabName:unknown sum sort" (ppr i)
459 _ -> pprPanic "getSyntabName:unknown `tuple or sum` tag" (ppr i)
460 _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
461
462 data BinSymbolTable = BinSymbolTable {
463 bin_symtab_next :: !FastMutInt, -- The next index to use
464 bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
465 -- indexed by Name
466 }
467
468 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
469 putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
470
471 allocateFastString :: BinDictionary -> FastString -> IO Word32
472 allocateFastString BinDictionary { bin_dict_next = j_r,
473 bin_dict_map = out_r} f = do
474 out <- readIORef out_r
475 let uniq = getUnique f
476 case lookupUFM out uniq of
477 Just (j, _) -> return (fromIntegral j :: Word32)
478 Nothing -> do
479 j <- readFastMutInt j_r
480 writeFastMutInt j_r (j + 1)
481 writeIORef out_r $! addToUFM out uniq (j, f)
482 return (fromIntegral j :: Word32)
483
484 getDictFastString :: Dictionary -> BinHandle -> IO FastString
485 getDictFastString dict bh = do
486 j <- get bh
487 return $! (dict ! fromIntegral (j :: Word32))
488
489 data BinDictionary = BinDictionary {
490 bin_dict_next :: !FastMutInt, -- The next index to use
491 bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
492 -- indexed by FastString
493 }
494
495 getWayDescr :: DynFlags -> String
496 getWayDescr dflags
497 | platformUnregisterised (targetPlatform dflags) = 'u':tag
498 | otherwise = tag
499 where tag = buildTag dflags
500 -- if this is an unregisterised build, make sure our interfaces
501 -- can't be used by a registerised build.