X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=d79ec95f6afd698dab13b9bf2b217698a11bba87;hp=631a28660e8374d1df38fd7ce6e9552a4906992d;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=ee2dd59cf1c96437696b9ec39b35dd1beea259a1 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 631a286..d79ec95 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,7 +1,5 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -- --- (c) The University of Glasgow 2002 +-- (c) The University of Glasgow 2002-2006 -- -- Binary interface file support. @@ -9,43 +7,230 @@ module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where #include "HsVersions.h" +import TcRnMonad +import IfaceEnv import HscTypes import BasicTypes import NewDemand import IfaceSyn +import Module +import Name +import OccName import VarEnv -import InstEnv ( OverlapFlag(..) ) -import Packages ( PackageIdH(..) ) -import Class ( DefMeth(..) ) +import InstEnv +import Class +import DynFlags +import UniqFM +import UniqSupply import CostCentre -import StaticFlags ( opt_HiVersion, v_Build_tag ) -import Kind ( Kind(..) ) +import StaticFlags +import PackageConfig import Panic import Binary +import SrcLoc import Util -import Config ( cGhcUnregisterised ) - -import DATA_IOREF -import EXCEPTION ( throwDyn ) -import Monad ( when ) +import ErrUtils +import Config +import FastMutInt import Outputable -#include "HsVersions.h" +import Data.List +import Data.Word +import Data.Array +import Data.IORef +import Control.Exception +import Control.Monad -- --------------------------------------------------------------------------- -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path mod_iface - -readBinIface :: FilePath -> IO ModIface -readBinIface hi_path = getBinFileWithDict hi_path - - --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* +-- Reading and writing binary interface files + +readBinIface :: FilePath -> TcRnIf a b ModIface +readBinIface hi_path = do + nc <- getNameCache + (new_nc, iface) <- ioToIOEnv $ readBinIface_ hi_path nc + setNameCache new_nc + return iface + +readBinIface_ :: FilePath -> NameCache -> IO (NameCache, ModIface) +readBinIface_ hi_path nc = do + 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 + 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 + 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 + ignore_way <- readIORef v_IgnoreHiWay + way_descr <- getWayDescr + when (not ignore_way && 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 + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p -- Back to where we were before + + -- 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 + seekBin bh symtab_p + (nc', symtab) <- getSymbolTable bh 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) + + +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + put_ bh binaryInterfaceMagic + + -- Remember where the dictionary pointer will go + 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 + + -- Make some intial state + ud <- newWriteState + + -- Put the main thing, + bh <- return $ setUserData bh ud + put_ bh mod_iface + + -- Write the symtab pointer at the fornt of the file + symtab_p <- tellBin bh -- This is where the symtab will start + putAt bh symtab_p_p symtab_p -- Fill in the placeholder + 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) + putSymbolTable bh symtab_next symtab_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next + <+> text "Names") + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + + -- Write the dictionary pointer at the fornt of the file + dict_p <- tellBin bh -- This is where the dictionary will start + putAt bh dict_p_p dict_p -- Fill in the placeholder + 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) + putDictionary bh dict_next dict_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") + + -- And send the result to the file + writeBinMem bh hi_path + +initBinMemSize = (1024*1024) :: Int + +-- The *host* architecture version: +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +binaryInterfaceMagic = 0x1face :: Word32 +#elif WORD_SIZE_IN_BITS == 64 +binaryInterfaceMagic = 0x1face64 :: Word32 +#endif + +-- ----------------------------------------------------------------------------- +-- The symbol table + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + 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 + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + let + arr = listArray (0,sz-1) names + (namecache', names) = + mapAccumR (fromOnDiskName arr) namecache od_names + -- + return (namecache', arr) + +type OnDiskName = (PackageId, ModuleName, OccName) + +fromOnDiskName + :: Array Int Name + -> NameCache + -> OnDiskName + -> (NameCache, Name) +fromOnDiskName arr nc (pid, mod_name, occ) = + let + mod = mkModule pid mod_name + cache = nsNames nc + in + case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let + us = nsUniqs nc + uniq = uniqFromSupply us + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache cache mod occ name + in + case splitUniqSupply us of { (us',_) -> + ( nc{ nsUniqs = us', nsNames = new_cache }, name ) + } + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name symtab = do + let mod = nameModule name + put_ bh (modulePackageId mod, moduleName mod, nameOccName name) + +-- ----------------------------------------------------------------------------- +-- All the binary instances -- BasicTypes {-! for IPName derive: Binary !-} @@ -97,8 +282,8 @@ instance Binary ModIface where mi_module = mod, mi_boot = is_boot, mi_mod_vers = mod_vers, - mi_package = _, -- we ignore the package on output mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -107,15 +292,16 @@ instance Binary ModIface where mi_deprecs = deprecs, mi_decls = decls, 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 put_ bh orphan + put_ bh hasFamInsts lazyPut bh deps lazyPut bh usages put_ bh exports @@ -124,33 +310,18 @@ instance Binary ModIface where lazyPut bh deprecs put_ bh decls put_ bh insts + 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 orphan <- get bh + hasFamInsts <- get bh deps <- lazyGet bh usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh @@ -159,14 +330,17 @@ instance Binary ModIface where 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 + vect_info <- get bh + hpc_info <- get bh return (ModIface { - mi_package = HomePackage, -- to be filled in properly later mi_module = mod_name, mi_boot = is_boot, mi_mod_vers = mod_vers, mi_orphan = orphan, + mi_finsts = hasFamInsts, mi_deps = deps, mi_usages = usages, mi_exports = exports, @@ -176,12 +350,15 @@ instance Binary ModIface where mi_decls = decls, mi_globals = Nothing, mi_insts = insts, + 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 }) + mi_dep_fn = mkIfaceDepCache deprecs, + mi_fix_fn = mkIfaceFixCache fixities, + mi_ver_fn = mkIfaceVerCache decls }) GLOBAL_VAR(v_IgnoreHiWay, False, Bool) @@ -200,11 +377,14 @@ instance Binary Dependencies where put_ bh deps = do put_ bh (dep_mods deps) put_ bh (dep_pkgs deps) put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) get bh = do ms <- get bh ps <- get bh os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) instance (Binary name) => Binary (GenAvailInfo name) where put_ bh (Avail aa) = do @@ -364,19 +544,9 @@ instance Binary Fixity where return (Fixity aa ab) instance (Binary name) => Binary (IPName name) where - put_ bh (Dupable aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Linear ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Dupable aa) - _ -> do ab <- get bh - return (Linear ab) + put_ bh (IPName aa) = put_ bh aa + get bh = do aa <- get bh + return (IPName aa) ------------------------------------------------------------------------- -- Types from: Demand @@ -514,36 +684,6 @@ instance Binary CostCentre where -- IfaceTypes and friends ------------------------------------------------------------------------- -instance Binary IfaceExtName where - put_ bh (ExtPkg mod occ) = do - putByte bh 0 - put_ bh mod - put_ bh occ - put_ bh (HomePkg mod occ vers) = do - putByte bh 1 - put_ bh mod - put_ bh occ - put_ bh vers - put_ bh (LocalTop occ) = do - putByte bh 2 - put_ bh occ - put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop - putByte bh 2 - put_ bh occ - - get bh = do - h <- getByte bh - case h of - 0 -> do mod <- get bh - occ <- get bh - return (ExtPkg mod occ) - 1 -> do mod <- get bh - occ <- get bh - vers <- get bh - return (HomePkg mod occ vers) - _ -> do occ <- get bh - return (LocalTop occ) - instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do putByte bh 0 @@ -559,31 +699,15 @@ instance Binary IfaceBndr where _ -> do ab <- get bh return (IfaceTvBndr ab) -instance Binary Kind where - put_ bh LiftedTypeKind = putByte bh 0 - put_ bh UnliftedTypeKind = putByte bh 1 - put_ bh UnboxedTypeKind = putByte bh 2 - put_ bh OpenTypeKind = putByte bh 3 - put_ bh ArgTypeKind = putByte bh 4 - put_ bh UbxTupleKind = putByte bh 5 - put_ bh (FunKind k1 k2) = do - putByte bh 6 - put_ bh k1 - put_ bh k2 - put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv) - - get bh = do - h <- getByte bh - case h of - 0 -> return LiftedTypeKind - 1 -> return UnliftedTypeKind - 2 -> return UnboxedTypeKind - 3 -> return OpenTypeKind - 4 -> return ArgTypeKind - 5 -> return UbxTupleKind - _ -> do k1 <- get bh - k2 <- get bh - return (FunKind k1 k2) +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 @@ -613,9 +737,17 @@ instance Binary IfaceType where -- Unit tuple and pairs put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10 put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 } + -- Kind cases + put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12 + put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13 + put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 + put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 + put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys } - put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys } + + put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys } + put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys } get bh = do h <- getByte bh @@ -641,7 +773,13 @@ instance Binary IfaceType where 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) } 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) []) 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) } - 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } + 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc []) + 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc []) + 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) + 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) + 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + + 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } instance Binary IfaceTyCon where @@ -652,8 +790,13 @@ instance Binary IfaceTyCon where put_ bh IfaceCharTc = putByte bh 3 put_ bh IfaceListTc = putByte bh 4 put_ bh IfacePArrTc = putByte bh 5 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext } + put_ bh IfaceLiftedTypeKindTc = putByte bh 6 + put_ bh IfaceOpenTypeKindTc = putByte bh 7 + put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 + put_ bh IfaceUbxTupleKindTc = putByte bh 9 + put_ bh IfaceArgTypeKindTc = putByte bh 10 + put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } get bh = do h <- getByte bh @@ -663,7 +806,12 @@ instance Binary IfaceTyCon where 3 -> return IfaceCharTc 4 -> return IfaceListTc 5 -> return IfacePArrTc - 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + 6 -> return IfaceLiftedTypeKindTc + 7 -> return IfaceOpenTypeKindTc + 8 -> return IfaceUnliftedTypeKindTc + 9 -> return IfaceUbxTupleKindTc + 10 -> return IfaceArgTypeKindTc + 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } _ -> do { ext <- get bh; return (IfaceTc ext) } instance Binary IfacePredType where @@ -675,15 +823,22 @@ instance Binary IfacePredType where putByte bh 1 put_ bh ac put_ bh ad + put_ bh (IfaceEqPred ac ad) = do + putByte bh 2 + put_ bh ac + put_ bh ad get bh = do h <- getByte bh case h of 0 -> do aa <- get bh ab <- get bh return (IfaceClassP aa ab) - _ -> do ac <- get bh + 1 -> do ac <- get bh ad <- get bh return (IfaceIParam ac ad) + 2 -> do ac <- get bh + ad <- get bh + return (IfaceEqPred ac ad) ------------------------------------------------------------------------- -- IfaceExpr and friends @@ -734,6 +889,14 @@ instance Binary IfaceExpr where put_ bh (IfaceExt aa) = do putByte bh 10 put_ bh aa + put_ bh (IfaceCast ie ico) = do + 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 @@ -768,8 +931,14 @@ instance Binary IfaceExpr where 9 -> do as <- get bh at <- get bh return (IfaceFCall as at) - _ -> do aa <- get bh - return (IfaceExt aa) + 10 -> do aa <- get bh + return (IfaceExt aa) + 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 @@ -863,9 +1032,6 @@ instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 put_ bh aa - put_ bh (IfaceCoerce ab) = do - putByte bh 1 - put_ bh ab put_ bh IfaceInlineMe = do putByte bh 3 put_ bh (IfaceCoreNote s) = do @@ -876,45 +1042,49 @@ instance Binary IfaceNote where case h of 0 -> do aa <- get bh return (IfaceSCC aa) - 1 -> do ab <- get bh - return (IfaceCoerce ab) 3 -> do return IfaceInlineMe - _ -> do ac <- get bh + 4 -> do ac <- get bh return (IfaceCoreNote ac) - ------------------------------------------------------------------------- -- IfaceDecl and friends ------------------------------------------------------------------------- +-- A bit of magic going on here: there's no need to store the OccName +-- for a decl on the disk, since we can infer the namespace from the +-- context; however it is useful to have the OccName in the IfaceDecl +-- to avoid re-building it in various places. So we build the OccName +-- when de-serialising. + instance Binary IfaceDecl where put_ bh (IfaceId name ty idinfo) = do putByte bh 0 - put_ bh name + put_ bh (occNameFS name) put_ bh ty put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 2 - put_ bh a1 + put_ bh (occNameFS a1) put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 put_ bh a7 - - put_ bh (IfaceSyn aq ar as at) = do + put_ bh a8 + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 - put_ bh 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 - put_ bh a2 + put_ bh (occNameFS a2) put_ bh a3 put_ bh a4 put_ bh a5 @@ -926,7 +1096,8 @@ instance Binary IfaceDecl where 0 -> do name <- get bh ty <- get bh idinfo <- get bh - return (IfaceId name ty idinfo) + occ <- return $! mkOccNameFS varName name + return (IfaceId occ ty idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- get bh @@ -936,13 +1107,17 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7) + a8 <- get bh + 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 - return (IfaceSyn aq 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 @@ -951,7 +1126,8 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceClass a1 a2 a3 a4 a5 a6 a7) + occ <- return $! mkOccNameFS clsName a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7) instance Binary IfaceInst where put_ bh (IfaceInst cls tys dfun flag orph) = do @@ -967,6 +1143,16 @@ instance Binary IfaceInst where orph <- get bh return (IfaceInst cls tys dfun flag orph) +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys tycon) = do + put_ bh fam + put_ bh tys + put_ bh tycon + get bh = do fam <- get bh + tys <- get bh + tycon <- get bh + return (IfaceFamInst fam tys tycon) + instance Binary OverlapFlag where put_ bh NoOverlap = putByte bh 0 put_ bh OverlapOk = putByte bh 1 @@ -979,62 +1165,54 @@ instance Binary OverlapFlag where instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = do { putByte bh 1 + put_ bh IfOpenDataTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs) = do { putByte bh 2 ; put_ bh cs } - put_ bh (IfNewTyCon c) = do { putByte bh 2 + put_ bh (IfNewTyCon c) = do { putByte bh 3 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do cs <- get bh + 1 -> return IfOpenDataTyCon + 2 -> do cs <- get bh return (IfDataTyCon cs) _ -> do aa <- get bh return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do - putByte bh 0 - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do - putByte bh 1 + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 - get bh = do - h <- getByte bh - case h of - 0 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfVanillaCon a1 a2 a3 a4 a5) - _ -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - return (IfGadtCon a1 a2 a3 a4 a5 a6) + put_ bh a7 + put_ bh a8 + put_ bh a9 + get bh = do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do - put_ bh n + put_ bh (occNameFS n) put_ bh def put_ bh ty get bh = do n <- get bh def <- get bh ty <- get bh - return (IfaceClassOp n def ty) + occ <- return $! mkOccNameFS varName n + return (IfaceClassOp occ def ty) instance Binary IfaceRule where put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do @@ -1055,4 +1233,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) +