X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=d2c408352b08d2daf9f13ecff639266921db7f0e;hb=f53056962c6d5d465001560a5b2afd8edf67517b;hp=782badad04400f45f142c138406f90eea5592022;hpb=8100cd4395e46ae747be4298c181a4730d6206bc;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 782bada..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,38 +42,85 @@ 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?")) + -- 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 + 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)) + + check_way <- get bh + way_descr <- getWayDescr + 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 ( + "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) - dict_p <- Binary.get bh -- Get the dictionary ptr data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh @@ -95,6 +150,11 @@ writeBinIface dflags hi_path mod_iface = do 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 @@ -185,7 +245,7 @@ fromOnDiskName arr nc (pid, mod_name, occ) = 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',_) -> @@ -262,10 +322,9 @@ instance Binary ModIface where 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_rule_vers = rule_vers, + mi_vect_info = vect_info, + mi_hpc = hpc_info }) = do put_ bh mod put_ bh is_boot put_ bh mod_vers @@ -282,27 +341,10 @@ instance Binary ModIface where put_ bh fam_insts lazyPut bh rules put_ bh rule_vers + 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 @@ -319,6 +361,8 @@ instance Binary ModIface where fam_insts <- {-# SCC "bin_fam_insts" #-} 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, @@ -337,13 +381,13 @@ instance Binary ModIface where mi_fam_insts = fam_insts, 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 @@ -403,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 @@ -681,6 +725,16 @@ instance Binary IfaceBndr where _ -> 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 @@ -865,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 @@ -904,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 @@ -1039,12 +1100,13 @@ instance Binary IfaceDecl where 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 @@ -1075,12 +1137,13 @@ instance Binary IfaceDecl where 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 @@ -1129,18 +1192,16 @@ instance Binary OverlapFlag where 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) @@ -1198,4 +1259,15 @@ instance Binary IfaceRule where 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) +