never executed always true always false
    1 {-# LANGUAGE BinaryLiterals, 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.
   12 module GHC.Iface.Binary (
   13         -- * Public API for interface file serialisation
   14         writeBinIface,
   15         readBinIface,
   16         readBinIfaceHeader,
   17         getSymtabName,
   18         getDictFastString,
   19         CheckHiWay(..),
   20         TraceBinIFace(..),
   21         getWithUserData,
   22         putWithUserData,
   23 
   24         -- * Internal serialisation functions
   25         getSymbolTable,
   26         putName,
   27         putDictionary,
   28         putFastString,
   29         putSymbolTable,
   30         BinSymbolTable(..),
   31         BinDictionary(..)
   32     ) where
   33 
   34 import GHC.Prelude
   35 
   36 import GHC.Tc.Utils.Monad
   37 import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )
   38 import GHC.Unit
   39 import GHC.Unit.Module.ModIface
   40 import GHC.Types.Name
   41 import GHC.Platform.Profile
   42 import GHC.Types.Unique.FM
   43 import GHC.Utils.Panic
   44 import GHC.Utils.Binary as Binary
   45 import GHC.Data.FastMutInt
   46 import GHC.Types.Unique
   47 import GHC.Utils.Outputable
   48 import GHC.Types.Name.Cache
   49 import GHC.Types.SrcLoc
   50 import GHC.Platform
   51 import GHC.Data.FastString
   52 import GHC.Settings.Constants
   53 import GHC.Utils.Fingerprint
   54 
   55 import Data.Array
   56 import Data.Array.IO
   57 import Data.Array.Unsafe
   58 import Data.Char
   59 import Data.Word
   60 import Data.IORef
   61 import Control.Monad
   62 
   63 -- ---------------------------------------------------------------------------
   64 -- Reading and writing binary interface files
   65 --
   66 
   67 data CheckHiWay = CheckHiWay | IgnoreHiWay
   68     deriving Eq
   69 
   70 data TraceBinIFace
   71    = TraceBinIFace (SDoc -> IO ())
   72    | QuietBinIFace
   73 
   74 -- | Read an interface file header, checking the magic number, version, and
   75 -- way. Returns the hash of the source file and a BinHandle which points at the
   76 -- start of the rest of the interface file data.
   77 readBinIfaceHeader
   78   :: Profile
   79   -> NameCache
   80   -> CheckHiWay
   81   -> TraceBinIFace
   82   -> FilePath
   83   -> IO (Fingerprint, BinHandle)
   84 readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
   85     let platform = profilePlatform profile
   86 
   87         wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
   88         wantedGot what wanted got ppr' =
   89             case traceBinIFace of
   90                QuietBinIFace         -> return ()
   91                TraceBinIFace printer -> printer $
   92                      text what <> text ": " <>
   93                      vcat [text "Wanted " <> ppr' wanted <> text ",",
   94                            text "got    " <> ppr' got]
   95 
   96         errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
   97         errorOnMismatch what wanted got =
   98             -- This will be caught by readIface which will emit an error
   99             -- msg containing the iface module name.
  100             when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
  101                          (what ++ " (wanted " ++ show wanted
  102                                ++ ", got "    ++ show got ++ ")")
  103     bh <- Binary.readBinMem hi_path
  104 
  105     -- Read the magic number to check that this really is a GHC .hi file
  106     -- (This magic number does not change when we change
  107     --  GHC interface file format)
  108     magic <- get bh
  109     wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
  110     errorOnMismatch "magic number mismatch: old/corrupt interface file?"
  111         (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
  112 
  113     -- Check the interface file version and profile tag.
  114     check_ver  <- get bh
  115     let our_ver = show hiVersion
  116     wantedGot "Version" our_ver check_ver text
  117     errorOnMismatch "mismatched interface file versions" our_ver check_ver
  118 
  119     check_tag <- get bh
  120     let tag = profileBuildTag profile
  121     wantedGot "Way" tag check_tag ppr
  122     when (checkHiWay == CheckHiWay) $
  123         errorOnMismatch "mismatched interface file profile tag" tag check_tag
  124 
  125     src_hash <- get bh
  126     pure (src_hash, bh)
  127 
  128 -- | Read an interface file.
  129 readBinIface
  130   :: Profile
  131   -> NameCache
  132   -> CheckHiWay
  133   -> TraceBinIFace
  134   -> FilePath
  135   -> IO ModIface
  136 readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
  137     (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path
  138 
  139     extFields_p <- get bh
  140 
  141     mod_iface <- getWithUserData name_cache bh
  142 
  143     seekBin bh extFields_p
  144     extFields <- get bh
  145 
  146     return mod_iface
  147       { mi_ext_fields = extFields
  148       , mi_src_hash = src_hash
  149       }
  150 
  151 -- | This performs a get action after reading the dictionary and symbol
  152 -- table. It is necessary to run this before trying to deserialise any
  153 -- Names or FastStrings.
  154 getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
  155 getWithUserData name_cache bh = do
  156     -- Read the dictionary
  157     -- The next word in the file is a pointer to where the dictionary is
  158     -- (probably at the end of the file)
  159     dict_p <- Binary.get bh
  160     data_p <- tellBin bh          -- Remember where we are now
  161     seekBin bh dict_p
  162     dict   <- getDictionary bh
  163     seekBin bh data_p             -- Back to where we were before
  164 
  165     -- Initialise the user-data field of bh
  166     bh <- do
  167         bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
  168                                                      (getDictFastString dict)
  169         symtab_p <- Binary.get bh     -- Get the symtab ptr
  170         data_p <- tellBin bh          -- Remember where we are now
  171         seekBin bh symtab_p
  172         symtab <- getSymbolTable bh name_cache
  173         seekBin bh data_p             -- Back to where we were before
  174 
  175         -- It is only now that we know how to get a Name
  176         return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
  177                                                (getDictFastString dict)
  178 
  179     -- Read the interface file
  180     get bh
  181 
  182 -- | Write an interface file
  183 writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
  184 writeBinIface profile traceBinIface hi_path mod_iface = do
  185     bh <- openBinMem initBinMemSize
  186     let platform = profilePlatform profile
  187     put_ bh (binaryInterfaceMagic platform)
  188 
  189     -- The version, profile tag, and source hash go next
  190     put_ bh (show hiVersion)
  191     let tag = profileBuildTag profile
  192     put_  bh tag
  193     put_  bh (mi_src_hash mod_iface)
  194 
  195     extFields_p_p <- tellBin bh
  196     put_ bh extFields_p_p
  197 
  198     putWithUserData traceBinIface bh mod_iface
  199 
  200     extFields_p <- tellBin bh
  201     putAt bh extFields_p_p extFields_p
  202     seekBin bh extFields_p
  203     put_ bh (mi_ext_fields mod_iface)
  204 
  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`.
  212 putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
  213 putWithUserData traceBinIface 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 0
  224     symtab_map <- newIORef emptyUFM
  225     let bin_symtab = BinSymbolTable {
  226                          bin_symtab_next = symtab_next,
  227                          bin_symtab_map  = symtab_map }
  228     dict_next_ref <- newFastMutInt 0
  229     dict_map_ref <- newIORef emptyUFM
  230     let bin_dict = BinDictionary {
  231                        bin_dict_next = dict_next_ref,
  232                        bin_dict_map  = dict_map_ref }
  233 
  234     -- Put the main thing,
  235     bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
  236                                                   (putName bin_dict bin_symtab)
  237                                                   (putFastString bin_dict)
  238     put_ bh payload
  239 
  240     -- Write the symtab pointer at the front of the file
  241     symtab_p <- tellBin bh        -- This is where the symtab will start
  242     putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
  243     seekBin bh symtab_p           -- Seek back to the end of the file
  244 
  245     -- Write the symbol table itself
  246     symtab_next <- readFastMutInt symtab_next
  247     symtab_map  <- readIORef symtab_map
  248     putSymbolTable bh symtab_next symtab_map
  249     case traceBinIface of
  250       QuietBinIFace         -> return ()
  251       TraceBinIFace printer ->
  252          printer (text "writeBinIface:" <+> int symtab_next
  253                                         <+> text "Names")
  254 
  255     -- NB. write the dictionary after the symbol table, because
  256     -- writing the symbol table may create more dictionary entries.
  257 
  258     -- Write the dictionary pointer at the front of the file
  259     dict_p <- tellBin bh          -- This is where the dictionary will start
  260     putAt bh dict_p_p dict_p      -- Fill in the placeholder
  261     seekBin bh dict_p             -- Seek back to the end of the file
  262 
  263     -- Write the dictionary itself
  264     dict_next <- readFastMutInt dict_next_ref
  265     dict_map  <- readIORef dict_map_ref
  266     putDictionary bh dict_next dict_map
  267     case traceBinIface of
  268       QuietBinIFace         -> return ()
  269       TraceBinIFace printer ->
  270          printer (text "writeBinIface:" <+> int dict_next
  271                                         <+> text "dict entries")
  272 
  273 
  274 
  275 -- | Initial ram buffer to allocate for writing interface files
  276 initBinMemSize :: Int
  277 initBinMemSize = 1024 * 1024
  278 
  279 binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
  280 binaryInterfaceMagic platform
  281  | target32Bit platform = FixedLengthEncoding 0x1face
  282  | otherwise            = FixedLengthEncoding 0x1face64
  283 
  284 
  285 -- -----------------------------------------------------------------------------
  286 -- The symbol table
  287 --
  288 
  289 putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
  290 putSymbolTable bh next_off symtab = do
  291     put_ bh next_off
  292     let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
  293       -- It's OK to use nonDetEltsUFM here because the elements have
  294       -- indices that array uses to create order
  295     mapM_ (\n -> serialiseName bh n symtab) names
  296 
  297 
  298 getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
  299 getSymbolTable bh name_cache = do
  300     sz <- get bh :: IO Int
  301     -- create an array of Names for the symbols and add them to the NameCache
  302     updateNameCache' name_cache $ \cache0 -> do
  303         mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
  304         cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
  305           let mod = mkModule uid mod_name
  306           case lookupOrigNameCache cache mod occ of
  307             Just name -> do
  308               writeArray mut_arr (fromIntegral i) name
  309               return cache
  310             Nothing   -> do
  311               uniq <- takeUniqFromNameCache name_cache
  312               let name      = mkExternalName uniq mod occ noSrcSpan
  313                   new_cache = extendOrigNameCache cache mod occ name
  314               writeArray mut_arr (fromIntegral i) name
  315               return new_cache
  316         arr <- unsafeFreeze mut_arr
  317         return (cache, arr)
  318 
  319 serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
  320 serialiseName bh name _ = do
  321     let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
  322     put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
  323 
  324 
  325 -- Note [Symbol table representation of names]
  326 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  327 --
  328 -- An occurrence of a name in an interface file is serialized as a single 32-bit
  329 -- word. The format of this word is:
  330 --  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
  331 --   A normal name. x is an index into the symbol table
  332 --  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
  333 --   A known-key name. x is the Unique's Char, y is the int part. We assume that
  334 --   all known-key uniques fit in this space. This is asserted by
  335 --   GHC.Builtin.Utils.knownKeyNamesOkay.
  336 --
  337 -- During serialization we check for known-key things using isKnownKeyName.
  338 -- During deserialization we use lookupKnownKeyName to get from the unique back
  339 -- to its corresponding Name.
  340 
  341 
  342 -- See Note [Symbol table representation of names]
  343 putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
  344 putName _dict BinSymbolTable{
  345                bin_symtab_map = symtab_map_ref,
  346                bin_symtab_next = symtab_next }
  347         bh name
  348   | isKnownKeyName name
  349   , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
  350   = -- assert (u < 2^(22 :: Int))
  351     put_ bh (0x80000000
  352              .|. (fromIntegral (ord c) `shiftL` 22)
  353              .|. (fromIntegral u :: Word32))
  354 
  355   | otherwise
  356   = do symtab_map <- readIORef symtab_map_ref
  357        case lookupUFM symtab_map name of
  358          Just (off,_) -> put_ bh (fromIntegral off :: Word32)
  359          Nothing -> do
  360             off <- readFastMutInt symtab_next
  361             -- massert (off < 2^(30 :: Int))
  362             writeFastMutInt symtab_next (off+1)
  363             writeIORef symtab_map_ref
  364                 $! addToUFM symtab_map name (off,name)
  365             put_ bh (fromIntegral off :: Word32)
  366 
  367 -- See Note [Symbol table representation of names]
  368 getSymtabName :: NameCache
  369               -> Dictionary -> SymbolTable
  370               -> BinHandle -> IO Name
  371 getSymtabName _name_cache _dict symtab bh = do
  372     i :: Word32 <- get bh
  373     case i .&. 0xC0000000 of
  374       0x00000000 -> return $! symtab ! fromIntegral i
  375 
  376       0x80000000 ->
  377         let
  378           tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
  379           ix  = fromIntegral i .&. 0x003FFFFF
  380           u   = mkUnique tag ix
  381         in
  382           return $! case lookupKnownKeyName u of
  383                       Nothing -> pprPanic "getSymtabName:unknown known-key unique"
  384                                           (ppr i $$ ppr (unpkUnique u))
  385                       Just n  -> n
  386 
  387       _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
  388 
  389 data BinSymbolTable = BinSymbolTable {
  390         bin_symtab_next :: !FastMutInt, -- The next index to use
  391         bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
  392                                 -- indexed by Name
  393   }
  394 
  395 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
  396 putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
  397 
  398 allocateFastString :: BinDictionary -> FastString -> IO Word32
  399 allocateFastString BinDictionary { bin_dict_next = j_r,
  400                                    bin_dict_map  = out_r} f = do
  401     out <- readIORef out_r
  402     let !uniq = getUnique f
  403     case lookupUFM_Directly out uniq of
  404         Just (j, _)  -> return (fromIntegral j :: Word32)
  405         Nothing -> do
  406            j <- readFastMutInt j_r
  407            writeFastMutInt j_r (j + 1)
  408            writeIORef out_r $! addToUFM_Directly out uniq (j, f)
  409            return (fromIntegral j :: Word32)
  410 
  411 getDictFastString :: Dictionary -> BinHandle -> IO FastString
  412 getDictFastString dict bh = do
  413     j <- get bh
  414     return $! (dict ! fromIntegral (j :: Word32))
  415 
  416 data BinDictionary = BinDictionary {
  417         bin_dict_next :: !FastMutInt, -- The next index to use
  418         bin_dict_map  :: !(IORef (UniqFM FastString (Int,FastString)))
  419                                 -- indexed by FastString
  420   }
  421