{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}

--
--  (c) The University of Glasgow 2002-2006
--

{-# OPTIONS_GHC -O2 #-}
-- 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(..),
        TraceBinIFaceReading(..),
        getWithUserData,
        putWithUserData

    ) where

#include "HsVersions.h"

import GhcPrelude

import TcRnMonad
import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
import IfaceEnv
import HscTypes
import Module
import Name
import DynFlags
import UniqFM
import UniqSupply
import Panic
import Binary
import SrcLoc
import ErrUtils
import FastMutInt
import Unique
import Outputable
import NameCache
import Platform
import FastString
import Constants
import Util

import Data.Array
import Data.Array.ST
import Data.Array.Unsafe
import Data.Bits
import Data.Char
import Data.Word
import Data.IORef
import Data.Foldable
import Control.Monad
import Control.Monad.ST
import Control.Monad.Trans.Class
import qualified Control.Monad.Trans.State.Strict as State

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

data CheckHiWay = CheckHiWay | IgnoreHiWay
    deriving CheckHiWay -> CheckHiWay -> Bool
(CheckHiWay -> CheckHiWay -> Bool)
-> (CheckHiWay -> CheckHiWay -> Bool) -> Eq CheckHiWay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckHiWay -> CheckHiWay -> Bool
$c/= :: CheckHiWay -> CheckHiWay -> Bool
== :: CheckHiWay -> CheckHiWay -> Bool
$c== :: CheckHiWay -> CheckHiWay -> Bool
Eq

data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
    deriving TraceBinIFaceReading -> TraceBinIFaceReading -> Bool
(TraceBinIFaceReading -> TraceBinIFaceReading -> Bool)
-> (TraceBinIFaceReading -> TraceBinIFaceReading -> Bool)
-> Eq TraceBinIFaceReading
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceBinIFaceReading -> TraceBinIFaceReading -> Bool
$c/= :: TraceBinIFaceReading -> TraceBinIFaceReading -> Bool
== :: TraceBinIFaceReading -> TraceBinIFaceReading -> Bool
$c== :: TraceBinIFaceReading -> TraceBinIFaceReading -> Bool
Eq

-- | Read an interface file
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
             -> TcRnIf a b ModIface
readBinIface :: CheckHiWay
-> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface
readBinIface checkHiWay :: CheckHiWay
checkHiWay traceBinIFaceReading :: TraceBinIFaceReading
traceBinIFaceReading hi_path :: FilePath
hi_path = do
    NameCacheUpdater
ncu <- TcRnIf a b NameCacheUpdater
forall a b. TcRnIf a b NameCacheUpdater
mkNameCacheUpdater
    DynFlags
dflags <- IOEnv (Env a b) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    IO ModIface -> TcRnIf a b ModIface
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModIface -> TcRnIf a b ModIface)
-> IO ModIface -> TcRnIf a b ModIface
forall a b. (a -> b) -> a -> b
$ DynFlags
-> CheckHiWay
-> TraceBinIFaceReading
-> FilePath
-> NameCacheUpdater
-> IO ModIface
readBinIface_ DynFlags
dflags CheckHiWay
checkHiWay TraceBinIFaceReading
traceBinIFaceReading FilePath
hi_path NameCacheUpdater
ncu

readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
              -> NameCacheUpdater
              -> IO ModIface
readBinIface_ :: DynFlags
-> CheckHiWay
-> TraceBinIFaceReading
-> FilePath
-> NameCacheUpdater
-> IO ModIface
readBinIface_ dflags :: DynFlags
dflags checkHiWay :: CheckHiWay
checkHiWay traceBinIFaceReading :: TraceBinIFaceReading
traceBinIFaceReading hi_path :: FilePath
hi_path ncu :: NameCacheUpdater
ncu = do
    let printer :: SDoc -> IO ()
        printer :: SDoc -> IO ()
printer = case TraceBinIFaceReading
traceBinIFaceReading of
                      TraceBinIFaceReading -> \sd :: SDoc
sd ->
                          DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
putLogMsg DynFlags
dflags
                                    WarnReason
NoReason
                                    Severity
SevOutput
                                    SrcSpan
