{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}

--
--  (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 GHC.Iface.Binary (
        -- * Public API for interface file serialisation
        writeBinIface,
        readBinIface,
        readBinIfaceHeader,
        getSymtabName,
        CheckHiWay(..),
        TraceBinIFace(..),
        getWithUserData,
        putWithUserData,

        -- * Internal serialisation functions
        getSymbolTable,
        putName,
        putSymbolTable,
        BinSymbolTable(..),
    ) where

import GHC.Prelude

import GHC.Tc.Utils.Monad
import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )
import GHC.Unit
import GHC.Unit.Module.ModIface
import GHC.Types.Name
import GHC.Platform.Profile
import GHC.Types.Unique.FM
import GHC.Utils.Panic
import GHC.Utils.Binary as Binary
import GHC.Data.FastMutInt
import GHC.Types.Unique
import GHC.Utils.Outputable
import GHC.Types.Name.Cache
import GHC.Types.SrcLoc
import GHC.Platform
import GHC.Settings.Constants
import GHC.Utils.Fingerprint

import Data.Array
import Data.Array.IO
import Data.Array.Unsafe
import Data.Char
import Data.Word
import Data.IORef
import Control.Monad

-- ---------------------------------------------------------------------------
-- 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
$c== :: CheckHiWay -> CheckHiWay -> Bool
== :: CheckHiWay -> CheckHiWay -> Bool
$c/= :: CheckHiWay -> CheckHiWay -> Bool
/= :: CheckHiWay -> CheckHiWay -> Bool
Eq

data TraceBinIFace
   = TraceBinIFace (SDoc -> IO ())
   | QuietBinIFace

-- | Read an interface file header, checking the magic number, version, and
-- way. Returns the hash of the source file and a BinHandle which points at the
-- start of the rest of the interface file data.
readBinIfaceHeader
  :: Profile
  -> NameCache
  -> CheckHiWay
  -> TraceBinIFace
  -> FilePath
  -> IO (Fingerprint, BinHandle)
readBinIfaceHeader :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, BinHandle)
readBinIfaceHeader Profile
profile NameCache
_name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIFace String
hi_path = do
    let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile

        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
        wantedGot :: forall a. String -> a -> a -> (a -> SDoc) -> IO ()
wantedGot String
what a
wanted a
got a -> SDoc
ppr' =
            case TraceBinIFace
traceBinIFace of
               TraceBinIFace
QuietBinIFace         -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               TraceBinIFace SDoc -> IO ()
printer -> SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                     [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Wanted " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
ppr' a
wanted SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
",",
                           String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"got    " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
ppr' a
got]

        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
        errorOnMismatch :: forall a. (Eq a, Show a) => String -> a -> a -> IO ()
errorOnMismatch String
what a
wanted 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
$ String -> GhcException
ProgramError
                         (String
what String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (wanted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
wanted
                               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", got "    String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
got String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
    bh <- String -> IO BinHandle
Binary.readBinMem String
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 platform) magic (ppr . unFixedLength)
    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
        (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)

    -- Check the interface file version and profile tag.
    check_ver  <- get bh
    let our_ver = Integer -> String
forall a. Show a => a -> String
show Integer
hiVersion
    wantedGot "Version" our_ver check_ver text
    errorOnMismatch "mismatched interface file versions" our_ver check_ver

    check_tag <- get bh
    let tag = Profile -> String
profileBuildTag Profile
profile
    wantedGot "Way" tag check_tag text
    when (checkHiWay == CheckHiWay) $
        errorOnMismatch "mismatched interface file profile tag" tag check_tag

    src_hash <- get bh
    pure (src_hash, bh)

-- | Read an interface file.
readBinIface
  :: Profile
  -> NameCache
  -> CheckHiWay
  -> TraceBinIFace
  -> FilePath
  -> IO ModIface
readBinIface :: Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO ModIface
readBinIface Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path = do
    (src_hash, bh) <- Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> String
-> IO (Fingerprint, BinHandle)
readBinIfaceHeader Profile
profile NameCache
name_cache CheckHiWay
checkHiWay TraceBinIFace
traceBinIface String
hi_path

    extFields_p <- get bh

    mod_iface <- getWithUserData name_cache bh

    seekBin bh extFields_p
    extFields <- get bh

    return mod_iface
      { mi_ext_fields = extFields
      , mi_src_hash = src_hash
      }

-- | 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 => NameCache -> BinHandle -> IO a
getWithUserData :: forall a. Binary a => NameCache -> BinHandle -> IO a
getWithUserData NameCache
name_cache BinHandle
bh = do
  bh <- NameCache -> BinHandle -> IO BinHandle
getTables NameCache
name_cache BinHandle
bh
  get bh

-- | Setup a BinHandle to read something written using putWithTables
--
-- Reading names has the side effect of adding them into the given NameCache.
getTables :: NameCache -> BinHandle -> IO BinHandle
getTables :: NameCache -> BinHandle -> IO BinHandle
getTables NameCache
name_cache 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)
    dict <- BinHandle -> IO Dictionary -> IO Dictionary
