+-- ---------------------------------------------------------------------------
+-- Reading and writing binary interface files
+
+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> TcRnIf a b ModIface
+readBinIface checkHiWay traceBinIFaceReading hi_path = do
+ update_nc <- mkNameCacheUpdater
+ dflags <- getDOpts
+ liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> NameCacheUpdater (Array Int Name)
+ -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
+ let printer :: SDoc -> IO ()
+ printer = case traceBinIFaceReading of
+ TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
+ QuietBinIFaceReading -> \_ -> return ()
+ wantedGot :: Outputable a => String -> a -> a -> IO ()
+ wantedGot what wanted got
+ = 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) $ ghcError $ 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 magic
+ errorOnMismatch "magic number mismatch: old/corrupt interface file?"
+ binaryInterfaceMagic magic
+
+ -- Note [dummy iface field]
+ -- read a dummy 32/64 bit value. This field used to hold the
+ -- dictionary pointer in old interface file formats, but now
+ -- the dictionary pointer is after the version (where it
+ -- should be). Also, the serialisation of value of type "Bin
+ -- a" used to depend on the word size of the machine, now they
+ -- are always 32 bits.
+ --
+ if wORD_SIZE == 4
+ then do _ <- Binary.get bh :: IO Word32; return ()
+ else do _ <- Binary.get bh :: IO Word64; return ()
+
+ -- Check the interface file version and ways.
+ check_ver <- get bh
+ let our_ver = show opt_HiVersion
+ wantedGot "Version" our_ver check_ver
+ errorOnMismatch "mismatched interface file versions" our_ver check_ver
+
+ check_way <- get bh
+ let way_descr = getWayDescr dflags
+ wantedGot "Way" way_descr check_way
+ when (checkHiWay == CheckHiWay) $
+ errorOnMismatch "mismatched interface file ways" way_descr check_way
+
+ -- Read the dictionary
+ -- The next word in the file is a pointer to where the dictionary is
+ -- (probably at the end of the file)
+ dict_p <- Binary.get bh
+ data_p <- tellBin bh -- Remember where we are now
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p -- Back to where we were before
+
+ -- Initialise the user-data field of bh
+ ud <- newReadState dict
+ bh <- return (setUserData bh ud)
+
+ symtab_p <- Binary.get bh -- Get the symtab ptr
+ data_p <- tellBin bh -- Remember where we are now
+ seekBin bh symtab_p
+ symtab <- getSymbolTable bh update_nc
+ seekBin bh data_p -- Back to where we were before
+ let ud = getUserData bh
+ bh <- return $! setUserData bh ud{ud_symtab = symtab}
+ iface <- get bh
+ return iface
+
+
+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
+writeBinIface dflags hi_path mod_iface = do
+ bh <- openBinMem initBinMemSize
+ put_ bh binaryInterfaceMagic
+
+ -- dummy 32/64-bit field before the version/way for
+ -- compatibility with older interface file formats.
+ -- See Note [dummy iface field] above.
+ if wORD_SIZE == 4
+ then Binary.put_ bh (0 :: Word32)
+ else Binary.put_ bh (0 :: Word64)
+
+ -- The version and way descriptor go next
+ put_ bh (show opt_HiVersion)
+ let way_descr = getWayDescr dflags
+ put_ bh way_descr
+
+ -- Remember where the dictionary pointer will go
+ dict_p_p <- tellBin bh
+ put_ bh dict_p_p -- Placeholder for ptr to dictionary
+
+ -- Remember where the symbol table pointer will go
+ symtab_p_p <- tellBin bh
+ put_ bh symtab_p_p
+
+ -- Make some intial state
+ symtab_next <- newFastMutInt
+ writeFastMutInt symtab_next 0
+ symtab_map <- newIORef emptyUFM
+ let bin_symtab = BinSymbolTable {
+ bin_symtab_next = symtab_next,
+ bin_symtab_map = symtab_map }
+ dict_next_ref <- newFastMutInt
+ writeFastMutInt dict_next_ref 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict = BinDictionary {
+ bin_dict_next = dict_next_ref,
+ bin_dict_map = dict_map_ref }
+ ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
+
+ -- Put the main thing,
+ bh <- return $ setUserData bh ud
+ put_ bh mod_iface
+
+ -- Write the symtab pointer at the fornt of the file
+ symtab_p <- tellBin bh -- This is where the symtab will start
+ putAt bh symtab_p_p symtab_p -- Fill in the placeholder
+ seekBin bh symtab_p -- Seek back to the end of the file
+
+ -- Write the symbol table itself
+ symtab_next <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
+ putSymbolTable bh symtab_next symtab_map
+ debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
+ <+> text "Names")
+
+ -- NB. write the dictionary after the symbol table, because
+ -- writing the symbol table may create more dictionary entries.
+
+ -- Write the dictionary pointer at the fornt of the file
+ dict_p <- tellBin bh -- This is where the dictionary will start
+ putAt bh dict_p_p dict_p -- Fill in the placeholder
+ seekBin bh dict_p -- Seek back to the end of the file
+
+ -- Write the dictionary itself
+ dict_next <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
+ putDictionary bh dict_next dict_map
+ debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
+ <+> text "dict entries")
+
+ -- And send the result to the file
+ writeBinMem bh hi_path
+
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024
+
+-- The *host* architecture version:
+#include "../includes/MachDeps.h"
+
+binaryInterfaceMagic :: Word32
+#if WORD_SIZE_IN_BITS == 32
+binaryInterfaceMagic = 0x1face
+#elif WORD_SIZE_IN_BITS == 64
+binaryInterfaceMagic = 0x1face64
+#endif
+
+-- -----------------------------------------------------------------------------
+-- The symbol table
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable bh next_off symtab = do
+ put_ bh next_off
+ let names = elems (array (0,next_off-1) (eltsUFM symtab))
+ mapM_ (\n -> serialiseName bh n symtab) names
+
+getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
+ -> IO (Array Int Name)
+getSymbolTable bh update_namecache = do
+ sz <- get bh
+ od_names <- sequence (replicate sz (get bh))
+ update_namecache $ \namecache ->
+ let
+ arr = listArray (0,sz-1) names
+ (namecache', names) =
+ mapAccumR (fromOnDiskName arr) namecache od_names
+ in (namecache', arr)
+
+type OnDiskName = (PackageId, ModuleName, OccName)
+
+fromOnDiskName
+ :: Array Int Name
+ -> NameCache
+ -> OnDiskName
+ -> (NameCache, Name)
+fromOnDiskName _ nc (pid, mod_name, occ) =
+ let
+ mod = mkModule pid mod_name
+ cache = nsNames nc
+ in
+ case lookupOrigNameCache cache mod occ of
+ Just name -> (nc, name)
+ Nothing ->
+ let
+ us = nsUniqs nc
+ uniq = uniqFromSupply us
+ name = mkExternalName uniq mod occ noSrcSpan
+ new_cache = extendNameCache cache mod occ name
+ in
+ case splitUniqSupply us of { (us',_) ->
+ ( nc{ nsUniqs = us', nsNames = new_cache }, name )
+ }
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name _ = do
+ let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+ put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+
+
+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName BinSymbolTable{
+ bin_symtab_map = symtab_map_ref,
+ bin_symtab_next = symtab_next } bh name
+ = 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
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! addToUFM symtab_map name (off,name)
+ put_ bh (fromIntegral off :: Word32)
+
+
+data BinSymbolTable = BinSymbolTable {
+ bin_symtab_next :: !FastMutInt, -- The next index to use
+ bin_symtab_map :: !(IORef (UniqFM (Int,Name)))
+ -- indexed by Name
+ }
+
+
+putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putFastString BinDictionary { bin_dict_next = j_r,
+ bin_dict_map = out_r} bh f
+ = do
+ out <- readIORef out_r
+ let uniq = getUnique f
+ case lookupUFM out uniq of
+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)
+ Nothing -> do
+ j <- readFastMutInt j_r
+ put_ bh (fromIntegral j :: Word32)
+ writeFastMutInt j_r (j + 1)
+ writeIORef out_r $! addToUFM out uniq (j, f)
+
+
+data BinDictionary = BinDictionary {
+ bin_dict_next :: !FastMutInt, -- The next index to use
+ bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
+ -- indexed by FastString
+ }
+
+-- -----------------------------------------------------------------------------
+-- All the binary instances