noSrcSpan
                                    (DynFlags -> PprStyle
defaultDumpStyle DynFlags
dflags)
                                    SDoc
sd
                      QuietBinIFaceReading -> \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        wantedGot :: Outputable a => String -> a -> a -> IO ()
        wantedGot :: FilePath -> a -> a -> IO ()
wantedGot what :: FilePath
what wanted :: a
wanted got :: a
got =
            SDoc -> IO ()
printer (FilePath -> SDoc
text FilePath
what SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text ": " SDoc -> SDoc -> SDoc
<>
                     [SDoc] -> SDoc
vcat [FilePath -> SDoc
text "Wanted " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
wanted SDoc -> SDoc -> SDoc
<> FilePath -> SDoc
text ",",
                           FilePath -> SDoc
text "got    " SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
got])

        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
        errorOnMismatch :: FilePath -> a -> a -> IO ()
errorOnMismatch what :: FilePath
what wanted :: a
wanted got :: a
got =
            -- This will be caught by readIface which will emit an error
            -- msg containing the iface module name.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a
wanted a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
got) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcException -> IO ()
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO ()) -> GhcException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> GhcException
ProgramError
                         (FilePath
what FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ " (wanted " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
wanted
                               FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ", got "    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
got FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ")")
    BinHandle
bh <- FilePath -> IO BinHandle
Binary.readBinMem FilePath
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)
    Word32
magic <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    FilePath -> Word32 -> Word32 -> IO ()
forall a. Outputable a => FilePath -> a -> a -> IO ()
wantedGot "Magic" (DynFlags -> Word32
binaryInterfaceMagic DynFlags
dflags) Word32
magic
    FilePath -> Word32 -> Word32 -> IO ()
forall a. (Eq a, Show a) => FilePath -> a -> a -> IO ()
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
        (DynFlags -> Word32
binaryInterfaceMagic DynFlags
dflags) Word32
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.
    if DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4
        then do Word32
_ <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh :: IO Word32; () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do Word64
_ <- BinHandle -> IO Word64
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh :: IO Word64; () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Check the interface file version and ways.
    FilePath
check_ver  <- BinHandle -> IO FilePath
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    let our_ver :: FilePath
our_ver = Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
hiVersion
    FilePath -> FilePath -> FilePath -> IO ()
forall a. Outputable a => FilePath -> a -> a -> IO ()
wantedGot "Version" FilePath
our_ver FilePath
check_ver
    FilePath -> FilePath -> FilePath -> IO ()
forall a. (Eq a, Show a) => FilePath -> a -> a -> IO ()
errorOnMismatch "mismatched interface file versions" FilePath
our_ver FilePath
check_ver

    FilePath
check_way <- BinHandle -> IO FilePath
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    let way_descr :: FilePath
way_descr = DynFlags -> FilePath
getWayDescr DynFlags
dflags
    FilePath -> FilePath -> FilePath -> IO ()
forall a. Outputable a => FilePath -> a -> a -> IO ()
wantedGot "Way" FilePath
way_descr FilePath
check_way
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CheckHiWay
checkHiWay CheckHiWay -> CheckHiWay -> Bool
forall a. Eq a => a -> a -> Bool
== CheckHiWay
CheckHiWay) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> FilePath -> FilePath -> IO ()
forall a. (Eq a, Show a) => FilePath -> a -> a -> IO ()
errorOnMismatch "mismatched interface file ways" FilePath
way_descr FilePath
check_way
    NameCacheUpdater -> BinHandle -> IO ModIface
forall a. Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData NameCacheUpdater
ncu BinHandle
bh


-- | 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 :: NameCacheUpdater -> BinHandle -> IO a
getWithUserData ncu :: NameCacheUpdater
ncu bh :: BinHandle
bh = do
    -- Read the dictionary
    -- The next word in the file is a pointer to where the dictionary is
    -- (probably at the end of the file)
    Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh
    Bin Any
data_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- Remember where we are now
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p
    Dictionary
dict   <- BinHandle -> IO Dictionary
getDictionary BinHandle
bh
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p             -- Back to where we were before

    -- Initialise the user-data field of bh
    BinHandle
bh <- do
        BinHandle
