1{- 2Binary serialization for .hie files. 3-} 4{- HLINT ignore -} 5{-# LANGUAGE ScopedTypeVariables #-} 6module Compat.HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc,NameCacheUpdater(..)) where 7 8import GHC.Settings ( maybeRead ) 9 10import Config ( cProjectVersion ) 11import Binary 12import BinIface ( getDictFastString ) 13import FastMutInt 14import FastString ( FastString ) 15import Module ( Module ) 16import Name 17import NameCache 18import Outputable 19import PrelInfo 20import SrcLoc 21import UniqSupply ( takeUniqFromSupply ) 22import Unique 23import UniqFM 24import IfaceEnv 25 26import qualified Data.Array as A 27import Data.IORef 28import Data.ByteString ( ByteString ) 29import qualified Data.ByteString as BS 30import qualified Data.ByteString.Char8 as BSC 31import Data.List ( mapAccumR ) 32import Data.Word ( Word8, Word32 ) 33import Control.Monad ( replicateM, when ) 34import System.Directory ( createDirectoryIfMissing ) 35import System.FilePath ( takeDirectory ) 36 37import HieTypes 38 39-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ 40-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between 41-- these two types. 42data HieName 43 = ExternalName !Module !OccName !SrcSpan 44 | LocalName !OccName !SrcSpan 45 | KnownKeyName !Unique 46 deriving (Eq) 47 48instance Ord HieName where 49 compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) 50 compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) 51 compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b 52 -- Not actually non determinstic as it is a KnownKey 53 compare ExternalName{} _ = LT 54 compare LocalName{} ExternalName{} = GT 55 compare LocalName{} _ = LT 56 compare KnownKeyName{} _ = GT 57 58instance Outputable HieName where 59 ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp 60 ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp 61 ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u 62 63hieNameOcc :: HieName -> OccName 64hieNameOcc (ExternalName _ occ _) = occ 65hieNameOcc (LocalName occ _) = occ 66hieNameOcc (KnownKeyName u) = 67 case lookupKnownKeyName u of 68 Just n -> nameOccName n 69 Nothing -> pprPanic "hieNameOcc:unknown known-key unique" 70 (ppr (unpkUnique u)) 71 72 73data HieSymbolTable = HieSymbolTable 74 { hie_symtab_next :: !FastMutInt 75 , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) 76 } 77 78data HieDictionary = HieDictionary 79 { hie_dict_next :: !FastMutInt -- The next index to use 80 , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString 81 } 82 83initBinMemSize :: Int 84initBinMemSize = 1024*1024 85 86-- | The header for HIE files - Capital ASCII letters "HIE". 87hieMagic :: [Word8] 88hieMagic = [72,73,69] 89 90hieMagicLen :: Int 91hieMagicLen = length hieMagic 92 93ghcVersion :: ByteString 94ghcVersion = BSC.pack cProjectVersion 95 96putBinLine :: BinHandle -> ByteString -> IO () 97putBinLine bh xs = do 98 mapM_ (putByte bh) $ BS.unpack xs 99 putByte bh 10 -- newline char 100 101-- | Write a `HieFile` to the given `FilePath`, with a proper header and 102-- symbol tables for `Name`s and `FastString`s 103writeHieFile :: FilePath -> HieFile -> IO () 104writeHieFile hie_file_path hiefile = do 105 bh0 <- openBinMem initBinMemSize 106 107 -- Write the header: hieHeader followed by the 108 -- hieVersion and the GHC version used to generate this file 109 mapM_ (putByte bh0) hieMagic 110 putBinLine bh0 $ BSC.pack $ show hieVersion 111 putBinLine bh0 $ ghcVersion 112 113 -- remember where the dictionary pointer will go 114 dict_p_p <- tellBin bh0 115 put_ bh0 dict_p_p 116 117 -- remember where the symbol table pointer will go 118 symtab_p_p <- tellBin bh0 119 put_ bh0 symtab_p_p 120 121 -- Make some intial state 122 symtab_next <- newFastMutInt 123 writeFastMutInt symtab_next 0 124 symtab_map <- newIORef emptyUFM 125 let hie_symtab = HieSymbolTable { 126 hie_symtab_next = symtab_next, 127 hie_symtab_map = symtab_map } 128 dict_next_ref <- newFastMutInt 129 writeFastMutInt dict_next_ref 0 130 dict_map_ref <- newIORef emptyUFM 131 let hie_dict = HieDictionary { 132 hie_dict_next = dict_next_ref, 133 hie_dict_map = dict_map_ref } 134 135 -- put the main thing 136 let bh = setUserData bh0 $ newWriteState (putName hie_symtab) 137 (putName hie_symtab) 138 (putFastString hie_dict) 139 put_ bh hiefile 140 141 -- write the symtab pointer at the front of the file 142 symtab_p <- tellBin bh 143 putAt bh symtab_p_p symtab_p 144 seekBin bh symtab_p 145 146 -- write the symbol table itself 147 symtab_next' <- readFastMutInt symtab_next 148 symtab_map' <- readIORef symtab_map 149 putSymbolTable bh symtab_next' symtab_map' 150 151 -- write the dictionary pointer at the front of the file 152 dict_p <- tellBin bh 153 putAt bh dict_p_p dict_p 154 seekBin bh dict_p 155 156 -- write the dictionary itself 157 dict_next <- readFastMutInt dict_next_ref 158 dict_map <- readIORef dict_map_ref 159 putDictionary bh dict_next dict_map 160 161 -- and send the result to the file 162 createDirectoryIfMissing True (takeDirectory hie_file_path) 163 writeBinMem bh hie_file_path 164 return () 165 166data HieFileResult 167 = HieFileResult 168 { hie_file_result_version :: Integer 169 , hie_file_result_ghc_version :: ByteString 170 , hie_file_result :: HieFile 171 } 172 173type HieHeader = (Integer, ByteString) 174 175-- | Read a `HieFile` from a `FilePath`. Can use 176-- an existing `NameCache`. Allows you to specify 177-- which versions of hieFile to attempt to read. 178-- `Left` case returns the failing header versions. 179readHieFileWithVersion :: (HieHeader -> Bool) -> NameCacheUpdater -> FilePath -> IO (Either HieHeader HieFileResult) 180readHieFileWithVersion readVersion ncu file = do 181 bh0 <- readBinMem file 182 183 (hieVersion, ghcVersion) <- readHieFileHeader file bh0 184 185 if readVersion (hieVersion, ghcVersion) 186 then do 187 hieFile <- readHieFileContents bh0 ncu 188 return $ Right (HieFileResult hieVersion ghcVersion hieFile) 189 else return $ Left (hieVersion, ghcVersion) 190 191 192-- | Read a `HieFile` from a `FilePath`. Can use 193-- an existing `NameCache`. 194readHieFile :: NameCacheUpdater -> FilePath -> IO HieFileResult 195readHieFile ncu file = do 196 197 bh0 <- readBinMem file 198 199 (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 200 201 -- Check if the versions match 202 when (readHieVersion /= hieVersion) $ 203 panic $ unwords ["readHieFile: hie file versions don't match for file:" 204 , file 205 , "Expected" 206 , show hieVersion 207 , "but got", show readHieVersion 208 ] 209 hieFile <- readHieFileContents bh0 ncu 210 return $ HieFileResult hieVersion ghcVersion hieFile 211 212readBinLine :: BinHandle -> IO ByteString 213readBinLine bh = BS.pack . reverse <$> loop [] 214 where 215 loop acc = do 216 char <- get bh :: IO Word8 217 if char == 10 -- ASCII newline '\n' 218 then return acc 219 else loop (char : acc) 220 221readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader 222readHieFileHeader file bh0 = do 223 -- Read the header 224 magic <- replicateM hieMagicLen (get bh0) 225 version <- BSC.unpack <$> readBinLine bh0 226 case maybeRead version of 227 Nothing -> 228 panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" 229 , show version 230 ] 231 Just readHieVersion -> do 232 ghcVersion <- readBinLine bh0 233 234 -- Check if the header is valid 235 when (magic /= hieMagic) $ 236 panic $ unwords ["readHieFileHeader: headers don't match for file:" 237 , file 238 , "Expected" 239 , show hieMagic 240 , "but got", show magic 241 ] 242 return (readHieVersion, ghcVersion) 243 244readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile 245readHieFileContents bh0 ncu = do 246 247 dict <- get_dictionary bh0 248 249 -- read the symbol table so we are capable of reading the actual data 250 bh1 <- do 251 let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") 252 (getDictFastString dict) 253 symtab <- get_symbol_table bh1 254 let bh1' = setUserData bh1 255 $ newReadState (getSymTabName symtab) 256 (getDictFastString dict) 257 return bh1' 258 259 -- load the actual data 260 hiefile <- get bh1 261 return hiefile 262 where 263 get_dictionary bin_handle = do 264 dict_p <- get bin_handle 265 data_p <- tellBin bin_handle 266 seekBin bin_handle dict_p 267 dict <- getDictionary bin_handle 268 seekBin bin_handle data_p 269 return dict 270 271 get_symbol_table bh1 = do 272 symtab_p <- get bh1 273 data_p' <- tellBin bh1 274 seekBin bh1 symtab_p 275 symtab <- getSymbolTable bh1 ncu 276 seekBin bh1 data_p' 277 return symtab 278 279putFastString :: HieDictionary -> BinHandle -> FastString -> IO () 280putFastString HieDictionary { hie_dict_next = j_r, 281 hie_dict_map = out_r} bh f 282 = do 283 out <- readIORef out_r 284 let unique = getUnique f 285 case lookupUFM out unique of 286 Just (j, _) -> put_ bh (fromIntegral j :: Word32) 287 Nothing -> do 288 j <- readFastMutInt j_r 289 put_ bh (fromIntegral j :: Word32) 290 writeFastMutInt j_r (j + 1) 291 writeIORef out_r $! addToUFM out unique (j, f) 292 293putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () 294putSymbolTable bh next_off symtab = do 295 put_ bh next_off 296 let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) 297 mapM_ (putHieName bh) names 298 299getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable 300getSymbolTable bh ncu = do 301 sz <- get bh 302 od_names <- replicateM sz (getHieName bh) 303 updateNameCache ncu $ \nc -> 304 let arr = A.listArray (0,sz-1) names 305 (nc', names) = mapAccumR fromHieName nc od_names 306 in (nc',arr) 307 308getSymTabName :: SymbolTable -> BinHandle -> IO Name 309getSymTabName st bh = do 310 i :: Word32 <- get bh 311 return $ st A.! (fromIntegral i) 312 313putName :: HieSymbolTable -> BinHandle -> Name -> IO () 314putName (HieSymbolTable next ref) bh name = do 315 symmap <- readIORef ref 316 case lookupUFM symmap name of 317 Just (off, ExternalName mod occ (UnhelpfulSpan _)) 318 | isGoodSrcSpan (nameSrcSpan name) -> do 319 let hieName = ExternalName mod occ (nameSrcSpan name) 320 writeIORef ref $! addToUFM symmap name (off, hieName) 321 put_ bh (fromIntegral off :: Word32) 322 Just (off, LocalName _occ span) 323 | notLocal (toHieName name) || nameSrcSpan name /= span -> do 324 writeIORef ref $! addToUFM symmap name (off, toHieName name) 325 put_ bh (fromIntegral off :: Word32) 326 Just (off, _) -> put_ bh (fromIntegral off :: Word32) 327 Nothing -> do 328 off <- readFastMutInt next 329 writeFastMutInt next (off+1) 330 writeIORef ref $! addToUFM symmap name (off, toHieName name) 331 put_ bh (fromIntegral off :: Word32) 332 333 where 334 notLocal :: HieName -> Bool 335 notLocal LocalName{} = False 336 notLocal _ = True 337 338 339-- ** Converting to and from `HieName`'s 340 341toHieName :: Name -> HieName 342toHieName name 343 | isKnownKeyName name = KnownKeyName (nameUnique name) 344 | isExternalName name = ExternalName (nameModule name) 345 (nameOccName name) 346 (nameSrcSpan name) 347 | otherwise = LocalName (nameOccName name) (nameSrcSpan name) 348 349fromHieName :: NameCache -> HieName -> (NameCache, Name) 350fromHieName nc (ExternalName mod occ span) = 351 let cache = nsNames nc 352 in case lookupOrigNameCache cache mod occ of 353 Just name 354 | nameSrcSpan name == span -> (nc, name) 355 | otherwise -> 356 let name' = setNameLoc name span 357 new_cache = extendNameCache cache mod occ name' 358 in ( nc{ nsNames = new_cache }, name' ) 359 Nothing -> 360 let (uniq, us) = takeUniqFromSupply (nsUniqs nc) 361 name = mkExternalName uniq mod occ span 362 new_cache = extendNameCache cache mod occ name 363 in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) 364fromHieName nc (LocalName occ span) = 365 let (uniq, us) = takeUniqFromSupply (nsUniqs nc) 366 name = mkInternalName uniq occ span 367 in ( nc{ nsUniqs = us }, name ) 368fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of 369 Nothing -> pprPanic "fromHieName:unknown known-key unique" 370 (ppr (unpkUnique u)) 371 Just n -> (nc, n) 372 373-- ** Reading and writing `HieName`'s 374 375putHieName :: BinHandle -> HieName -> IO () 376putHieName bh (ExternalName mod occ span) = do 377 putByte bh 0 378 put_ bh (mod, occ, span) 379putHieName bh (LocalName occName span) = do 380 putByte bh 1 381 put_ bh (occName, span) 382putHieName bh (KnownKeyName uniq) = do 383 putByte bh 2 384 put_ bh $ unpkUnique uniq 385 386getHieName :: BinHandle -> IO HieName 387getHieName bh = do 388 t <- getByte bh 389 case t of 390 0 -> do 391 (modu, occ, span) <- get bh 392 return $ ExternalName modu occ span 393 1 -> do 394 (occ, span) <- get bh 395 return $ LocalName occ span 396 2 -> do 397 (c,i) <- get bh 398 return $ KnownKeyName $ mkUnique c i 399 _ -> panic "HieBin.getHieName: invalid tag" 400