X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=d2c408352b08d2daf9f13ecff639266921db7f0e;hb=e4db45612e3efa59251239e1e0b8a0440783b966;hp=0ffd37dec71fa1e61ad328f0a6d2f568ae5bd740;hpb=8e325220e14e05e83fef46a195e7f05fe2d49433;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 0ffd37d..d2c4083 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,9 +1,17 @@ +{-# 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" @@ -34,30 +42,50 @@ 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]) 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) magic <- get bh + wantedGot "Magic" binaryInterfaceMagic magic when (magic /= binaryInterfaceMagic) $ throwDyn (ProgramError ( "magic number mismatch: old/corrupt interface file?")) @@ -72,6 +100,7 @@ readBinIface_ hi_path nc = do -- Check the interface file version and ways. check_ver <- get bh let our_ver = show opt_HiVersion + wantedGot "Version" our_ver check_ver when (check_ver /= our_ver) $ -- This will be caught by readIface which will emit an error -- msg containing the iface module name. @@ -80,9 +109,9 @@ readBinIface_ hi_path nc = do ++ 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) $ + wantedGot "Way" way_descr check_way + when (checkHiWay == CheckHiWay && check_way /= way_descr) $ -- This will be caught by readIface -- which will emit an error msg containing the iface module name. throwDyn (ProgramError ( @@ -294,7 +323,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 +342,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 +362,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 +382,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 +447,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 @@ -888,6 +919,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 +962,9 @@ 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) instance Binary IfaceConAlt where put_ bh IfaceDefault = do @@ -1222,10 +1260,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)