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