bh <- BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (FilePath -> BinHandle -> IO Name
forall a. HasCallStack => FilePath -> a
error "getSymtabName")
                                                     (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)
        Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall a. Binary a => BinHandle -> IO a
Binary.get BinHandle
bh     -- Get the symtab ptr
        Bin Any
data_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- Remember where we are now
        BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p
        SymbolTable
symtab <- BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable BinHandle
bh NameCacheUpdater
ncu
        BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
data_p             -- Back to where we were before

        -- It is only now that we know how to get a Name
        BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> IO Name) -> (BinHandle -> IO FastString) -> UserData
newReadState (NameCacheUpdater
-> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCacheUpdater
ncu Dictionary
dict SymbolTable
symtab)
                                               (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)

    -- Read the interface file
    BinHandle -> IO a
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

-- | Write an interface file
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
writeBinIface dflags :: DynFlags
dflags hi_path :: FilePath
hi_path mod_iface :: ModIface
mod_iface = do
    BinHandle
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
    BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (DynFlags -> Word32
binaryInterfaceMagic DynFlags
dflags)

   -- dummy 32/64-bit field before the version/way for
   -- compatibility with older interface file formats.
   -- See Note [dummy iface field] above.
    if DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4
        then BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
Binary.put_ BinHandle
bh (0 :: Word32)
        else BinHandle -> Word64 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
Binary.put_ BinHandle
bh (0 :: Word64)

    -- The version and way descriptor go next
    BinHandle -> FilePath -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
hiVersion)
    let way_descr :: FilePath
way_descr = DynFlags -> FilePath
getWayDescr DynFlags
dflags
    BinHandle -> FilePath -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_  BinHandle
bh FilePath
way_descr


    (SDoc -> IO ()) -> BinHandle -> ModIface -> IO ()
forall a. Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
putWithUserData (DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags 3) BinHandle
bh ModIface
mod_iface
    -- And send the result to the file
    BinHandle -> FilePath -> IO ()
writeBinMem BinHandle
bh FilePath
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 :: (SDoc -> IO ()) -> BinHandle -> a -> IO ()
putWithUserData log_action :: SDoc -> IO ()
log_action bh :: BinHandle
bh payload :: a
payload = do
    -- Remember where the dictionary pointer will go
    Bin (Bin Any)
dict_p_p <- BinHandle -> IO (Bin (Bin Any))
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    -- Placeholder for ptr to dictionary
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
dict_p_p

    -- Remember where the symbol table pointer will go
    Bin (Bin Any)
symtab_p_p <- BinHandle -> IO (Bin (Bin Any))
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh
    BinHandle -> Bin (Bin Any) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Bin (Bin Any)
symtab_p_p
    -- Make some initial state
    FastMutInt
symtab_next <- IO FastMutInt
newFastMutInt
    FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
symtab_next 0
    IORef (UniqFM (Int, Name))
symtab_map <- UniqFM (Int, Name) -> IO (IORef (UniqFM (Int, Name)))
forall a. a -> IO (IORef a)
newIORef UniqFM (Int, Name)
forall elt. UniqFM elt
emptyUFM
    let bin_symtab :: BinSymbolTable
bin_symtab = $WBinSymbolTable :: FastMutInt -> IORef (UniqFM (Int, Name)) -> BinSymbolTable
BinSymbolTable {
                         bin_symtab_next :: FastMutInt
bin_symtab_next = FastMutInt
symtab_next,
                         bin_symtab_map :: IORef (UniqFM (Int, Name))
bin_symtab_map  = IORef (UniqFM (Int, Name))
symtab_map }
    FastMutInt
dict_next_ref <- IO FastMutInt
newFastMutInt
    FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
dict_next_ref 0
    IORef (UniqFM (Int, FastString))
dict_map_ref <- UniqFM (Int, FastString) -> IO (IORef (UniqFM (Int, FastString)))
forall a. a -> IO (IORef a)
newIORef UniqFM (Int, FastString)
forall elt. UniqFM elt
emptyUFM
    let bin_dict :: BinDictionary
