1{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-} 2 3-- 4-- (c) The University of Glasgow 2002-2006 5-- 6 7{-# OPTIONS_GHC -O2 #-} 8-- We always optimise this, otherwise performance of a non-optimised 9-- compiler is severely affected 10 11-- | Binary interface file support. 12module BinIface ( 13 -- * Public API for interface file serialisation 14 writeBinIface, 15 readBinIface, 16 getSymtabName, 17 getDictFastString, 18 CheckHiWay(..), 19 TraceBinIFaceReading(..), 20 getWithUserData, 21 putWithUserData, 22 23 -- * Internal serialisation functions 24 getSymbolTable, 25 putName, 26 putDictionary, 27 putFastString, 28 putSymbolTable, 29 BinSymbolTable(..), 30 BinDictionary(..) 31 32 ) where 33 34#include "HsVersions.h" 35 36import GhcPrelude 37 38import TcRnMonad 39import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) 40import IfaceEnv 41import HscTypes 42import Module 43import Name 44import DynFlags 45import UniqFM 46import UniqSupply 47import Panic 48import Binary 49import SrcLoc 50import ErrUtils 51import FastMutInt 52import Unique 53import Outputable 54import NameCache 55import GHC.Platform 56import FastString 57import Constants 58import Util 59 60import Data.Array 61import Data.Array.ST 62import Data.Array.Unsafe 63import Data.Bits 64import Data.Char 65import Data.Word 66import Data.IORef 67import Data.Foldable 68import Control.Monad 69import Control.Monad.ST 70import Control.Monad.Trans.Class 71import qualified Control.Monad.Trans.State.Strict as State 72 73-- --------------------------------------------------------------------------- 74-- Reading and writing binary interface files 75-- 76 77data CheckHiWay = CheckHiWay | IgnoreHiWay 78 deriving Eq 79 80data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading 81 deriving Eq 82 83-- | Read an interface file 84readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath 85 -> TcRnIf a b ModIface 86readBinIface checkHiWay traceBinIFaceReading hi_path = do 87 ncu <- mkNameCacheUpdater 88 dflags <- getDynFlags 89 liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu 90 91readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath 92 -> NameCacheUpdater 93 -> IO ModIface 94readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do 95 let printer :: SDoc -> IO () 96 printer = case traceBinIFaceReading of 97 TraceBinIFaceReading -> \sd -> 98 putLogMsg dflags 99 NoReason 100 SevOutput 101 noSrcSpan 102 (defaultDumpStyle dflags) 103 sd 104 QuietBinIFaceReading -> \_ -> return () 105 106 wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () 107 wantedGot what wanted got ppr' = 108 printer (text what <> text ": " <> 109 vcat [text "Wanted " <> ppr' wanted <> text ",", 110 text "got " <> ppr' got]) 111 112 errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () 113 errorOnMismatch what wanted got = 114 -- This will be caught by readIface which will emit an error 115 -- msg containing the iface module name. 116 when (wanted /= got) $ throwGhcExceptionIO $ ProgramError 117 (what ++ " (wanted " ++ show wanted 118 ++ ", got " ++ show got ++ ")") 119 bh <- Binary.readBinMem hi_path 120 121 -- Read the magic number to check that this really is a GHC .hi file 122 -- (This magic number does not change when we change 123 -- GHC interface file format) 124 magic <- get bh 125 wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr 126 errorOnMismatch "magic number mismatch: old/corrupt interface file?" 127 (binaryInterfaceMagic dflags) magic 128 129 -- Note [dummy iface field] 130 -- read a dummy 32/64 bit value. This field used to hold the 131 -- dictionary pointer in old interface file formats, but now 132 -- the dictionary pointer is after the version (where it 133 -- should be). Also, the serialisation of value of type "Bin 134 -- a" used to depend on the word size of the machine, now they 135 -- are always 32 bits. 136 if wORD_SIZE dflags == 4 137 then do _ <- Binary.get bh :: IO Word32; return () 138 else do _ <- Binary.get bh :: IO Word64; return () 139 140 -- Check the interface file version and ways. 141 check_ver <- get bh 142 let our_ver = show hiVersion 143 wantedGot "Version" our_ver check_ver text 144 errorOnMismatch "mismatched interface file versions" our_ver check_ver 145 146 check_way <- get bh 147 let way_descr = getWayDescr dflags 148 wantedGot "Way" way_descr check_way ppr 149 when (checkHiWay == CheckHiWay) $ 150 errorOnMismatch "mismatched interface file ways" way_descr check_way 151 getWithUserData ncu bh 152 153 154-- | This performs a get action after reading the dictionary and symbol 155-- table. It is necessary to run this before trying to deserialise any 156-- Names or FastStrings. 157getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a 158getWithUserData ncu bh = do 159 -- Read the dictionary 160 -- The next word in the file is a pointer to where the dictionary is 161 -- (probably at the end of the file) 162 dict_p <- Binary.get bh 163 data_p <- tellBin bh -- Remember where we are now 164 seekBin bh dict_p 165 dict <- getDictionary bh 166 seekBin bh data_p -- Back to where we were before 167 168 -- Initialise the user-data field of bh 169 bh <- do 170 bh <- return $ setUserData bh $ newReadState (error "getSymtabName") 171 (getDictFastString dict) 172 symtab_p <- Binary.get bh -- Get the symtab ptr 173 data_p <- tellBin bh -- Remember where we are now 174 seekBin bh symtab_p 175 symtab <- getSymbolTable bh ncu 176 seekBin bh data_p -- Back to where we were before 177 178 -- It is only now that we know how to get a Name 179 return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) 180 (getDictFastString dict) 181 182 -- Read the interface file 183 get bh 184 185-- | Write an interface file 186writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () 187writeBinIface dflags hi_path mod_iface = do 188 bh <- openBinMem initBinMemSize 189 put_ bh (binaryInterfaceMagic dflags) 190 191 -- dummy 32/64-bit field before the version/way for 192 -- compatibility with older interface file formats. 193 -- See Note [dummy iface field] above. 194 if wORD_SIZE dflags == 4 195 then Binary.put_ bh (0 :: Word32) 196 else Binary.put_ bh (0 :: Word64) 197 198 -- The version and way descriptor go next 199 put_ bh (show hiVersion) 200 let way_descr = getWayDescr dflags 201 put_ bh way_descr 202 203 204 putWithUserData (debugTraceMsg dflags 3) bh mod_iface 205 -- And send the result to the file 206 writeBinMem bh hi_path 207 208-- | Put a piece of data with an initialised `UserData` field. This 209-- is necessary if you want to serialise Names or FastStrings. 210-- It also writes a symbol table and the dictionary. 211-- This segment should be read using `getWithUserData`. 212putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () 213putWithUserData log_action bh payload = do 214 -- Remember where the dictionary pointer will go 215 dict_p_p <- tellBin bh 216 -- Placeholder for ptr to dictionary 217 put_ bh dict_p_p 218 219 -- Remember where the symbol table pointer will go 220 symtab_p_p <- tellBin bh 221 put_ bh symtab_p_p 222 -- Make some initial state 223 symtab_next <- newFastMutInt 224 writeFastMutInt symtab_next 0 225 symtab_map <- newIORef emptyUFM 226 let bin_symtab = BinSymbolTable { 227 bin_symtab_next = symtab_next, 228 bin_symtab_map = symtab_map } 229 dict_next_ref <- newFastMutInt 230 writeFastMutInt dict_next_ref 0 231 dict_map_ref <- newIORef emptyUFM 232 let bin_dict = BinDictionary { 233 bin_dict_next = dict_next_ref, 234 bin_dict_map = dict_map_ref } 235 236 -- Put the main thing, 237 bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) 238 (putName bin_dict bin_symtab) 239 (putFastString bin_dict) 240 put_ bh payload 241 242 -- Write the symtab pointer at the front of the file 243 symtab_p <- tellBin bh -- This is where the symtab will start 244 putAt bh symtab_p_p symtab_p -- Fill in the placeholder 245 seekBin bh symtab_p -- Seek back to the end of the file 246 247 -- Write the symbol table itself 248 symtab_next <- readFastMutInt symtab_next 249 symtab_map <- readIORef symtab_map 250 putSymbolTable bh symtab_next symtab_map 251 log_action (text "writeBinIface:" <+> int symtab_next 252 <+> text "Names") 253 254 -- NB. write the dictionary after the symbol table, because 255 -- writing the symbol table may create more dictionary entries. 256 257 -- Write the dictionary pointer at the front of the file 258 dict_p <- tellBin bh -- This is where the dictionary will start 259 putAt bh dict_p_p dict_p -- Fill in the placeholder 260 seekBin bh dict_p -- Seek back to the end of the file 261 262 -- Write the dictionary itself 263 dict_next <- readFastMutInt dict_next_ref 264 dict_map <- readIORef dict_map_ref 265 putDictionary bh dict_next dict_map 266 log_action (text "writeBinIface:" <+> int dict_next 267 <+> text "dict entries") 268 269 270 271-- | Initial ram buffer to allocate for writing interface files 272initBinMemSize :: Int 273initBinMemSize = 1024 * 1024 274 275binaryInterfaceMagic :: DynFlags -> Word32 276binaryInterfaceMagic dflags 277 | target32Bit (targetPlatform dflags) = 0x1face 278 | otherwise = 0x1face64 279 280 281-- ----------------------------------------------------------------------------- 282-- The symbol table 283-- 284 285putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () 286putSymbolTable bh next_off symtab = do 287 put_ bh next_off 288 let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) 289 -- It's OK to use nonDetEltsUFM here because the elements have 290 -- indices that array uses to create order 291 mapM_ (\n -> serialiseName bh n symtab) names 292 293getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable 294getSymbolTable bh ncu = do 295 sz <- get bh 296 od_names <- sequence (replicate sz (get bh)) 297 updateNameCache ncu $ \namecache -> 298 runST $ flip State.evalStateT namecache $ do 299 mut_arr <- lift $ newSTArray_ (0, sz-1) 300 for_ (zip [0..] od_names) $ \(i, odn) -> do 301 (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn 302 lift $ writeArray mut_arr i n 303 State.put nc 304 arr <- lift $ unsafeFreeze mut_arr 305 namecache' <- State.get 306 return (namecache', arr) 307 where 308 -- This binding is required because the type of newArray_ cannot be inferred 309 newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) 310 newSTArray_ = newArray_ 311 312type OnDiskName = (UnitId, ModuleName, OccName) 313 314fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) 315fromOnDiskName nc (pid, mod_name, occ) = 316 let mod = mkModule pid mod_name 317 cache = nsNames nc 318 in case lookupOrigNameCache cache mod occ of 319 Just name -> (nc, name) 320 Nothing -> 321 let (uniq, us) = takeUniqFromSupply (nsUniqs nc) 322 name = mkExternalName uniq mod occ noSrcSpan 323 new_cache = extendNameCache cache mod occ name 324 in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) 325 326serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () 327serialiseName bh name _ = do 328 let mod = ASSERT2( isExternalName name, ppr name ) nameModule name 329 put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) 330 331 332-- Note [Symbol table representation of names] 333-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 334-- 335-- An occurrence of a name in an interface file is serialized as a single 32-bit 336-- word. The format of this word is: 337-- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx 338-- A normal name. x is an index into the symbol table 339-- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy 340-- A known-key name. x is the Unique's Char, y is the int part. We assume that 341-- all known-key uniques fit in this space. This is asserted by 342-- PrelInfo.knownKeyNamesOkay. 343-- 344-- During serialization we check for known-key things using isKnownKeyName. 345-- During deserialization we use lookupKnownKeyName to get from the unique back 346-- to its corresponding Name. 347 348 349-- See Note [Symbol table representation of names] 350putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () 351putName _dict BinSymbolTable{ 352 bin_symtab_map = symtab_map_ref, 353 bin_symtab_next = symtab_next } 354 bh name 355 | isKnownKeyName name 356 , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits 357 = -- ASSERT(u < 2^(22 :: Int)) 358 put_ bh (0x80000000 359 .|. (fromIntegral (ord c) `shiftL` 22) 360 .|. (fromIntegral u :: Word32)) 361 362 | otherwise 363 = do symtab_map <- readIORef symtab_map_ref 364 case lookupUFM symtab_map name of 365 Just (off,_) -> put_ bh (fromIntegral off :: Word32) 366 Nothing -> do 367 off <- readFastMutInt symtab_next 368 -- MASSERT(off < 2^(30 :: Int)) 369 writeFastMutInt symtab_next (off+1) 370 writeIORef symtab_map_ref 371 $! addToUFM symtab_map name (off,name) 372 put_ bh (fromIntegral off :: Word32) 373 374-- See Note [Symbol table representation of names] 375getSymtabName :: NameCacheUpdater 376 -> Dictionary -> SymbolTable 377 -> BinHandle -> IO Name 378getSymtabName _ncu _dict symtab bh = do 379 i :: Word32 <- get bh 380 case i .&. 0xC0000000 of 381 0x00000000 -> return $! symtab ! fromIntegral i 382 383 0x80000000 -> 384 let 385 tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) 386 ix = fromIntegral i .&. 0x003FFFFF 387 u = mkUnique tag ix 388 in 389 return $! case lookupKnownKeyName u of 390 Nothing -> pprPanic "getSymtabName:unknown known-key unique" 391 (ppr i $$ ppr (unpkUnique u)) 392 Just n -> n 393 394 _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) 395 396data BinSymbolTable = BinSymbolTable { 397 bin_symtab_next :: !FastMutInt, -- The next index to use 398 bin_symtab_map :: !(IORef (UniqFM (Int,Name))) 399 -- indexed by Name 400 } 401 402putFastString :: BinDictionary -> BinHandle -> FastString -> IO () 403putFastString dict bh fs = allocateFastString dict fs >>= put_ bh 404 405allocateFastString :: BinDictionary -> FastString -> IO Word32 406allocateFastString BinDictionary { bin_dict_next = j_r, 407 bin_dict_map = out_r} f = do 408 out <- readIORef out_r 409 let uniq = getUnique f 410 case lookupUFM out uniq of 411 Just (j, _) -> return (fromIntegral j :: Word32) 412 Nothing -> do 413 j <- readFastMutInt j_r 414 writeFastMutInt j_r (j + 1) 415 writeIORef out_r $! addToUFM out uniq (j, f) 416 return (fromIntegral j :: Word32) 417 418getDictFastString :: Dictionary -> BinHandle -> IO FastString 419getDictFastString dict bh = do 420 j <- get bh 421 return $! (dict ! fromIntegral (j :: Word32)) 422 423data BinDictionary = BinDictionary { 424 bin_dict_next :: !FastMutInt, -- The next index to use 425 bin_dict_map :: !(IORef (UniqFM (Int,FastString))) 426 -- indexed by FastString 427 } 428 429getWayDescr :: DynFlags -> String 430getWayDescr dflags 431 | platformUnregisterised (targetPlatform dflags) = 'u':tag 432 | otherwise = tag 433 where tag = buildTag dflags 434 -- if this is an unregisterised build, make sure our interfaces 435 -- can't be used by a registerised build. 436