BinIface.hs 15.5 KB
Newer Older
1
{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
2

3
--
4
--  (c) The University of Glasgow 2002-2006
5
--
6

7
{-# OPTIONS_GHC -O2 #-}
dterei's avatar
dterei committed
8 9 10 11 12 13 14 15 16 17
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected

-- | Binary interface file support.
module BinIface (
        writeBinIface,
        readBinIface,
        getSymtabName,
        getDictFastString,
        CheckHiWay(..),
18 19 20 21
        TraceBinIFaceReading(..),
        getWithUserData,
        putWithUserData

dterei's avatar
dterei committed
22
    ) where
23 24 25

#include "HsVersions.h"

26 27
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
28
import TcRnMonad
29
import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
30
import IfaceEnv
31
import HscTypes
Simon Marlow's avatar
Simon Marlow committed
32
import Module
33
import Name
Simon Marlow's avatar
Simon Marlow committed
34 35 36
import DynFlags
import UniqFM
import UniqSupply
37 38
import Panic
import Binary
Simon Marlow's avatar
Simon Marlow committed
39 40 41
import SrcLoc
import ErrUtils
import FastMutInt
42
import Unique
43
import Outputable
44
import NameCache
Ian Lynagh's avatar
Ian Lynagh committed
45
import Platform
46
import FastString
47
import Constants
48
import Util
49

50 51 52
import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
53 54
import Data.Bits
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
55 56
import Data.Word
import Data.IORef
57
import Data.Foldable
Simon Marlow's avatar
Simon Marlow committed
58
import Control.Monad
59 60 61
import Control.Monad.ST
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.State.Strict as State
dterei's avatar
dterei committed
62 63 64 65 66

-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
--

Ian Lynagh's avatar
Ian Lynagh committed
67 68 69
data CheckHiWay = CheckHiWay | IgnoreHiWay
    deriving Eq

70 71 72
data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
    deriving Eq

dterei's avatar
dterei committed
73
-- | Read an interface file
74 75 76
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
             -> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
dterei's avatar
dterei committed
77
    ncu <- mkNameCacheUpdater
78
    dflags <- getDynFlags
dterei's avatar
dterei committed
79
    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
80

81
readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
82
              -> NameCacheUpdater
83
              -> IO ModIface
84
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
dterei's avatar
dterei committed
85 86
    let printer :: SDoc -> IO ()
        printer = case traceBinIFaceReading of
87
                      TraceBinIFaceReading -> \sd ->
Ben Gamari's avatar
Ben Gamari committed
88 89 90 91 92 93
                          putLogMsg dflags
                                    NoReason
                                    SevOutput
                                    noSrcSpan
                                    (defaultDumpStyle dflags)
                                    sd
dterei's avatar
dterei committed
94 95 96 97
                      QuietBinIFaceReading -> \_ -> return ()
        wantedGot :: Outputable a => String -> a -> a -> IO ()
        wantedGot what wanted got =
            printer (text what <> text ": " <>
98 99
                     vcat [text "Wanted " <> ppr wanted <> text ",",
                           text "got    " <> ppr got])
100

dterei's avatar
dterei committed
101 102
        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
        errorOnMismatch what wanted got =
103 104
            -- This will be caught by readIface which will emit an error
            -- msg containing the iface module name.
105
            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
dterei's avatar
dterei committed
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
                         (what ++ " (wanted " ++ show wanted
                               ++ ", got "    ++ show got ++ ")")
    bh <- Binary.readBinMem hi_path

    -- Read the magic number to check that this really is a GHC .hi file
    -- (This magic number does not change when we change
    --  GHC interface file format)
    magic <- get bh
    wantedGot "Magic" (binaryInterfaceMagic dflags) magic
    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
        (binaryInterfaceMagic dflags) magic

    -- Note [dummy iface field]
    -- read a dummy 32/64 bit value.  This field used to hold the
    -- dictionary pointer in old interface file formats, but now
    -- the dictionary pointer is after the version (where it
    -- should be).  Also, the serialisation of value of type "Bin
    -- a" used to depend on the word size of the machine, now they
    -- are always 32 bits.
125
    if wORD_SIZE dflags == 4
dterei's avatar
dterei committed
126 127 128 129 130
        then do _ <- Binary.get bh :: IO Word32; return ()
        else do _ <- Binary.get bh :: IO Word64; return ()

    -- Check the interface file version and ways.
    check_ver  <- get bh
Ian Lynagh's avatar
Ian Lynagh committed
131
    let our_ver = show hiVersion
dterei's avatar
dterei committed
132 133 134 135 136 137 138 139
    wantedGot "Version" our_ver check_ver
    errorOnMismatch "mismatched interface file versions" our_ver check_ver

    check_way <- get bh
    let way_descr = getWayDescr dflags
    wantedGot "Way" way_descr check_way
    when (checkHiWay == CheckHiWay) $
        errorOnMismatch "mismatched interface file ways" way_descr check_way
140 141
    getWithUserData ncu bh

dterei's avatar
dterei committed
142

143 144 145 146 147
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData ncu bh = do
dterei's avatar
dterei committed
148 149 150 151
    -- Read the dictionary
    -- The next word in the file is a pointer to where the dictionary is
    -- (probably at the end of the file)
    dict_p <- Binary.get bh
152
    data_p <- tellBin bh          -- Remember where we are now
dterei's avatar
dterei committed
153 154
    seekBin bh dict_p
    dict   <- getDictionary bh
155 156
    seekBin bh data_p             -- Back to where we were before

dterei's avatar
dterei committed
157 158 159 160 161 162 163 164 165
    -- Initialise the user-data field of bh
    bh <- do
        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
                                                     (getDictFastString dict)
        symtab_p <- Binary.get bh     -- Get the symtab ptr
        data_p <- tellBin bh          -- Remember where we are now
        seekBin bh symtab_p
        symtab <- getSymbolTable bh ncu
        seekBin bh data_p             -- Back to where we were before
166

dterei's avatar
dterei committed
167 168 169
        -- It is only now that we know how to get a Name
        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
                                               (getDictFastString dict)
170

dterei's avatar
dterei committed
171 172
    -- Read the interface file
    get bh
173

dterei's avatar
dterei committed
174
-- | Write an interface file
175 176
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface dflags hi_path mod_iface = do
dterei's avatar
dterei committed
177 178 179 180 181 182
    bh <- openBinMem initBinMemSize
    put_ bh (binaryInterfaceMagic dflags)

   -- dummy 32/64-bit field before the version/way for
   -- compatibility with older interface file formats.
   -- See Note [dummy iface field] above.
183
    if wORD_SIZE dflags == 4
dterei's avatar
dterei committed
184 185 186 187
        then Binary.put_ bh (0 :: Word32)
        else Binary.put_ bh (0 :: Word64)

    -- The version and way descriptor go next
Ian Lynagh's avatar
Ian Lynagh committed
188
    put_ bh (show hiVersion)
dterei's avatar
dterei committed
189 190 191
    let way_descr = getWayDescr dflags
    put_  bh way_descr

192 193 194 195 196 197 198 199 200 201 202

    putWithUserData (debugTraceMsg dflags 3) bh mod_iface
    -- And send the result to the file
    writeBinMem bh hi_path

-- | Put a piece of data with an initialised `UserData` field. This
-- is necessary if you want to serialise Names or FastStrings.
-- It also writes a symbol table and the dictionary.
-- This segment should be read using `getWithUserData`.
putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
putWithUserData log_action bh payload = do
dterei's avatar
dterei committed
203 204 205 206 207 208 209 210
    -- Remember where the dictionary pointer will go
    dict_p_p <- tellBin bh
    -- Placeholder for ptr to dictionary
    put_ bh dict_p_p

    -- Remember where the symbol table pointer will go
    symtab_p_p <- tellBin bh
    put_ bh symtab_p_p
211
    -- Make some initial state
dterei's avatar
dterei committed
212 213 214 215 216 217 218 219 220 221 222 223
    symtab_next <- newFastMutInt
    writeFastMutInt symtab_next 0
    symtab_map <- newIORef emptyUFM
    let bin_symtab = BinSymbolTable {
                         bin_symtab_next = symtab_next,
                         bin_symtab_map  = symtab_map }
    dict_next_ref <- newFastMutInt
    writeFastMutInt dict_next_ref 0
    dict_map_ref <- newIORef emptyUFM
    let bin_dict = BinDictionary {
                       bin_dict_next = dict_next_ref,
                       bin_dict_map  = dict_map_ref }
224 225

    -- Put the main thing,
dterei's avatar
dterei committed
226
    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
227
                                                  (putName bin_dict bin_symtab)
dterei's avatar
dterei committed
228
                                                  (putFastString bin_dict)
229
    put_ bh payload
dterei's avatar
dterei committed
230

231
    -- Write the symtab pointer at the front of the file
dterei's avatar
dterei committed
232 233 234 235 236 237 238 239
    symtab_p <- tellBin bh        -- This is where the symtab will start
    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
    seekBin bh symtab_p           -- Seek back to the end of the file

    -- Write the symbol table itself
    symtab_next <- readFastMutInt symtab_next
    symtab_map  <- readIORef symtab_map
    putSymbolTable bh symtab_next symtab_map
240
    log_action (text "writeBinIface:" <+> int symtab_next
241 242
                                <+> text "Names")

dterei's avatar
dterei committed
243 244
    -- NB. write the dictionary after the symbol table, because
    -- writing the symbol table may create more dictionary entries.
245

Gabor Greif's avatar
Gabor Greif committed
246
    -- Write the dictionary pointer at the front of the file
dterei's avatar
dterei committed
247 248 249
    dict_p <- tellBin bh          -- This is where the dictionary will start
    putAt bh dict_p_p dict_p      -- Fill in the placeholder
    seekBin bh dict_p             -- Seek back to the end of the file
250

dterei's avatar
dterei committed
251 252 253 254
    -- Write the dictionary itself
    dict_next <- readFastMutInt dict_next_ref
    dict_map  <- readIORef dict_map_ref
    putDictionary bh dict_next dict_map
255
    log_action (text "writeBinIface:" <+> int dict_next
dterei's avatar
dterei committed
256
                                <+> text "dict entries")
257

258

259

dterei's avatar
dterei committed
260
-- | Initial ram buffer to allocate for writing interface files
Ian Lynagh's avatar
Ian Lynagh committed
261 262
initBinMemSize :: Int
initBinMemSize = 1024 * 1024
263

Ian Lynagh's avatar
Ian Lynagh committed
264 265 266 267
binaryInterfaceMagic :: DynFlags -> Word32
binaryInterfaceMagic dflags
 | target32Bit (targetPlatform dflags) = 0x1face
 | otherwise                           = 0x1face64
268

dterei's avatar
dterei committed
269

270 271
-- -----------------------------------------------------------------------------
-- The symbol table
dterei's avatar
dterei committed
272
--
273 274 275

putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable bh next_off symtab = do
dterei's avatar
dterei committed
276
    put_ bh next_off
niteria's avatar
niteria committed
277 278 279
    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
      -- It's OK to use nonDetEltsUFM here because the elements have
      -- indices that array uses to create order
dterei's avatar
dterei committed
280
    mapM_ (\n -> serialiseName bh n symtab) names
281

dterei's avatar
dterei committed
282
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
283
getSymbolTable bh ncu = do
dterei's avatar
dterei committed
284 285 286
    sz <- get bh
    od_names <- sequence (replicate sz (get bh))
    updateNameCache ncu $ \namecache ->
287 288 289 290 291 292 293 294 295 296 297 298 299
        runST $ flip State.evalStateT namecache $ do
            mut_arr <- lift $ newSTArray_ (0, sz-1)
            for_ (zip [0..] od_names) $ \(i, odn) -> do
                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
                lift $ writeArray mut_arr i n
                State.put nc
            arr <- lift $ unsafeFreeze mut_arr
            namecache' <- State.get
            return (namecache', arr)
  where
    -- This binding is required because the type of newArray_ cannot be inferred
    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
    newSTArray_ = newArray_
300

301
type OnDiskName = (UnitId, ModuleName, OccName)
302

303 304
fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName nc (pid, mod_name, occ) =
dterei's avatar
dterei committed
305
    let mod   = mkModule pid mod_name
306
        cache = nsNames nc
307
    in case lookupOrigNameCache cache  mod occ of
dterei's avatar
dterei committed
308 309 310 311 312 313
           Just name -> (nc, name)
           Nothing   ->
               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
                   name       = mkExternalName uniq mod occ noSrcSpan
                   new_cache  = extendNameCache cache mod occ name
               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
314 315

serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
316
serialiseName bh name _ = do
dterei's avatar
dterei committed
317
    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
318
    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
319

320

321 322 323
-- Note [Symbol table representation of names]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
324 325
-- An occurrence of a name in an interface file is serialized as a single 32-bit
-- word. The format of this word is:
326
--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
327
--   A normal name. x is an index into the symbol table
328
--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
329 330 331
--   A known-key name. x is the Unique's Char, y is the int part. We assume that
--   all known-key uniques fit in this space. This is asserted by
--   PrelInfo.knownKeyNamesOkay.
332
--
333 334 335
-- During serialization we check for known-key things using isKnownKeyName.
-- During deserialization we use lookupKnownKeyName to get from the unique back
-- to its corresponding Name.
336 337 338 339


-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
340
putName _dict BinSymbolTable{
341
               bin_symtab_map = symtab_map_ref,
342 343 344
               bin_symtab_next = symtab_next }
        bh name
  | isKnownKeyName name
345 346
  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
  = -- ASSERT(u < 2^(22 :: Int))
347 348 349 350
    put_ bh (0x80000000
             .|. (fromIntegral (ord c) `shiftL` 22)
             .|. (fromIntegral u :: Word32))

351
  | otherwise
352
  = do symtab_map <- readIORef symtab_map_ref
353 354 355 356 357 358 359 360 361 362 363 364 365 366
       case lookupUFM symtab_map name of
         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
         Nothing -> do
            off <- readFastMutInt symtab_next
            -- MASSERT(off < 2^(30 :: Int))
            writeFastMutInt symtab_next (off+1)
            writeIORef symtab_map_ref
                $! addToUFM symtab_map name (off,name)
            put_ bh (fromIntegral off :: Word32)

-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
              -> Dictionary -> SymbolTable
              -> BinHandle -> IO Name
367
getSymtabName _ncu _dict symtab bh = do
368
    i :: Word32 <- get bh
369
    case i .&. 0xC0000000 of
370 371
      0x00000000 -> return $! symtab ! fromIntegral i

372
      0x80000000 ->
373 374 375
        let
          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
          ix  = fromIntegral i .&. 0x003FFFFF
376
          u   = mkUnique tag ix
377
        in
378 379 380
          return $! case lookupKnownKeyName u of
                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
                                          (ppr i $$ ppr (unpkUnique u))
381 382 383
                      Just n  -> n

      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
384 385 386 387 388 389 390 391

data BinSymbolTable = BinSymbolTable {
        bin_symtab_next :: !FastMutInt, -- The next index to use
        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
                                -- indexed by Name
  }

putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
392 393 394 395 396
putFastString dict bh fs = allocateFastString dict fs >>= put_ bh

allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
                                   bin_dict_map  = out_r} f = do
397 398 399
    out <- readIORef out_r
    let uniq = getUnique f
    case lookupUFM out uniq of
400
        Just (j, _)  -> return (fromIntegral j :: Word32)
401 402 403 404
        Nothing -> do
           j <- readFastMutInt j_r
           writeFastMutInt j_r (j + 1)
           writeIORef out_r $! addToUFM out uniq (j, f)
405
           return (fromIntegral j :: Word32)
406

407 408 409 410
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString dict bh = do
    j <- get bh
    return $! (dict ! fromIntegral (j :: Word32))
411 412 413 414 415 416 417

data BinDictionary = BinDictionary {
        bin_dict_next :: !FastMutInt, -- The next index to use
        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
                                -- indexed by FastString
  }

418 419
getWayDescr :: DynFlags -> String
getWayDescr dflags
420 421
  | platformUnregisterised (targetPlatform dflags) = 'u':tag
  | otherwise                                      =     tag
422
  where tag = buildTag dflags
dterei's avatar
dterei committed
423 424
        -- if this is an unregisterised build, make sure our interfaces
        -- can't be used by a registerised build.