bin_dict = $WBinDictionary :: FastMutInt -> IORef (UniqFM (Int, FastString)) -> BinDictionary
BinDictionary {
                       bin_dict_next :: FastMutInt
bin_dict_next = FastMutInt
dict_next_ref,
                       bin_dict_map :: IORef (UniqFM (Int, FastString))
bin_dict_map  = IORef (UniqFM (Int, FastString))
dict_map_ref }

    -- Put the main thing,
    BinHandle
bh <- BinHandle -> IO BinHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (BinHandle -> IO BinHandle) -> BinHandle -> IO BinHandle
forall a b. (a -> b) -> a -> b
$ BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh (UserData -> BinHandle) -> UserData -> BinHandle
forall a b. (a -> b) -> a -> b
$ (BinHandle -> Name -> IO ())
-> (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
-> UserData
newWriteState (BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinDictionary
bin_dict BinSymbolTable
bin_symtab)
                                                  (BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinDictionary
bin_dict BinSymbolTable
bin_symtab)
                                                  (BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary
bin_dict)
    BinHandle -> a -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh a
payload

    -- Write the symtab pointer at the front of the file
    Bin Any
symtab_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh        -- This is where the symtab will start
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
symtab_p_p Bin Any
symtab_p  -- Fill in the placeholder
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
symtab_p           -- Seek back to the end of the file

    -- Write the symbol table itself
    Int
symtab_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
    UniqFM (Int, Name)
symtab_map  <- IORef (UniqFM (Int, Name)) -> IO (UniqFM (Int, Name))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, Name))
symtab_map
    BinHandle -> Int -> UniqFM (Int, Name) -> IO ()
putSymbolTable BinHandle
bh Int
symtab_next UniqFM (Int, Name)
symtab_map
    SDoc -> IO ()
log_action (FilePath -> SDoc
text "writeBinIface:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
symtab_next
                                SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "Names")

    -- NB. write the dictionary after the symbol table, because
    -- writing the symbol table may create more dictionary entries.

    -- Write the dictionary pointer at the front of the file
    Bin Any
dict_p <- BinHandle -> IO (Bin Any)
forall k (a :: k). BinHandle -> IO (Bin a)
tellBin BinHandle
bh          -- This is where the dictionary will start
    BinHandle -> Bin (Bin Any) -> Bin Any -> IO ()
forall a. Binary a => BinHandle -> Bin a -> a -> IO ()
putAt BinHandle
bh Bin (Bin Any)
dict_p_p Bin Any
dict_p      -- Fill in the placeholder
    BinHandle -> Bin Any -> IO ()
forall k (a :: k). BinHandle -> Bin a -> IO ()
seekBin BinHandle
bh Bin Any
dict_p             -- Seek back to the end of the file

    -- Write the dictionary itself
    Int
dict_next <- FastMutInt -> IO Int
readFastMutInt FastMutInt
dict_next_ref
    UniqFM (Int, FastString)
dict_map  <- IORef (UniqFM (Int, FastString)) -> IO (UniqFM (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, FastString))
dict_map_ref
    BinHandle -> Int -> UniqFM (Int, FastString) -> IO ()
putDictionary BinHandle
bh Int
dict_next UniqFM (Int, FastString)
dict_map
    SDoc -> IO ()
log_action (FilePath -> SDoc
text "writeBinIface:" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
dict_next
                                SDoc -> SDoc -> SDoc
<+> FilePath -> SDoc
text "dict entries")



-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = 1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1024

binaryInterfaceMagic :: DynFlags -> Word32
binaryInterfaceMagic :: DynFlags -> Word32
binaryInterfaceMagic dflags :: DynFlags
dflags
 | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = 0x1face
 | Bool
otherwise                           = 0x1face64


-- -----------------------------------------------------------------------------
-- The symbol table
--

putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
putSymbolTable :: BinHandle -> Int -> UniqFM (Int, Name) -> IO ()
putSymbolTable bh :: BinHandle
bh next_off :: Int
next_off symtab :: UniqFM (Int, Name)
symtab = do
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
next_off
    let names :: [Name]