forall a. BinHandle -> IO a -> IO a
Binary.forwardGet BinHandle
bh (BinHandle -> IO Dictionary
getDictionary BinHandle
bh)

    -- Initialise the user-data field of bh
    let bh_fs = 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 (String -> BinHandle -> IO Name
forall a. HasCallStack => String -> a
error String
"getSymtabName")
                                              (Dictionary -> BinHandle -> IO FastString
getDictFastString Dictionary
dict)

    symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)

    -- It is only now that we know how to get a Name
    return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
                                           (getDictFastString dict)

-- | Write an interface file
writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
writeBinIface :: Profile -> TraceBinIFace -> String -> ModIface -> IO ()
writeBinIface Profile
profile TraceBinIFace
traceBinIface String
hi_path ModIface
mod_iface = do
    bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize
    let platform = Profile -> Platform
profilePlatform Profile
profile
    put_ bh (binaryInterfaceMagic platform)

    -- The version, profile tag, and source hash go next
    put_ bh (show hiVersion)
    let tag = Profile -> String
profileBuildTag Profile
profile
    put_  bh tag
    put_  bh (mi_src_hash mod_iface)

    extFields_p_p <- tellBin bh
    put_ bh extFields_p_p

    putWithUserData traceBinIface bh mod_iface

    extFields_p <- tellBin bh
    putAt bh extFields_p_p extFields_p
    seekBin bh extFields_p
    put_ bh (mi_ext_fields 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 => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData :: forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData TraceBinIFace
traceBinIface BinHandle
bh a
payload = do
  (name_count, fs_count, _b) <- BinHandle -> (BinHandle -> IO (Bin a)) -> IO (Int, Int, Bin a)
forall b. BinHandle -> (BinHandle -> IO b) -> IO (Int, Int, b)
putWithTables BinHandle
bh (\BinHandle
bh' -> BinHandle -> a -> IO (Bin a)
forall a. Binary a => BinHandle -> a -> IO (Bin a)
put BinHandle
bh' a
payload)

  case traceBinIface of
    TraceBinIFace
QuietBinIFace         -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TraceBinIFace SDoc -> IO ()
printer -> do
       SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
name_count
                                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Names")
       SDoc -> IO ()
printer (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"writeBinIface:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
fs_count
                                      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dict entries")

-- | Write name/symbol tables
--
-- 1. setup the given BinHandle with Name/FastString table handling
-- 2. write the following
--    - FastString table pointer
--    - Name table pointer
--    - payload
--    - Name table
--    - FastString table
--
-- It returns (number of names, number of FastStrings, payload write result)
--
putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
putWithTables :: forall b. BinHandle -> (BinHandle -> IO b) -> IO (Int, Int, b)
putWithTables BinHandle
bh BinHandle -> IO b
put_payload = do
    -- initialize state for the name table and the FastString table.
    symtab_next <- Int -> IO FastMutInt
newFastMutInt Int
0
    symtab_map <- newIORef emptyUFM
    let bin_symtab = BinSymbolTable
                      { bin_symtab_next :: FastMutInt
bin_symtab_next = FastMutInt
symtab_next
                      , bin_symtab_map :: IORef (UniqFM Name (Int, Name))
bin_symtab_map  = IORef (UniqFM Name (Int, Name))
symtab_map
                      }

    (bh_fs, bin_dict, put_dict) <- initFSTable bh

    (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do

      -- NB. write the dictionary after the symbol table, because
      -- writing the symbol table may create more dictionary entries.
      let put_symtab = do
            name_count <- FastMutInt -> IO Int
readFastMutInt FastMutInt
symtab_next
            symtab_map  <- readIORef symtab_map
            putSymbolTable bh_fs name_count symtab_map
            pure name_count

      forwardPut bh_fs (const put_symtab) $ do

        -- BinHandle with FastString and Name writing support
        let ud_fs = BinHandle -> UserData
getUserData BinHandle
bh_fs
        let ud_name = UserData
ud_fs
                        { ud_put_nonbinding_name = putName bin_dict bin_symtab
                        , ud_put_binding_name    = putName bin_dict bin_symtab
                        }
        let bh_name = BinHandle -> UserData -> BinHandle
setUserData BinHandle
bh UserData
ud_name

        put_payload bh_name

    return (name_count, fs_count, r)



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

binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
binaryInterfaceMagic Platform
platform
 | Platform -> Bool
target32Bit Platform
platform = Word32 -> FixedLengthEncoding Word32
forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face
 | Bool
otherwise            = Word32 -> FixedLengthEncoding Word32
forall a. a -> FixedLengthEncoding a
FixedLengthEncoding Word32
0x1face64


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

putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int, Name) -> IO ()
putSymbolTable BinHandle
bh Int
name_count UniqFM Name (Int, Name)
symtab = do
    BinHandle -> Int -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Int
name_count
    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 (Int
0,Int
name_countInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (UniqFM Name (Int, Name) -> [(Int, Name)]
forall {k} (key :: k) elt. UniqFM key elt -> [elt]
nonDetEltsUFM UniqFM Name (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_ (\Name
n -> BinHandle -> Name -> UniqFM Name (Int, Name) -> IO ()
forall {k} (key :: k).
BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
n UniqFM Name (Int, Name)
symtab) [Name]
names


getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
getSymbolTable BinHandle
bh NameCache
name_cache = do
    sz <- BinHandle -> IO Int
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh :: IO Int
    -- create an array of Names for the symbols and add them to the NameCache
    updateNameCache' name_cache $ \OrigNameCache
cache0 -> do
        mut_arr <- (Int, Int) -> IO (IOArray Int Name)
forall i. Ix i => (i, i) -> IO (IOArray i Name)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
0, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) :: IO (IOArray Int Name)
        cache <- foldGet' (fromIntegral sz) bh cache0 $ \Word
i (Unit
uid, ModuleName
mod_name, OccName
occ) OrigNameCache
cache -> do
          let mod :: GenModule Unit
mod = Unit -> ModuleName -> GenModule Unit
forall u. u -> ModuleName -> GenModule u
mkModule Unit
uid ModuleName
mod_name
          case OrigNameCache -> GenModule Unit -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ of
            Just Name
name -> do
              IOArray Int Name -> Int -> Name -> IO ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray IOArray Int Name
mut_arr (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) Name
name
              OrigNameCache -> IO OrigNameCache
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return OrigNameCache
cache
            Maybe Name
Nothing   -> do
              uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
              let name      = Unique -> GenModule Unit -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq GenModule Unit
mod OccName
occ SrcSpan
noSrcSpan
                  new_cache = OrigNameCache -> GenModule Unit -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache GenModule Unit
mod OccName
occ Name
name
              writeArray mut_arr (fromIntegral i) name
              return new_cache
        arr <- unsafeFreeze mut_arr
        return (cache, arr)

serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
serialiseName :: forall {k} (key :: k).
BinHandle -> Name -> UniqFM key (Int, Name) -> IO ()
serialiseName BinHandle
bh Name
name UniqFM key (Int, Name)
_ = do
    let mod :: GenModule Unit
mod = Bool -> SDoc -> GenModule Unit -> GenModule Unit
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (HasDebugCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
name)
    BinHandle -> (Unit, ModuleName, OccName) -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh (GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
mod, GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule Unit
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
--   GHC.Builtin.Utils.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 :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName FSTable
_dict BinSymbolTable{
               bin_symtab_map :: BinSymbolTable -> IORef (UniqFM Name (Int, Name))
bin_symtab_map = IORef (UniqFM Name (Int, Name))
symtab_map_ref,
               bin_symtab_next :: BinSymbolTable -> FastMutInt
bin_symtab_next = FastMutInt
symtab_next }
        BinHandle
bh Name
name
  | Name -> Bool
isKnownKeyName Name
name
  , let (Char
c, Word64
u) = Unique -> (Char, Word64)
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 (Word32
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` Int
22)
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
u :: Word32))

  | Bool
otherwise
  = do symtab_map <- IORef (UniqFM Name (Int, Name)) -> IO (UniqFM Name (Int, Name))
forall a. IORef a -> IO a
readIORef IORef (UniqFM Name (Int, Name))
symtab_map_ref
       case lookupUFM symtab_map name of
         Just (Int
off,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)
         Maybe (Int, Name)
Nothing -> do
            off <- FastMutInt -> IO Int
readFastMutInt FastMutInt
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 :: NameCache
              -> Dictionary -> SymbolTable
              -> BinHandle -> IO Name
getSymtabName :: NameCache -> Dictionary -> SymbolTable -> BinHandle -> IO Name
getSymtabName NameCache
_name_cache Dictionary
_dict SymbolTable
symtab BinHandle
bh = do
    i :: Word32 <- BinHandle -> IO Word32
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
    case i .&. 0xC0000000 of
      Word32
0x00000000 -> Name -> IO Name
forall a. a -> IO a
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

      Word32
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
.&. Word32
0x3FC00000) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
22))
          ix :: Word64
ix  = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x003FFFFF
          u :: Unique
u   = Char -> Word64 -> Unique
mkUnique Char
tag Word64
ix
        in
          Name -> IO Name
forall a. a -> IO a
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
                      Maybe Name
Nothing -> String -> SDoc -> Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getSymtabName:unknown known-key unique"
                                          (Word32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word32
i SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
tag SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Word64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word64
ix)
                      Just Name
n  -> Name
n

      Word32
_ -> String -> SDoc -> IO Name
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 Name (Int, Name))
bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
                                -- indexed by Name
  }