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