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