---
+
+{-# OPTIONS_GHC -O #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
+
+--
-- (c) The University of Glasgow 2002-2006
---
+--
-- Binary interface file support.
-module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
+module BinIface ( writeBinIface, readBinIface,
+ CheckHiWay(..), TraceBinIFaceReading(..) ) where
#include "HsVersions.h"
import UniqSupply
import CostCentre
import StaticFlags
-import PackageConfig
import Panic
import Binary
import SrcLoc
-import Util
import ErrUtils
import Config
import FastMutInt
+import Unique
import Outputable
+import FastString
+import Data.List
import Data.Word
import Data.Array
import Data.IORef
-import Control.Exception
import Control.Monad
+data CheckHiWay = CheckHiWay | IgnoreHiWay
+ deriving Eq
+
+data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
+ deriving Eq
+
-- ---------------------------------------------------------------------------
-- Reading and writing binary interface files
-readBinIface :: FilePath -> TcRnIf a b ModIface
-readBinIface hi_path = do
+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> TcRnIf a b ModIface
+readBinIface checkHiWay traceBinIFaceReading hi_path = do
nc <- getNameCache
- (new_nc, iface) <- ioToIOEnv $ readBinIface_ hi_path nc
+ (new_nc, iface) <- liftIO $
+ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
setNameCache new_nc
return iface
-readBinIface_ :: FilePath -> NameCache -> IO (NameCache, ModIface)
-readBinIface_ hi_path nc = do
+readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
+ -> IO (NameCache, ModIface)
+readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
+ let printer :: SDoc -> IO ()
+ printer = case traceBinIFaceReading of
+ TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
+ QuietBinIFaceReading -> \_ -> return ()
+ wantedGot :: Outputable a => String -> a -> a -> IO ()
+ wantedGot what wanted got
+ = printer (text what <> text ": " <>
+ vcat [text "Wanted " <> ppr wanted <> text ",",
+ text "got " <> ppr got])
+
+ errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
+ errorOnMismatch what wanted got
+ -- This will be caught by readIface which will emit an error
+ -- msg containing the iface module name.
+ = when (wanted /= got) $ ghcError $ ProgramError
+ (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)
+ -- 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
- when (magic /= binaryInterfaceMagic) $
- throwDyn (ProgramError (
- "magic number mismatch: old/corrupt interface file?"))
-
- -- 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 -- Get the dictionary ptr
- data_p <- tellBin bh -- Remember where we are now
+ wantedGot "Magic" binaryInterfaceMagic magic
+ errorOnMismatch "magic number mismatch: old/corrupt interface file?"
+ binaryInterfaceMagic magic
+
+ -- Get the dictionary pointer. We won't attempt to actually
+ -- read the dictionary until we've done the version checks below,
+ -- just in case this isn't a valid interface. In retrospect the
+ -- version should have come before the dictionary pointer, but this
+ -- is the way it was done originally, and we can't change it now.
+ dict_p <- Binary.get bh -- Get the dictionary ptr
+
+ -- Check the interface file version and ways.
+ check_ver <- get bh
+ let our_ver = show opt_HiVersion
+ wantedGot "Version" our_ver check_ver
+ errorOnMismatch "mismatched interface file versions" our_ver check_ver
+
+ check_way <- get bh
+ way_descr <- getWayDescr
+ wantedGot "Way" way_descr check_way
+ when (checkHiWay == CheckHiWay) $
+ errorOnMismatch "mismatched interface file ways" way_descr check_way
+
+ -- Read the dictionary
+ -- The next word in the file is a pointer to where the dictionary is
+ -- (probably at the end of the file)
+ data_p <- tellBin bh -- Remember where we are now
seekBin bh dict_p
dict <- getDictionary bh
- seekBin bh data_p -- Back to where we were before
+ seekBin bh data_p -- Back to where we were before
- -- Initialise the user-data field of bh
+ -- Initialise the user-data field of bh
ud <- newReadState dict
bh <- return (setUserData bh ud)
-
- symtab_p <- Binary.get bh -- Get the symtab ptr
- data_p <- tellBin bh -- Remember where we are now
+
+ symtab_p <- Binary.get bh -- Get the symtab ptr
+ data_p <- tellBin bh -- Remember where we are now
seekBin bh symtab_p
(nc', symtab) <- getSymbolTable bh nc
- seekBin bh data_p -- Back to where we were before
+ seekBin bh data_p -- Back to where we were before
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
dict_p_p <- tellBin bh
put_ bh dict_p_p -- Placeholder for ptr to dictionary
+ -- The version and way descriptor go next
+ put_ bh (show opt_HiVersion)
+ way_descr <- getWayDescr
+ put bh way_descr
+
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
-- Make some intial state
- ud <- newWriteState
+ 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 }
+ ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
-- Put the main thing,
bh <- return $ setUserData bh ud
seekBin bh symtab_p -- Seek back to the end of the file
-- Write the symbol table itself
- symtab_next <- readFastMutInt (ud_symtab_next ud)
- symtab_map <- readIORef (ud_symtab_map ud)
+ symtab_next <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
putSymbolTable bh symtab_next symtab_map
debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
<+> text "Names")
seekBin bh dict_p -- Seek back to the end of the file
-- Write the dictionary itself
- dict_next <- readFastMutInt (ud_dict_next ud)
- dict_map <- readIORef (ud_dict_map ud)
+ dict_next <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
<+> text "dict entries")
-- And send the result to the file
writeBinMem bh hi_path
-initBinMemSize = (1024*1024) :: Int
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024
-- The *host* architecture version:
#include "MachDeps.h"
+binaryInterfaceMagic :: Word32
#if WORD_SIZE_IN_BITS == 32
-binaryInterfaceMagic = 0x1face :: Word32
+binaryInterfaceMagic = 0x1face
#elif WORD_SIZE_IN_BITS == 64
-binaryInterfaceMagic = 0x1face64 :: Word32
+binaryInterfaceMagic = 0x1face64
#endif
-- -----------------------------------------------------------------------------
-> NameCache
-> OnDiskName
-> (NameCache, Name)
-fromOnDiskName arr nc (pid, mod_name, occ) =
+fromOnDiskName _ nc (pid, mod_name, occ) =
let
mod = mkModule pid mod_name
cache = nsNames nc
let
us = nsUniqs nc
uniq = uniqFromSupply us
- name = mkExternalName uniq mod occ noSrcLoc
+ name = mkExternalName uniq mod occ noSrcSpan
new_cache = extendNameCache cache mod occ name
in
case splitUniqSupply us of { (us',_) ->
}
serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
-serialiseName bh name symtab = do
- let mod = nameModule name
+serialiseName bh name _ = do
+ let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+
+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName BinSymbolTable{
+ bin_symtab_map = symtab_map_ref,
+ bin_symtab_next = symtab_next } bh name
+ = do
+ symtab_map <- readIORef symtab_map_ref
+ case lookupUFM symtab_map name of
+ Just (off,_) -> put_ bh off
+ Nothing -> do
+ off <- readFastMutInt symtab_next
+ writeFastMutInt symtab_next (off+1)
+ writeIORef symtab_map_ref
+ $! addToUFM symtab_map name (off,name)
+ put_ bh off
+
+
+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 ()
+putFastString BinDictionary { bin_dict_next = j_r,
+ bin_dict_map = out_r} bh f
+ = do
+ out <- readIORef out_r
+ let uniq = getUnique f
+ case lookupUFM out uniq of
+ Just (j, _) -> put_ bh j
+ Nothing -> do
+ j <- readFastMutInt j_r
+ put_ bh j
+ writeFastMutInt j_r (j + 1)
+ writeIORef out_r $! addToUFM out uniq (j, f)
+
+
+data BinDictionary = BinDictionary {
+ bin_dict_next :: !FastMutInt, -- The next index to use
+ bin_dict_map :: !(IORef (UniqFM (Int,FastString)))
+ -- indexed by FastString
+ }
+
-- -----------------------------------------------------------------------------
-- All the binary instances
put_ bh (ModIface {
mi_module = mod,
mi_boot = is_boot,
- mi_mod_vers = mod_vers,
+ mi_iface_hash= iface_hash,
+ mi_mod_hash = mod_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
- mi_exp_vers = exp_vers,
+ mi_exp_hash = exp_hash,
mi_fixities = fixities,
- mi_deprecs = deprecs,
+ mi_warns = warns,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
- mi_rule_vers = rule_vers }) = do
- put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
- put bh way_descr
+ mi_orphan_hash = orphan_hash,
+ mi_vect_info = vect_info,
+ mi_hpc = hpc_info }) = do
put_ bh mod
put_ bh is_boot
- put_ bh mod_vers
+ put_ bh iface_hash
+ put_ bh mod_hash
put_ bh orphan
put_ bh hasFamInsts
lazyPut bh deps
lazyPut bh usages
put_ bh exports
- put_ bh exp_vers
+ put_ bh exp_hash
put_ bh fixities
- lazyPut bh deprecs
+ lazyPut bh warns
put_ bh decls
put_ bh insts
put_ bh fam_insts
lazyPut bh rules
- put_ bh rule_vers
+ put_ bh orphan_hash
+ put_ bh vect_info
+ put_ bh hpc_info
get bh = do
- check_ver <- get bh
- let our_ver = show opt_HiVersion
- when (check_ver /= our_ver) $
- -- use userError because this will be caught by readIface
- -- which will emit an error msg containing the iface module name.
- throwDyn (ProgramError (
- "mismatched interface file versions: expected "
- ++ our_ver ++ ", found " ++ check_ver))
-
- check_way <- get bh
- ignore_way <- readIORef v_IgnoreHiWay
- way_descr <- getWayDescr
- when (not ignore_way && check_way /= way_descr) $
- -- use userError because this will be caught by readIface
- -- which will emit an error msg containing the iface module name.
- throwDyn (ProgramError (
- "mismatched interface file ways: expected "
- ++ way_descr ++ ", found " ++ check_way))
-
mod_name <- get bh
is_boot <- get bh
- mod_vers <- get bh
+ iface_hash <- get bh
+ mod_hash <- get bh
orphan <- get bh
hasFamInsts <- get bh
deps <- lazyGet bh
usages <- {-# SCC "bin_usages" #-} lazyGet bh
exports <- {-# SCC "bin_exports" #-} get bh
- exp_vers <- get bh
+ exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
- deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
+ warns <- {-# SCC "bin_warns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
- rule_vers <- get bh
+ orphan_hash <- get bh
+ vect_info <- get bh
+ hpc_info <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
- mi_mod_vers = mod_vers,
+ mi_iface_hash = iface_hash,
+ mi_mod_hash = mod_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
- mi_exp_vers = exp_vers,
+ mi_exp_hash = exp_hash,
mi_fixities = fixities,
- mi_deprecs = deprecs,
+ mi_warns = warns,
mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
- mi_rule_vers = rule_vers,
+ mi_orphan_hash = orphan_hash,
+ mi_vect_info = vect_info,
+ mi_hpc = hpc_info,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
- mi_ver_fn = mkIfaceVerCache decls })
-
-GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
+ mi_hash_fn = mkIfaceHashCache decls })
getWayDescr :: IO String
getWayDescr = do
return (AvailTC ab ac)
instance Binary Usage where
- put_ bh usg = do
- put_ bh (usg_name usg)
- put_ bh (usg_mod usg)
+ put_ bh usg@UsagePackageModule{} = do
+ putByte bh 0
+ put_ bh (usg_mod usg)
+ put_ bh (usg_mod_hash usg)
+ put_ bh usg@UsageHomeModule{} = do
+ putByte bh 1
+ put_ bh (usg_mod_name usg)
+ put_ bh (usg_mod_hash usg)
put_ bh (usg_exports usg)
put_ bh (usg_entities usg)
- put_ bh (usg_rules usg)
get bh = do
- nm <- get bh
- mod <- get bh
- exps <- get bh
- ents <- get bh
- rules <- get bh
- return (Usage { usg_name = nm, usg_mod = mod,
- usg_exports = exps, usg_entities = ents,
- usg_rules = rules })
-
-instance Binary a => Binary (Deprecs a) where
- put_ bh NoDeprecs = putByte bh 0
- put_ bh (DeprecAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (DeprecSome ts) = do
- putByte bh 2
- put_ bh ts
+ h <- getByte bh
+ case h of
+ 0 -> do
+ nm <- get bh
+ mod <- get bh
+ return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
+ _ -> do
+ nm <- get bh
+ mod <- get bh
+ exps <- get bh
+ ents <- get bh
+ return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
+ usg_exports = exps, usg_entities = ents }
+
+instance Binary Warnings where
+ put_ bh NoWarnings = putByte bh 0
+ put_ bh (WarnAll t) = do
+ putByte bh 1
+ put_ bh t
+ put_ bh (WarnSome ts) = do
+ putByte bh 2
+ put_ bh ts
get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoDeprecs
- 1 -> do aa <- get bh
- return (DeprecAll aa)
- _ -> do aa <- get bh
- return (DeprecSome aa)
+ h <- getByte bh
+ case h of
+ 0 -> return NoWarnings
+ 1 -> do aa <- get bh
+ return (WarnAll aa)
+ _ -> do aa <- get bh
+ return (WarnSome aa)
+
+instance Binary WarningTxt where
+ put_ bh (WarningTxt w) = do
+ putByte bh 0
+ put_ bh w
+ put_ bh (DeprecatedTxt d) = do
+ putByte bh 1
+ put_ bh d
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do w <- get bh
+ return (WarningTxt w)
+ _ -> do d <- get bh
+ return (DeprecatedTxt d)
-------------------------------------------------------------------------
-- Types from: BasicTypes
_ -> do ab <- get bh
return (IfaceTvBndr ab)
+instance Binary IfaceLetBndr where
+ put_ bh (IfLetBndr a b c) = do
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ return (IfLetBndr a b c)
+
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 0
2 -> do ac <- get bh
ad <- get bh
return (IfaceEqPred ac ad)
+ _ -> panic ("get IfacePredType " ++ show h)
-------------------------------------------------------------------------
-- IfaceExpr and friends
putByte bh 11
put_ bh ie
put_ bh ico
+ put_ bh (IfaceTick m ix) = do
+ putByte bh 12
+ put_ bh m
+ put_ bh ix
get bh = do
h <- getByte bh
case h of
11 -> do ie <- get bh
ico <- get bh
return (IfaceCast ie ico)
+ 12 -> do m <- get bh
+ ix <- get bh
+ return (IfaceTick m ix)
+ _ -> panic ("get IfaceExpr " ++ show h)
instance Binary IfaceConAlt where
put_ bh IfaceDefault = do
3 -> do return IfaceInlineMe
4 -> do ac <- get bh
return (IfaceCoreNote ac)
+ _ -> panic ("get IfaceNote " ++ show h)
-------------------------------------------------------------------------
-- IfaceDecl and friends
put_ bh (occNameFS name)
put_ bh ty
put_ bh idinfo
- put_ bh (IfaceForeign ae af) =
+ put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 2
put_ bh a6
put_ bh a7
put_ bh a8
- put_ bh (IfaceSyn aq ar as at) = do
+ put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
- put_ bh (occNameFS aq)
- put_ bh ar
- put_ bh as
- put_ bh at
+ put_ bh (occNameFS a1)
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
put_ bh a1
occ <- return $! mkOccNameFS tcName a1
return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
3 -> do
- aq <- get bh
- ar <- get bh
- as <- get bh
- at <- get bh
- occ <- return $! mkOccNameFS tcName aq
- return (IfaceSyn occ ar as at)
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ occ <- return $! mkOccNameFS tcName a1
+ return (IfaceSyn occ a2 a3 a4 a5)
_ -> do
a1 <- get bh
a2 <- get bh
0 -> return NoOverlap
1 -> return OverlapOk
2 -> return Incoherent
+ _ -> panic ("get OverlapFlag " ++ show h)
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh IfOpenDataTyCon = putByte bh 1
- put_ bh IfOpenNewTyCon = putByte bh 2
- put_ bh (IfDataTyCon cs) = do { putByte bh 3
+ put_ bh (IfDataTyCon cs) = do { putByte bh 2
; put_ bh cs }
- put_ bh (IfNewTyCon c) = do { putByte bh 4
+ put_ bh (IfNewTyCon c) = do { putByte bh 3
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> return IfOpenDataTyCon
- 2 -> return IfOpenNewTyCon
- 3 -> do cs <- get bh
+ 2 -> do cs <- get bh
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+instance Binary IfaceVectInfo where
+ put_ bh (IfaceVectInfo a1 a2 a3) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ return (IfaceVectInfo a1 a2 a3)
+
projects / ghc-hetmet.git / blobdiff