names = SymbolTable -> [Name]
forall i e. Array i e -> [e]
elems ((Int, Int) -> [(Int, Name)] -> SymbolTable
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (0,Int
next_offInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (UniqFM (Int, Name) -> [(Int, Name)]
forall elt. UniqFM elt -> [elt]
nonDetEltsUFM UniqFM (Int, Name)
symtab))
      -- It's OK to use nonDetEltsUFM here because the elements have
      -- indices that array uses to create order
    (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\n :: Name
n -> BinHandle -> Name -> UniqFM (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
n UniqFM (Int, Name)
symtab) [Name]
names

getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
getSymbolTable bh :: BinHandle
bh ncu :: NameCacheUpdater
ncu = do
    Int
sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    [OnDiskName]
od_names <- [IO OnDiskName] -> IO [OnDiskName]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> IO OnDiskName -> [IO OnDiskName]
forall a. Int -> a -> [a]
replicate Int
sz (BinHandle -> IO OnDiskName
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh))
    NameCacheUpdater -> forall c. (NameCache -> (NameCache, c)) -> IO c
updateNameCache NameCacheUpdater
ncu ((NameCache -> (NameCache, SymbolTable)) -> IO SymbolTable)
-> (NameCache -> (NameCache, SymbolTable)) -> IO SymbolTable
forall a b. (a -> b) -> a -> b
$ \namecache :: NameCache
namecache ->
        (forall s. ST s (NameCache, SymbolTable))
-> (NameCache, SymbolTable)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (NameCache, SymbolTable))
 -> (NameCache, SymbolTable))
-> (forall s. ST s (NameCache, SymbolTable))
-> (NameCache, SymbolTable)
forall a b. (a -> b) -> a -> b
$ (StateT NameCache (ST s) (NameCache, SymbolTable)
 -> NameCache -> ST s (NameCache, SymbolTable))
-> NameCache
-> StateT NameCache (ST s) (NameCache, SymbolTable)
-> ST s (NameCache, SymbolTable)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT NameCache (ST s) (NameCache, SymbolTable)
-> NameCache -> ST s (NameCache, SymbolTable)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
State.evalStateT NameCache
namecache (StateT NameCache (ST s) (NameCache, SymbolTable)
 -> ST s (NameCache, SymbolTable))
-> StateT NameCache (ST s) (NameCache, SymbolTable)
-> ST s (NameCache, SymbolTable)
forall a b. (a -> b) -> a -> b
$ do
            STArray s Int Name
mut_arr <- ST s (STArray s Int Name)
-> StateT NameCache (ST s) (STArray s Int Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (STArray s Int Name)
 -> StateT NameCache (ST s) (STArray s Int Name))
-> ST s (STArray s Int Name)
-> StateT NameCache (ST s) (STArray s Int Name)
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> ST s (STArray s Int Name)
forall s. (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ (0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
            [(Int, OnDiskName)]
-> ((Int, OnDiskName) -> StateT NameCache (ST s) ())
-> StateT NameCache (ST s) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Int] -> [OnDiskName] -> [(Int, OnDiskName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] [OnDiskName]
od_names) (((Int, OnDiskName) -> StateT NameCache (ST s) ())
 -> StateT NameCache (ST s) ())
-> ((Int, OnDiskName) -> StateT NameCache (ST s) ())
-> StateT NameCache (ST s) ()
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i, odn :: OnDiskName
odn) -> do
                (nc :: NameCache
nc, !Name
n) <- (NameCache -> (NameCache, Name))
-> StateT NameCache (ST s) (NameCache, Name)
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets ((NameCache -> (NameCache, Name))
 -> StateT NameCache (ST s) (NameCache, Name))
-> (NameCache -> (NameCache, Name))
-> StateT NameCache (ST s) (NameCache, Name)
forall a b. (a -> b) -> a -> b
$ \nc :: NameCache
nc -> NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName NameCache
nc OnDiskName
odn
                ST s () -> StateT NameCache (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT NameCache (ST s) ())
-> ST s () -> StateT NameCache (ST s) ()
forall a b. (a -> b) -> a -> b
$ STArray s Int Name -> Int -> Name -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Int Name
mut_arr Int
i Name
n
                NameCache -> StateT NameCache (ST s) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put NameCache
nc
            SymbolTable
