X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=f09ce4f7d25296ef0f2a992429e480e950804506;hb=740618f2b7d822f53528d271ccfb617c8ce84c55;hp=ab4ab01a8c3497d7d37ec3ea3445c42e2f39509b;hpb=0d80489c9b9f2421f65d8dd86c1e50c6bb429715;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ab4ab01..f09ce4f 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,7 +1,11 @@ --- +{-# 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, @@ -14,12 +18,11 @@ import IfaceEnv import HscTypes import BasicTypes import NewDemand +import Annotations import IfaceSyn import Module import Name -import OccName import VarEnv -import InstEnv import Class import DynFlags import UniqFM @@ -40,7 +43,6 @@ import Data.List import Data.Word import Data.Array import Data.IORef -import Control.Exception import Control.Monad data CheckHiWay = CheckHiWay | IgnoreHiWay @@ -55,15 +57,14 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do - nc <- getNameCache - (new_nc, iface) <- liftIO $ - readBinIface_ checkHiWay traceBinIFaceReading hi_path nc - setNameCache new_nc - return iface - -readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache - -> IO (NameCache, ModIface) -readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do + update_nc <- mkNameCacheUpdater + dflags <- getDOpts + liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc + +readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath + -> NameCacheUpdater (Array Int Name) + -> IO ModIface +readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do let printer :: SDoc -> IO () printer = case traceBinIFaceReading of TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle @@ -74,16 +75,11 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do vcat [text "Wanted " <> ppr wanted <> text ",", text "got " <> ppr got]) - errorOnMismatch' :: (Eq a, Show a) => String -> a -> a -> IO () -> IO () - errorOnMismatch' what wanted got io - = do when (wanted /= got) $ io - errorOnMismatch what wanted 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 + = when (wanted /= got) $ ghcError $ ProgramError (what ++ " (wanted " ++ show wanted ++ ", got " ++ show got ++ ")") bh <- Binary.readBinMem hi_path @@ -110,7 +106,7 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do errorOnMismatch "mismatched interface file versions" our_ver check_ver check_way <- get bh - way_descr <- getWayDescr + let way_descr = getWayDescr dflags wantedGot "Way" way_descr check_way when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file ways" way_descr check_way @@ -130,12 +126,12 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do 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 + symtab <- getSymbolTable bh update_nc 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 - return (nc', iface) + return iface writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () @@ -149,8 +145,8 @@ writeBinIface dflags hi_path mod_iface = do -- The version and way descriptor go next put_ bh (show opt_HiVersion) - way_descr <- getWayDescr - put bh way_descr + let way_descr = getWayDescr dflags + put_ bh way_descr -- Remember where the symbol table pointer will go symtab_p_p <- tellBin bh @@ -209,7 +205,7 @@ initBinMemSize :: Int initBinMemSize = 1024 * 1024 -- The *host* architecture version: -#include "MachDeps.h" +#include "../includes/MachDeps.h" binaryInterfaceMagic :: Word32 #if WORD_SIZE_IN_BITS == 32 @@ -227,16 +223,17 @@ putSymbolTable bh next_off symtab = do let names = elems (array (0,next_off-1) (eltsUFM symtab)) mapM_ (\n -> serialiseName bh n symtab) names -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) -getSymbolTable bh namecache = do +getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name) + -> IO (Array Int Name) +getSymbolTable bh update_namecache = do sz <- get bh od_names <- sequence (replicate sz (get bh)) - let + update_namecache $ \namecache -> + let arr = listArray (0,sz-1) names (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names - -- - return (namecache', arr) + in (namecache', arr) type OnDiskName = (PackageId, ModuleName, OccName) @@ -265,7 +262,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do - let mod = nameModule name + let mod = ASSERT2( isExternalName name, ppr name ) nameModule name put_ bh (modulePackageId mod, moduleName mod, nameOccName name) @@ -374,7 +371,8 @@ instance Binary ModIface where mi_exports = exports, mi_exp_hash = exp_hash, mi_fixities = fixities, - mi_deprecs = deprecs, + mi_warns = warns, + mi_anns = anns, mi_decls = decls, mi_insts = insts, mi_fam_insts = fam_insts, @@ -393,7 +391,8 @@ instance Binary ModIface where put_ bh exports put_ bh exp_hash put_ bh fixities - lazyPut bh deprecs + lazyPut bh warns + lazyPut bh anns put_ bh decls put_ bh insts put_ bh fam_insts @@ -414,7 +413,8 @@ instance Binary ModIface where exports <- {-# SCC "bin_exports" #-} get bh exp_hash <- get bh fixities <- {-# SCC "bin_fixities" #-} get bh - deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh @@ -433,8 +433,9 @@ instance Binary ModIface where mi_usages = usages, mi_exports = exports, mi_exp_hash = exp_hash, + mi_anns = anns, mi_fixities = fixities, - mi_deprecs = deprecs, + mi_warns = warns, mi_decls = decls, mi_globals = Nothing, mi_insts = insts, @@ -444,14 +445,15 @@ instance Binary ModIface where 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_hash_fn = mkIfaceHashCache decls }) -getWayDescr :: IO String -getWayDescr = do - tag <- readIORef v_Build_tag - if cGhcUnregisterised == "YES" then return ('u':tag) else return tag +getWayDescr :: DynFlags -> String +getWayDescr dflags + | cGhcUnregisterised == "YES" = 'u':tag + | otherwise = tag + where tag = buildTag dflags -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. @@ -516,23 +518,39 @@ instance Binary Usage where 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 - put_ bh (DeprecAll t) = do - putByte bh 1 - put_ bh t - put_ bh (DeprecSome ts) = do - putByte bh 2 - put_ bh ts +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 @@ -559,13 +577,28 @@ instance Binary Activation where _ -> do ab <- get bh return (ActiveAfter ab) +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlinePragma where + put_ bh (InlinePragma activation match_info) = do + put_ bh activation + put_ bh match_info + + get bh = do + act <- get bh + info <- get bh + return (InlinePragma act info) + instance Binary StrictnessMark where - put_ bh MarkedStrict = do - putByte bh 0 - put_ bh MarkedUnboxed = do - putByte bh 1 - put_ bh NotMarkedStrict = do - putByte bh 2 + put_ bh MarkedStrict = putByte bh 0 + put_ bh MarkedUnboxed = putByte bh 1 + put_ bh NotMarkedStrict = putByte bh 2 get bh = do h <- getByte bh case h of @@ -574,10 +607,8 @@ instance Binary StrictnessMark where _ -> do return NotMarkedStrict instance Binary Boxity where - put_ bh Boxed = do - putByte bh 0 - put_ bh Unboxed = do - putByte bh 1 + put_ bh Boxed = putByte bh 0 + put_ bh Unboxed = putByte bh 1 get bh = do h <- getByte bh case h of @@ -649,7 +680,7 @@ instance (Binary name) => Binary (IPName name) where instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType - put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p) + put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p) get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr) instance Binary Demand where @@ -1077,6 +1108,19 @@ instance Binary IfaceBinding where _ -> do ac <- get bh return (IfaceRec ac) +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b } + put_ bh IfDFunId = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do a <- get bh + b <- get bh + return (IfRecSelId a b) + _ -> return IfDFunId + instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do @@ -1155,10 +1199,11 @@ instance Binary IfaceNote where -- when de-serialising. instance Binary IfaceDecl where - put_ bh (IfaceId name ty idinfo) = do + put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 put_ bh (occNameFS name) put_ bh ty + put_ bh details put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" @@ -1191,11 +1236,12 @@ instance Binary IfaceDecl where get bh = do h <- getByte bh case h of - 0 -> do name <- get bh - ty <- get bh - idinfo <- get bh + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty idinfo) + return (IfaceId occ ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- get bh @@ -1280,7 +1326,7 @@ instance Binary IfaceConDecls where return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1290,6 +1336,7 @@ instance Binary IfaceConDecl where put_ bh a7 put_ bh a8 put_ bh a9 + put_ bh a10 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh @@ -1299,7 +1346,8 @@ instance Binary IfaceConDecl where a7 <- get bh a8 <- get bh a9 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) + a10 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do @@ -1332,6 +1380,30 @@ instance Binary IfaceRule where a7 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6 a7) +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> do a <- get bh + return (NamedTarget a) + _ -> do a <- get bh + return (ModuleTarget a) + instance Binary IfaceVectInfo where put_ bh (IfaceVectInfo a1 a2 a3) = do put_ bh a1