{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002-2006 -- {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected -- | Binary interface file support. module GHC.Iface.Binary ( -- * Public API for interface file serialisation writeBinIface, readBinIface, readBinIfaceHeader, CompressionIFace(..), getSymtabName, CheckHiWay(..), TraceBinIFace(..), getIfaceWithExtFields, putIfaceWithExtFields, getWithUserData, putWithUserData, -- * Internal serialisation functions getSymbolTable, putName, putSymbolTable, BinSymbolTable(..), initWriteIfaceType, initReadIfaceTypeTable, putAllTables, ) where import GHC.Prelude import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) import GHC.Unit import GHC.Unit.Module.ModIface import GHC.Types.Name import GHC.Platform.Profile import GHC.Types.Unique.FM import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Data.FastMutInt import GHC.Data.FastString (FastString) import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Platform import GHC.Settings.Constants import GHC.Utils.Fingerprint import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte) import Control.Monad import Data.Array import Data.Array.IO import Data.Array.Unsafe import Data.Char import Data.IORef import Data.Map.Strict (Map) import Data.Word import System.IO.Unsafe import Data.Typeable (Typeable) import qualified GHC.Data.Strict as Strict import Data.Function ((&)) -- --------------------------------------------------------------------------- -- Reading and writing binary interface files -- data CheckHiWay = CheckHiWay | IgnoreHiWay deriving Eq data TraceBinIFace = TraceBinIFace (SDoc -> IO ()) | QuietBinIFace -- | The compression/deduplication level of 'ModIface' files. -- -- A 'ModIface' contains many duplicated symbols and names. To keep interface -- files small, we deduplicate them during serialisation. -- It is impossible to write an interface file with *no* compression/deduplication. -- -- We support different levels of compression/deduplication, with different -- trade-offs for run-time performance and memory usage. -- If you don't have any specific requirements, then 'SafeExtraCompression' is a good default. data CompressionIFace = NormalCompression -- ^ Perform the normal compression operations, -- such as deduplicating 'Name's and 'FastString's | SafeExtraCompression -- ^ Perform some extra compression steps that have minimal impact -- on the run-time of 'ghc'. -- -- This reduces the size of '.hi' files significantly in some cases -- and reduces overall memory usage in certain scenarios. | MaximumCompression -- ^ Try to compress as much as possible. -- -- Yields the smallest '.hi' files but at the cost of additional run-time. deriving (Show, Eq, Ord, Bounded, Enum) instance Outputable CompressionIFace where ppr = text . show -- | Read an interface file header, checking the magic number, version, and -- way. Returns the hash of the source file and a BinHandle which points at the -- start of the rest of the interface file data. readBinIfaceHeader :: Profile -> NameCache -> CheckHiWay -> TraceBinIFace -> FilePath -> IO (Fingerprint, ReadBinHandle) readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do let platform = profilePlatform profile wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () wantedGot what wanted got ppr' = case traceBinIFace of QuietBinIFace -> return () TraceBinIFace printer -> printer $ text what <> text ": " <> vcat [text "Wanted " <> ppr' wanted <> text ",", text "got " <> ppr' got] errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () errorOnMismatch what wanted got = -- This will be caught by readIface which will emit an error -- msg containing the iface module name. when (wanted /= got) $ throwGhcExceptionIO $ ProgramError (what ++ " (wanted " ++ show wanted ++ ", got " ++ show got ++ ")") bh <- Binary.readBinMem hi_path -- Read the magic number to check that this really is a GHC .hi file -- (This magic number does not change when we change -- GHC interface file format) magic <- get bh wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength) errorOnMismatch "magic number mismatch: old/corrupt interface file?" (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) -- Check the interface file version and profile tag. check_ver <- get bh let our_ver = show hiVersion wantedGot "Version" our_ver check_ver text errorOnMismatch "mismatched interface file versions" our_ver check_ver check_tag <- get bh let tag = profileBuildTag profile wantedGot "Way" tag check_tag text when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file profile tag" tag check_tag src_hash <- get bh pure (src_hash, bh) -- | Read an interface file. -- -- See Note [Deduplication during iface binary serialisation] for details. readBinIface :: Profile -> NameCache -> CheckHiWay -> TraceBinIFace -> FilePath -> IO ModIface readBinIface profile name_cache checkHiWay traceBinIface hi_path = do (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path mod_iface <- getIfaceWithExtFields name_cache bh return $ mod_iface & addSourceFingerprint src_hash getIfaceWithExtFields :: NameCache -> ReadBinHandle -> IO ModIface getIfaceWithExtFields name_cache bh = do -- Start offset for the byte array that contains the serialised 'ModIface'. start <- tellBinReader bh extFields_p_rel <- getRelBin bh mod_iface <- getWithUserData name_cache bh seekBinReaderRel bh extFields_p_rel extFields <- get bh -- Store the 'ModIface' byte array, so that we can avoid serialisation if -- the 'ModIface' isn't modified. -- See Note [Sharing of ModIface] modIfaceBinData <- freezeBinHandle bh start pure $ mod_iface & set_mi_ext_fields extFields & set_mi_hi_bytes (FullIfaceBinHandle $ Strict.Just modIfaceBinData) -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings. getWithUserData :: Binary a => NameCache -> ReadBinHandle -> IO a getWithUserData name_cache bh = do bh <- getTables name_cache bh get bh -- | Setup a BinHandle to read something written using putWithTables -- -- Reading names has the side effect of adding them into the given NameCache. getTables :: NameCache -> ReadBinHandle -> IO ReadBinHandle getTables name_cache bh = do bhRef <- newIORef (error "used too soon") -- It is important this is passed to 'getTable' -- See Note [Lazy ReaderUserData during IfaceType serialisation] ud <- unsafeInterleaveIO (readIORef bhRef) fsReaderTable <- initFastStringReaderTable nameReaderTable <- initNameReaderTable name_cache ifaceTypeReaderTable <- initReadIfaceTypeTable ud let -- For any 'ReaderTable', we decode the table that is found at the location -- the forward reference points to. -- After decoding the table, we create a 'BinaryReader' and immediately -- add it to the 'ReaderUserData' of 'ReadBinHandle'. decodeReaderTable :: Typeable a => ReaderTable a -> ReadBinHandle -> IO ReadBinHandle decodeReaderTable tbl bh0 = do table <- Binary.forwardGetRel bh (getTable tbl bh0) let binaryReader = mkReaderFromTable tbl table pure $ addReaderToUserData binaryReader bh0 -- Decode all the tables and populate the 'ReaderUserData'. bhFinal <- foldM (\bh0 act -> act bh0) bh -- The order of these deserialisation matters! -- -- See Note [Order of deduplication tables during iface binary serialisation] for details. [ decodeReaderTable fsReaderTable , decodeReaderTable nameReaderTable , decodeReaderTable ifaceTypeReaderTable ] writeIORef bhRef (getReaderUserData bhFinal) pure bhFinal -- | Write an interface file. -- -- See Note [Deduplication during iface binary serialisation] for details. writeBinIface :: Profile -> TraceBinIFace -> CompressionIFace -> FilePath -> ModIface -> IO () writeBinIface profile traceBinIface compressionLevel hi_path mod_iface = do case traceBinIface of QuietBinIFace -> pure () TraceBinIFace printer -> do printer (text "writeBinIface compression level:" <+> ppr compressionLevel) bh <- openBinMem initBinMemSize let platform = profilePlatform profile put_ bh (binaryInterfaceMagic platform) -- The version, profile tag, and source hash go next put_ bh (show hiVersion) let tag = profileBuildTag profile put_ bh tag put_ bh (mi_src_hash mod_iface) putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface -- And send the result to the file writeBinMem bh hi_path -- | Puts the 'ModIface' to the 'WriteBinHandle'. -- -- This avoids serialisation of the 'ModIface' if the fields 'mi_hi_bytes' contains a -- 'Just' value. This field is populated by reading the 'ModIface' using -- 'getIfaceWithExtFields' and not modifying it in any way afterwards. putIfaceWithExtFields :: TraceBinIFace -> CompressionIFace -> WriteBinHandle -> ModIface -> IO () putIfaceWithExtFields traceBinIface compressionLevel bh mod_iface = case mi_hi_bytes mod_iface of FullIfaceBinHandle Strict.Nothing -> do forwardPutRel_ bh (\_ -> put_ bh (mi_ext_fields mod_iface)) $ do putWithUserData traceBinIface compressionLevel bh mod_iface FullIfaceBinHandle (Strict.Just binData) -> putFullBinData bh binData -- | Put a piece of data with an initialised `UserData` field. This -- is necessary if you want to serialise Names or FastStrings. -- It also writes a symbol table and the dictionary. -- This segment should be read using `getWithUserData`. putWithUserData :: Binary a => TraceBinIFace -> CompressionIFace -> WriteBinHandle -> a -> IO () putWithUserData traceBinIface compressionLevel bh payload = do (name_count, fs_count, ifacetype_count, _b) <- putWithTables compressionLevel bh (\bh' -> put bh' payload) case traceBinIface of QuietBinIFace -> return () TraceBinIFace printer -> do printer (text "writeBinIface:" <+> int name_count <+> text "Names") printer (text "writeBinIface:" <+> int fs_count <+> text "dict entries") printer (text "writeBinIface:" <+> int ifacetype_count <+> text "iface type entries") -- | Write name/symbol/ifacetype tables -- -- 1. setup the given BinHandle with Name/FastString/IfaceType table handling -- 2. write the following -- - FastString table pointer -- - Name table pointer -- - IfaceType table pointer -- - payload -- - IfaceType table -- - Name table -- - FastString table -- -- It returns (number of names, number of FastStrings, number of IfaceTypes, payload write result) -- -- See Note [Order of deduplication tables during iface binary serialisation] putWithTables :: CompressionIFace -> WriteBinHandle -> (WriteBinHandle -> IO b) -> IO (Int, Int, Int, b) putWithTables compressionLevel bh' put_payload = do -- Initialise deduplicating tables. (fast_wt, fsWriter) <- initFastStringWriterTable (name_wt, nameWriter) <- initNameWriterTable (ifaceType_wt, ifaceTypeWriter) <- initWriteIfaceType compressionLevel -- Initialise the 'WriterUserData'. let writerUserData = mkWriterUserData [ mkSomeBinaryWriter @FastString fsWriter , mkSomeBinaryWriter @Name nameWriter -- We sometimes serialise binding and non-binding names differently, but -- not during 'ModIface' serialisation. Here, we serialise both to the same -- deduplication table. -- -- See Note [Binary UserData] , mkSomeBinaryWriter @BindingName $ mkWriter (\bh name -> putEntry nameWriter bh (getBindingName name)) , mkSomeBinaryWriter @IfaceType ifaceTypeWriter ] let bh = setWriterUserData bh' writerUserData ([fs_count, name_count, ifacetype_count] , r) <- -- The order of these entries matters! -- -- See Note [Order of deduplication tables during iface binary serialisation] for details. putAllTables bh [fast_wt, name_wt, ifaceType_wt] $ do put_payload bh return (name_count, fs_count, ifacetype_count, r) -- | Write all deduplication tables to disk after serialising the -- main payload. -- -- Writes forward pointers to the deduplication tables before writing the payload -- to allow deserialisation *before* the payload is read again. putAllTables :: WriteBinHandle -> [WriterTable] -> IO b -> IO ([Int], b) putAllTables _ [] act = do a <- act pure ([], a) putAllTables bh (x : xs) act = do (r, (res, a)) <- forwardPutRel bh (const $ putTable x bh) $ do putAllTables bh xs act pure (r : res, a) -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int initBinMemSize = 1024 * 1024 binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32 binaryInterfaceMagic platform | target32Bit platform = FixedLengthEncoding 0x1face | otherwise = FixedLengthEncoding 0x1face64 {- Note [Deduplication during iface binary serialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we serialise a 'ModIface', many symbols are redundant. For example, there can be many duplicated 'FastString's and 'Name's. To save space, we deduplicate duplicated symbols, such as 'FastString' and 'Name', by maintaining a table of already seen symbols. Besides saving a lot of disk space, this additionally enables us to automatically share these symbols when we read the 'ModIface' from disk, without additional mechanisms such as 'FastStringTable'. The general idea is, when serialising a value of type 'Name', we first have to create a deduplication table (see 'putWithTables.initNameWriterTable' for example). Then, we create a 'BinaryWriter' function which we add to the 'WriterUserData'. When this 'BinaryWriter' is used to serialise a value of type 'Name', it looks up whether we have seen this value before. If so, we write an index to disk. If we haven't seen the value before, we add it to the deduplication table and produce a new index. Both the 'ReaderUserData' and 'WriterUserData' can contain many 'BinaryReader's and 'BinaryWriter's respectively, which can each individually be tweaked to use a deduplication table, or to serialise the value without deduplication. After the payload (e.g., the 'ModIface') has been serialised to disk, we serialise the deduplication tables to disk. This happens in 'putAllTables', where we serialise all tables that we use during 'ModIface' serialisation. See 'initNameWriterTable' and 'putSymbolTable' for an implementation example. This uses the 'real' serialisation function, e.g., 'serialiseName'. However, these tables need to be deserialised before we can read the 'ModIface' from disk. Thus, we write before the 'ModIface' a forward pointer to the deduplication table, so we can read this table before deserialising the 'ModIface'. To add a deduplication table for a type, let us assume 'IfaceTyCon', you need to do the following: * The 'Binary' instance 'IfaceTyCon' needs to dynamically look up the serialiser function instead of serialising the value of 'IfaceTyCon'. It needs to look up the serialiser in the 'ReaderUserData' and 'WriterUserData' respectively. This allows us to change the serialisation of 'IfaceTyCon' at run-time. We can still serialise 'IfaceTyCon' to disk directly, or use a deduplication table to reduce the size of the .hi file. For example: @ instance Binary IfaceTyCon where put_ bh ty = case findUserDataWriter (Proxy @IfaceTyCon) bh of tbl -> putEntry tbl bh ty get bh = case findUserDataReader (Proxy @IfaceTyCon) bh of tbl -> getEntry tbl bh @ We include the signatures of 'findUserDataWriter' and 'findUserDataReader' to make this code example easier to understand: @ findUserDataReader :: Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a findUserDataWriter :: Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a @ where 'BinaryReader' and 'BinaryWriter' correspond to the 'Binary' class methods 'get' and 'put_' respectively, thus: @ newtype BinaryReader s = BinaryReader { getEntry :: ReadBinHandle -> IO s } newtype BinaryWriter s = BinaryWriter { putEntry :: WriteBinHandle -> s -> IO () } @ 'findUserData*' looks up the serialisation function for 'IfaceTyCon', which we then subsequently use to serialise said 'IfaceTyCon'. If no such serialiser can be found, 'findUserData*' crashes at run-time. * Whenever a value of 'IfaceTyCon' needs to be serialised, there are two serialisation functions involved: * The literal serialiser that puts/gets the value to/from disk: Writes or reads a value of type 'IfaceTyCon' from the 'Write/ReadBinHandle'. This serialiser is primarily used to write the values stored in the deduplication table. It is also used to read the values from disk. * The deduplicating serialiser: Replaces the serialised value of 'IfaceTyCon' with an offset that is stored in the deduplication table. This serialiser is used while serialising the payload. We need to add the deduplicating serialiser to the 'ReaderUserData' and 'WriterUserData' respectively, so that 'findUserData*' can find them. For example, adding a serialiser for writing 'IfaceTyCon's: @ let bh0 :: WriteBinHandle = ... putIfaceTyCon = ... -- Serialises 'IfaceTyCon' to disk bh = addWriterToUserData (mkSomeBinaryWriter putIfaceTyCon) bh0 @ Naturally, you have to do something similar for reading values of 'IfaceTyCon'. The provided code example implements the previous behaviour: serialise all values of type 'IfaceTyCon' directly. No deduplication is happening. Now, instead of literally putting the value, we can introduce a deduplication table! Instead of specifying 'putIfaceTyCon', which writes a value of 'IfaceTyCon' directly to disk, we provide a function that looks up values in a table and provides an index of each value we have already seen. If the particular 'IfaceTyCon' we want to serialise isn't already in the de-dup table, we allocate a new index and extend the table. See the definition of 'initNameWriterTable' and 'initNameReaderTable' for example deduplication tables. * Storing the deduplication table. After the deduplicating the elements in the payload (e.g., 'ModIface'), we now have a deduplication table full with all the values. We serialise this table to disk using the real serialiser (e.g., 'putIfaceTyCon'). When serialisation is complete, we write out the de-dup table in 'putAllTables', serialising each 'IfaceTyCon' in the table. Of course, doing so might in turn serialise another de-dup'd thing (e.g. a FastString), thereby extending its respective de-dup table. Note [Order of deduplication tables during iface binary serialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Serialisation of 'ModIface' uses tables to deduplicate symbols that occur often. See Note [Deduplication during iface binary serialisation]. After 'ModIface' has been written to disk, we write the deduplication tables. Writing a table may add additional entries to *other* deduplication tables, thus we need to make sure that the symbol table we serialise only depends on deduplication tables that haven't been written to disk yet. For example, assume we maintain deduplication tables for 'FastString' and 'Name'. The symbol 'Name' depends on 'FastString', so serialising a 'Name' may add a 'FastString' to the 'FastString' deduplication table. Thus, 'Name' table needs to be serialised to disk before the 'FastString' table. When we read the 'ModIface' from disk, we consequentially need to read the 'FastString' deduplication table from disk, before we can deserialise the 'Name' deduplication table. Therefore, before we serialise the tables, we write forward pointers that allow us to jump ahead to the table we need to deserialise first. What deduplication tables exist and the order of serialisation is currently statically specified in 'putWithTables'. 'putWithTables' also takes care of the serialisation of used deduplication tables. The deserialisation of the deduplication tables happens 'getTables', using 'Binary' utility functions such as 'forwardGetRel'. Here, a visualisation of the table structure we currently have (ignoring 'ExtensibleFields'): ┌──────────────┐ │ Headers │ ├──────────────┤ │ Ptr FS ├────────┐ ├──────────────┤ │ │ Ptr Name ├─────┐ │ ├──────────────┤ │ │ │ │ │ │ │ ModIface │ │ │ │ Payload │ │ │ │ │ │ │ ├──────────────┤ │ │ │ │ │ │ │ Name Table │◄────┘ │ │ │ │ ├──────────────┤ │ │ │ │ │ FS Table │◄───────┘ │ │ └──────────────┘ -} {- Note [Lazy ReaderUserData during IfaceType serialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Serialising recursive data types, such as 'IfaceType', requires some trickery to inject the deduplication table at the right moment. When we serialise a value of 'IfaceType', we might encounter new 'IfaceType' values. For example, 'IfaceAppTy' has an 'IfaceType' field, which we want to deduplicate as well. Thus, when we serialise an 'IfaceType', we might add new 'IfaceType's to the 'GenericSymbolTable' (i.e., the deduplication table). These 'IfaceType's are then subsequently also serialised to disk, and uncover new 'IfaceType' values, etc... In other words, when we serialise an 'IfaceType' we write it out using a post-order traversal. See 'putGenericSymbolTable' for the implementation. Now, when we deserialise the deduplication table, reading the first element of the deduplication table will fail, as deserialisation requires that we read the child elements first. Remember, we wrote them to disk using a post-order traversal. To make this work, we therefore use 'lazyGet'' to lazily read the parent 'IfaceType', but delay the actual deserialisation. We just assume that once you need to force a value, the deduplication table for 'IfaceType' will be available. That's where 'bhRef' comes into play: @ bhRef <- newIORef (error "used too soon") ud <- unsafeInterleaveIO (readIORef bhRef) ... ifaceTypeReaderTable <- initReadIfaceTypeTable ud ... writeIORef bhRef (getReaderUserData bhFinal) @ 'ud' is the 'ReaderUserData' that will eventually contain the deduplication table for 'IfaceType'. As deserialisation of the 'IfaceType' needs the deduplication table, we provide a promise that it will exist in the future (represented by @unsafeInterleaveIO (readIORef bhRef)@). We pass 'ud' to 'initReadIfaceTypeTable', so the deserialisation will use the promised deduplication table. Once we have "read" the deduplication table, it will be available in 'bhFinal', and we fulfill the promise that the deduplication table for 'IfaceType' exists when forced. -} -- ----------------------------------------------------------------------------- -- The symbol table -- initReadIfaceTypeTable :: ReaderUserData -> IO (ReaderTable IfaceType) initReadIfaceTypeTable ud = do pure $ ReaderTable { getTable = getGenericSymbolTable (\bh -> lazyGet' getIfaceType (setReaderUserData bh ud)) , mkReaderFromTable = \tbl -> mkReader (getGenericSymtab tbl) } initWriteIfaceType :: CompressionIFace -> IO (WriterTable, BinaryWriter IfaceType) initWriteIfaceType compressionLevel = do sym_tab <- initGenericSymbolTable @(Map IfaceType) pure ( WriterTable { putTable = putGenericSymbolTable sym_tab (lazyPut' putIfaceType) } , mkWriter $ ifaceWriter sym_tab ) where ifaceWriter sym_tab = case compressionLevel of NormalCompression -> literalIfaceTypeSerialiser SafeExtraCompression -> ifaceTyConAppSerialiser sym_tab MaximumCompression -> fullIfaceTypeSerialiser sym_tab ifaceTyConAppSerialiser sym_tab bh ty = case ty of IfaceTyConApp {} -> do put_ bh ifaceTypeSharedByte putGenericSymTab sym_tab bh ty _ -> putIfaceType bh ty fullIfaceTypeSerialiser sym_tab bh ty = do put_ bh ifaceTypeSharedByte putGenericSymTab sym_tab bh ty literalIfaceTypeSerialiser = putIfaceType initNameReaderTable :: NameCache -> IO (ReaderTable Name) initNameReaderTable cache = do return $ ReaderTable { getTable = \bh -> getSymbolTable bh cache , mkReaderFromTable = \tbl -> mkReader (getSymtabName tbl) } data BinSymbolTable = BinSymbolTable { bin_symtab_next :: !FastMutInt, -- The next index to use bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name } initNameWriterTable :: IO (WriterTable, BinaryWriter Name) initNameWriterTable = do symtab_next <- newFastMutInt 0 symtab_map <- newIORef emptyUFM let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next , bin_symtab_map = symtab_map } let put_symtab bh = do name_count <- readFastMutInt symtab_next symtab_map <- readIORef symtab_map putSymbolTable bh name_count symtab_map pure name_count return ( WriterTable { putTable = put_symtab } , mkWriter $ putName bin_symtab ) putSymbolTable :: WriteBinHandle -> Int -> UniqFM Name (Int,Name) -> IO () putSymbolTable bh name_count symtab = do put_ bh name_count let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) -- It's OK to use nonDetEltsUFM here because the elements have -- indices that array uses to create order mapM_ (\n -> serialiseName bh n symtab) names getSymbolTable :: ReadBinHandle -> NameCache -> IO (SymbolTable Name) getSymbolTable bh name_cache = do sz <- get bh :: IO Int -- create an array of Names for the symbols and add them to the NameCache updateNameCache' name_cache $ \cache0 -> do mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name) cache <- foldGet' (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do let mod = mkModule uid mod_name case lookupOrigNameCache cache mod occ of Just name -> do writeArray mut_arr (fromIntegral i) name return cache Nothing -> do uniq <- takeUniqFromNameCache name_cache let name = mkExternalName uniq mod occ noSrcSpan new_cache = extendOrigNameCache cache mod occ name writeArray mut_arr (fromIntegral i) name return new_cache arr <- unsafeFreeze mut_arr return (cache, arr) serialiseName :: WriteBinHandle -> Name -> UniqFM key (Int,Name) -> IO () serialiseName bh name _ = do let mod = assertPpr (isExternalName name) (ppr name) (nameModule name) put_ bh (moduleUnit mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- An occurrence of a name in an interface file is serialized as a single 32-bit -- word. The format of this word is: -- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx -- A normal name. x is an index into the symbol table -- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy -- A known-key name. x is the Unique's Char, y is the int part. We assume that -- all known-key uniques fit in this space. This is asserted by -- GHC.Builtin.Utils.knownKeyNamesOkay. -- -- During serialization we check for known-key things using isKnownKeyName. -- During deserialization we use lookupKnownKeyName to get from the unique back -- to its corresponding Name. -- See Note [Symbol table representation of names] putName :: BinSymbolTable -> WriteBinHandle -> Name -> IO () putName BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } bh name | isKnownKeyName name , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits = -- assert (u < 2^(22 :: Int)) put_ bh (0x80000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32)) | otherwise = do symtab_map <- readIORef symtab_map_ref case lookupUFM symtab_map name of Just (off,_) -> put_ bh (fromIntegral off :: Word32) Nothing -> do off <- readFastMutInt symtab_next -- massert (off < 2^(30 :: Int)) writeFastMutInt symtab_next (off+1) writeIORef symtab_map_ref $! addToUFM symtab_map name (off,name) put_ bh (fromIntegral off :: Word32) -- See Note [Symbol table representation of names] getSymtabName :: SymbolTable Name -> ReadBinHandle -> IO Name getSymtabName symtab bh = do i :: Word32 <- get bh case i .&. 0xC0000000 of 0x00000000 -> return $! symtab ! fromIntegral i 0x80000000 -> let tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) ix = fromIntegral i .&. 0x003FFFFF u = mkUnique tag ix in return $! case lookupKnownKeyName u of Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i $$ ppr u $$ char tag $$ ppr ix) Just n -> n _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)