+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
--
-- (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 FastMutInt
import Outputable
+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) $ throwDyn $ 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?"))
+ 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
+ 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
- when (check_ver /= our_ver) $
- -- 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))
+ wantedGot "Version" our_ver check_ver
+ errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
- ignore_way <- readIORef v_IgnoreHiWay
way_descr <- getWayDescr
- when (not ignore_way && check_way /= way_descr) $
- -- 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))
-
- -- 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
+ 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
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_rule_vers = rule_vers,
- mi_vect_info = vect_info }) = do
+ mi_vect_info = vect_info,
+ mi_hpc = hpc_info }) = do
put_ bh mod
put_ bh is_boot
put_ bh mod_vers
lazyPut bh rules
put_ bh rule_vers
put_ bh vect_info
+ put_ bh hpc_info
get bh = do
mod_name <- get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
vect_info <- get bh
+ hpc_info <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
mi_rules = rules,
mi_rule_vers = rule_vers,
mi_vect_info = vect_info,
+ mi_hpc = hpc_info,
-- And build the cached values
mi_dep_fn = mkIfaceDepCache deprecs,
mi_fix_fn = mkIfaceFixCache fixities,
mi_ver_fn = mkIfaceVerCache decls })
-GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
-
getWayDescr :: IO String
getWayDescr = do
tag <- readIORef v_Build_tag
usg_exports = exps, usg_entities = ents,
usg_rules = rules })
-instance Binary a => Binary (Deprecs a) where
+instance Binary Deprecations where
put_ bh NoDeprecs = putByte bh 0
put_ bh (DeprecAll t) = do
putByte bh 1
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)
instance Binary IfaceConAlt where
put_ bh IfaceDefault = do
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
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceVectInfo where
- put_ bh (IfaceVectInfo a1) = do
+ put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1
+ put_ bh a2
+ put_ bh a3
get bh = do
a1 <- get bh
- return (IfaceVectInfo a1)
+ a2 <- get bh
+ a3 <- get bh
+ return (IfaceVectInfo a1 a2 a3)