arr <- ST s SymbolTable -> StateT NameCache (ST s) SymbolTable
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s SymbolTable -> StateT NameCache (ST s) SymbolTable)
-> ST s SymbolTable -> StateT NameCache (ST s) SymbolTable
forall a b. (a -> b) -> a -> b
$ STArray s Int Name -> ST s SymbolTable
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
unsafeFreeze STArray s Int Name
mut_arr
            NameCache
namecache' <- StateT NameCache (ST s) NameCache
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
            (NameCache, SymbolTable)
-> StateT NameCache (ST s) (NameCache, SymbolTable)
forall (m :: * -> *) a. Monad m => a -> m a
return (NameCache
namecache', SymbolTable
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_ :: (Int, Int) -> ST s (STArray s Int Name)
newSTArray_ = (Int, Int) -> ST s (STArray s Int Name)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_

type OnDiskName = (UnitId, ModuleName, OccName)

fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
fromOnDiskName nc :: NameCache
nc (pid :: UnitId
pid, mod_name :: ModuleName
mod_name, occ :: OccName
occ) =
    let mod :: Module
mod   = UnitId -> ModuleName -> Module
mkModule UnitId
pid ModuleName
mod_name
        cache :: OrigNameCache
cache = NameCache -> OrigNameCache
nsNames NameCache
nc
    in case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache  Module
mod OccName
occ of
           Just name :: Name
name -> (NameCache
nc, Name
name)
           Nothing   ->
               let (uniq :: Unique
uniq, us :: UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
                   name :: Name
name       = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
                   new_cache :: OrigNameCache
new_cache  = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache OrigNameCache
cache Module
mod OccName
occ Name
name
               in ( NameCache
nc{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us, nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name )

serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName :: BinHandle -> Name -> UniqFM (Int, Name) -> IO ()
serialiseName bh :: BinHandle
bh name :: Name
name _ = do
    let mod :: Module
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
    BinHandle -> OnDiskName -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Module -> UnitId
moduleUnitId Module
mod, Module -> ModuleName
moduleName Module
mod, Name -> OccName
nameOccName Name
name)


-- Note [Symbol table representation of names]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- An occurrence of a name in an interface file is serialized as a single 32-bit
-- word. The format of this word is:
--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
--   A normal name. x is an index into the symbol table
--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
--   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.
--
-- 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.


-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName _dict :: BinDictionary
_dict BinSymbolTable{
               bin_symtab_map :: BinSymbolTable -> IORef (UniqFM (Int, Name))
bin_symtab_map = IORef (UniqFM (Int, Name))
symtab_map_ref,
               bin_symtab_next :: BinSymbolTable -> FastMutInt
bin_symtab_next = FastMutInt
symtab_next }
        bh :: BinHandle
bh name :: Name
name
  | Name -> Bool
isKnownKeyName Name
name
  , let (c :: Char
c, u :: Int
u) = Unique -> (Char, Int)
unpkUnique (Name -> Unique
nameUnique Name
name) -- INVARIANT: (ord c) fits in 8 bits
  = -- ASSERT(u < 2^(22 :: Int))
    BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (0x80000000
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 22)
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u :: Word32))

  | Bool
otherwise
  = do UniqFM (Int, Name)
symtab_map <- IORef (UniqFM (Int, Name)) -> IO (UniqFM (Int, Name))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, Name))
symtab_map_ref
       case UniqFM (Int, Name) -> Name -> Maybe (Int, Name)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Int, Name)
symtab_map Name
name of
         Just (off :: Int
off,_) -> BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)
         Nothing -> do
            Int
off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
            -- MASSERT(off < 2^(30 :: Int))
            FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
symtab_next (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
            IORef (UniqFM (Int, Name)) -> UniqFM (Int, Name) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, Name))
symtab_map_ref
                (UniqFM (Int, Name) -> IO ()) -> UniqFM (Int, Name) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, Name) -> Name -> (Int, Name) -> UniqFM (Int, Name)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, Name)
symtab_map Name
name (Int
off,Name
name)
            BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off :: Word32)

-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
              -> Dictionary -> SymbolTable
              -> BinHandle -> IO Name
