X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=321eac14e2b7a441082bfda87649387187f013f4;hb=8604da0136707cc14845d14a88c2272fe576b6d0;hp=0ffd37dec71fa1e61ad328f0a6d2f568ae5bd740;hpb=8e325220e14e05e83fef46a195e7f05fe2d49433;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 0ffd37d..321eac1 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,9 +1,11 @@ + -- -- (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" @@ -24,88 +26,104 @@ import UniqFM import UniqSupply import CostCentre import StaticFlags -import PackageConfig import Panic import Binary import SrcLoc -import Util import ErrUtils import Config 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 @@ -167,15 +185,17 @@ writeBinIface dflags hi_path mod_iface = do -- 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 -- ----------------------------------------------------------------------------- @@ -205,7 +225,7 @@ fromOnDiskName -> 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 @@ -224,7 +244,7 @@ fromOnDiskName arr nc (pid, mod_name, occ) = } serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name symtab = do +serialiseName bh name _ = do let mod = nameModule name put_ bh (modulePackageId mod, moduleName mod, nameOccName name) @@ -294,7 +314,8 @@ instance Binary ModIface where 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 @@ -312,6 +333,7 @@ instance Binary ModIface where lazyPut bh rules put_ bh rule_vers put_ bh vect_info + put_ bh hpc_info get bh = do mod_name <- get bh @@ -331,6 +353,7 @@ instance Binary ModIface where 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, @@ -350,13 +373,12 @@ instance Binary ModIface where 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 @@ -416,7 +438,7 @@ instance Binary Usage where 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 @@ -834,6 +856,7 @@ instance Binary IfacePredType where 2 -> do ac <- get bh ad <- get bh return (IfaceEqPred ac ad) + _ -> panic ("get IfacePredType " ++ show h) ------------------------------------------------------------------------- -- IfaceExpr and friends @@ -888,6 +911,10 @@ instance Binary IfaceExpr where 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 @@ -927,6 +954,10 @@ instance Binary IfaceExpr where 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 @@ -1033,6 +1064,7 @@ instance Binary IfaceNote where 3 -> do return IfaceInlineMe 4 -> do ac <- get bh return (IfaceCoreNote ac) + _ -> panic ("get IfaceNote " ++ show h) ------------------------------------------------------------------------- -- IfaceDecl and friends @@ -1050,7 +1082,7 @@ instance Binary IfaceDecl where 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 @@ -1150,6 +1182,7 @@ instance Binary OverlapFlag where 0 -> return NoOverlap 1 -> return OverlapOk 2 -> return Incoherent + _ -> panic ("get OverlapFlag " ++ show h) instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 @@ -1222,10 +1255,14 @@ instance Binary IfaceRule where 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)