X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=58c837376adebf302b056ffbcd41f9f3ed606635;hp=5b94dd6c14d7b5030f00a396d13a112d93542304;hb=66579ff945831c5fc9a17c58c722ff01f2268d76;hpb=f09fe9cd924df3ca73baf124e66f05794e066780 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 5b94dd6..58c8373 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,16 +1,15 @@ -{-# 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 - --- + +{-# 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, CheckHiWay(..) ) where +module BinIface ( writeBinIface, readBinIface, + CheckHiWay(..), TraceBinIFaceReading(..) ) where #include "HsVersions.h" @@ -31,92 +30,106 @@ 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 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 :: CheckHiWay -> FilePath -> TcRnIf a b ModIface -readBinIface checkHiWay hi_path = do +readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath + -> TcRnIf a b ModIface +readBinIface checkHiWay traceBinIFaceReading hi_path = do nc <- getNameCache - (new_nc, iface) <- liftIO $ readBinIface_ checkHiWay hi_path nc + (new_nc, iface) <- liftIO $ + readBinIface_ checkHiWay traceBinIFaceReading hi_path nc setNameCache new_nc return iface -readBinIface_ :: CheckHiWay -> FilePath -> NameCache +readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache -> IO (NameCache, ModIface) -readBinIface_ checkHiWay hi_path nc = do +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?")) + 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 way_descr <- getWayDescr - 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) - 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 @@ -142,7 +155,19 @@ writeBinIface dflags hi_path mod_iface = do 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 @@ -154,8 +179,8 @@ writeBinIface dflags hi_path mod_iface = do 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") @@ -169,8 +194,8 @@ writeBinIface dflags hi_path mod_iface = do 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") @@ -178,15 +203,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 -- ----------------------------------------------------------------------------- @@ -216,7 +243,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 @@ -235,10 +262,55 @@ fromOnDiskName arr nc (pid, mod_name, occ) = } 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 @@ -291,84 +363,88 @@ instance Binary ModIface where 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, + 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 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 }) + mi_hash_fn = mkIfaceHashCache decls }) getWayDescr :: IO String getWayDescr = do @@ -412,40 +488,65 @@ instance (Binary name) => Binary (GenAvailInfo name) where 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 Deprecations 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 @@ -847,6 +948,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 @@ -947,6 +1049,7 @@ instance Binary IfaceExpr where 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 @@ -1053,6 +1156,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 @@ -1070,7 +1174,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 @@ -1170,6 +1274,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