getSymtabName :: NameCacheUpdater
-> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName _ncu :: NameCacheUpdater
_ncu _dict :: Dictionary
_dict symtab :: SymbolTable
symtab bh :: BinHandle
bh = do
    Word32
i :: Word32 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    case Word32
i Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0xC0000000 of
      0x00000000 -> Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$! SymbolTable
symtab SymbolTable -> Int -> Name
forall i e. Ix i => Array i e -> i -> e
! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i

      0x80000000 ->
        let
          tag :: Char
tag = Int -> Char
chr (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word32
i Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. 0x3FC00000) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 22))
          ix :: Int
ix  = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x003FFFFF
          u :: Unique
u   = Char -> Int -> Unique
mkUnique Char
tag Int
ix
        in
          Name -> IO Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> IO Name) -> Name -> IO Name
forall a b. (a -> b) -> a -> b
$! case Unique -> Maybe Name
lookupKnownKeyName Unique
u of
                      Nothing -> FilePath -> SDoc -> Name
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "getSymtabName:unknown known-key unique"
                                          (Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
i SDoc -> SDoc -> SDoc
$$ (Char, Int) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unique -> (Char, Int)
unpkUnique Unique
u))
                      Just n :: Name
n  -> Name
n

      _ -> FilePath -> SDoc -> IO Name
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic "getSymtabName:unknown name tag" (Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
i)

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

putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString dict :: BinDictionary
dict bh :: BinHandle
bh fs :: FastString
fs = BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary
dict FastString
fs IO Word32 -> (Word32 -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BinHandle -> Word32 -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh

allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next :: BinDictionary -> FastMutInt
bin_dict_next = FastMutInt
j_r,
                                   bin_dict_map :: BinDictionary -> IORef (UniqFM (Int, FastString))
bin_dict_map  = IORef (UniqFM (Int, FastString))
out_r} f :: FastString
f = do
    UniqFM (Int, FastString)
out <- IORef (UniqFM (Int, FastString)) -> IO (UniqFM (Int, FastString))
forall a. IORef a -> IO a
readIORef IORef (UniqFM (Int, FastString))
out_r
    let uniq :: Unique
uniq = FastString -> Unique
forall a. Uniquable a => a -> Unique
getUnique FastString
f
    case UniqFM (Int, FastString) -> Unique -> Maybe (Int, FastString)
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM (Int, FastString)
out Unique
uniq of
        Just (j :: Int
j, _)  -> Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)
        Nothing -> do
           Int
j <- FastMutInt -> IO Int
readFastMutInt FastMutInt
j_r
           FastMutInt -> Int -> IO ()
writeFastMutInt FastMutInt
j_r (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
           IORef (UniqFM (Int, FastString))
-> UniqFM (Int, FastString) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (UniqFM (Int, FastString))
out_r (UniqFM (Int, FastString) -> IO ())
-> UniqFM (Int, FastString) -> IO ()
forall a b. (a -> b) -> a -> b
$! UniqFM (Int, FastString)
-> Unique -> (Int, FastString) -> UniqFM (Int, FastString)
forall key elt.
Uniquable key =>
UniqFM elt -> key -> elt -> UniqFM elt
addToUFM UniqFM (Int, FastString)
out Unique
uniq (Int
j, FastString
f)
           Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j :: Word32)

getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString dict :: Dictionary
dict bh :: BinHandle
bh = do
    Word32
j <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    FastString -> IO FastString
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> IO FastString) -> FastString -> IO FastString
forall a b. (a -> b) -> a -> b
$! (Dictionary
dict Dictionary -> Int -> FastString
forall i e. Ix i => Array i e -> i -> e
! Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
j :: Word32))

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

getWayDescr :: DynFlags -> String
getWayDescr :: DynFlags -> FilePath
getWayDescr dflags :: DynFlags
dflags
  | Platform -> Bool
platformUnregisterised (DynFlags -> Platform
targetPlatform DynFlags
dflags) = 'u'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
tag
  | Bool
otherwise                                      =     FilePath
tag
  where tag :: FilePath
tag = DynFlags -> FilePath
buildTag DynFlags
dflags
        -- if this is an unregisterised build, make sure our interfaces
        -- can't be used by a registerised build.