X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fiface%2FBinIface.hs;h=152381c528bdcebaf0c9b3f5dda7063e80dc74bf;hb=526c3af1dc98987b6949f4df73c0debccf9875bd;hp=1a4e7888259c2e43e2367f12f889bbc66f8db99a;hpb=a6f203cb4574c75d6bf091c7e1608061bbf51f78;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 1a4e788..152381c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,9 +1,3 @@ -{-# 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 @@ -32,15 +26,15 @@ 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 @@ -157,7 +151,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 @@ -169,8 +175,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") @@ -184,8 +190,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") @@ -193,15 +199,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 -- ----------------------------------------------------------------------------- @@ -231,7 +239,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 @@ -250,10 +258,55 @@ 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) + +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 @@ -306,70 +359,74 @@ 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_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 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 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_decls = decls, @@ -377,13 +434,13 @@ instance Binary ModIface where 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_fix_fn = mkIfaceFixCache fixities, - mi_ver_fn = mkIfaceVerCache decls }) + mi_hash_fn = mkIfaceHashCache decls }) getWayDescr :: IO String getWayDescr = do @@ -427,22 +484,31 @@ 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 }) + 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 Deprecations where put_ bh NoDeprecs = putByte bh 0 @@ -862,6 +928,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 @@ -962,6 +1029,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 @@ -1068,6 +1136,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 @@ -1085,7 +1154,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 @@ -1185,6 +1254,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