X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=502eefa57842cc5248cffb97b9f61e1c503deb2e;hp=13be0491c048d8f69b751fb218b743be42a56e14;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=3e0b6b2542d8464bfba365b97a6e4b95c3885f10 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 13be049..502eefa 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,54 +1,328 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} --- --- (c) The University of Glasgow 2002 --- +{-# 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, v_IgnoreHiWay ) where +module BinIface ( writeBinIface, readBinIface, + CheckHiWay(..), TraceBinIFaceReading(..) ) where #include "HsVersions.h" +import TcRnMonad +import IfaceEnv import HscTypes import BasicTypes -import NewDemand +import Demand +import Annotations +import CoreSyn import IfaceSyn +import Module +import Name import VarEnv -import InstEnv ( OverlapFlag(..) ) -import Class ( DefMeth(..) ) +import DynFlags +import UniqFM +import UniqSupply import CostCentre -import StaticFlags ( opt_HiVersion, v_Build_tag ) -import Type ( Kind, - isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isArgTypeKind, isUbxTupleKind, liftedTypeKind, - unliftedTypeKind, openTypeKind, argTypeKind, - ubxTupleKind, mkArrowKind, splitFunTy_maybe ) +import StaticFlags import Panic import Binary -import Util -import Config ( cGhcUnregisterised ) - -import DATA_IOREF -import EXCEPTION ( throwDyn ) -import Monad ( when ) +import SrcLoc +import ErrUtils +import Config +import FastMutInt +import Unique import Outputable +import FastString +import Constants -#include "HsVersions.h" - --- --------------------------------------------------------------------------- -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path mod_iface +import Data.List +import Data.Word +import Data.Array +import Data.IORef +import Control.Monad -readBinIface :: FilePath -> IO ModIface -readBinIface hi_path = getBinFileWithDict hi_path +data CheckHiWay = CheckHiWay | IgnoreHiWay + deriving Eq +data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading + deriving Eq --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* +-- --------------------------------------------------------------------------- +-- Reading and writing binary interface files + +readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath + -> TcRnIf a b ModIface +readBinIface checkHiWay traceBinIFaceReading hi_path = 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 + 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) + magic <- get bh + wantedGot "Magic" binaryInterfaceMagic magic + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + binaryInterfaceMagic magic + + -- Note [dummy iface field] + -- read a dummy 32/64 bit value. This field used to hold the + -- dictionary pointer in old interface file formats, but now + -- the dictionary pointer is after the version (where it + -- should be). Also, the serialisation of value of type "Bin + -- a" used to depend on the word size of the machine, now they + -- are always 32 bits. + -- + if wORD_SIZE == 4 + then do _ <- Binary.get bh :: IO Word32; return () + else do _ <- Binary.get bh :: IO Word64; return () + + -- Check the interface file version and ways. + check_ver <- get bh + let our_ver = show opt_HiVersion + wantedGot "Version" our_ver check_ver + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_way <- get bh + let way_descr = getWayDescr dflags + 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) + dict_p <- Binary.get bh + 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 + 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 iface + + +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + put_ bh binaryInterfaceMagic + + -- dummy 32/64-bit field before the version/way for + -- compatibility with older interface file formats. + -- See Note [dummy iface field] above. + if wORD_SIZE == 4 + then Binary.put_ bh (0 :: Word32) + else Binary.put_ bh (0 :: Word64) + + -- The version and way descriptor go next + put_ bh (show opt_HiVersion) + let way_descr = getWayDescr dflags + put_ bh way_descr + + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + put_ bh dict_p_p -- Placeholder for ptr to dictionary + + -- Remember where the symbol table pointer will go + symtab_p_p <- tellBin bh + put_ bh symtab_p_p + + -- Make some intial state + 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 + 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 symtab_next + symtab_map <- readIORef symtab_map + 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 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") + + -- And send the result to the file + writeBinMem bh hi_path + +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +-- The *host* architecture version: +#include "../includes/MachDeps.h" + +binaryInterfaceMagic :: Word32 +#if WORD_SIZE_IN_BITS == 32 +binaryInterfaceMagic = 0x1face +#elif WORD_SIZE_IN_BITS == 64 +binaryInterfaceMagic = 0x1face64 +#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 -> NameCacheUpdater (Array Int Name) + -> IO (Array Int Name) +getSymbolTable bh update_namecache = do + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + update_namecache $ \namecache -> + let + arr = listArray (0,sz-1) names + (namecache', names) = + mapAccumR (fromOnDiskName arr) namecache od_names + in (namecache', arr) + +type OnDiskName = (PackageId, ModuleName, OccName) + +fromOnDiskName + :: Array Int Name + -> NameCache + -> OnDiskName + -> (NameCache, Name) +fromOnDiskName _ 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 -> + case takeUniqFromSupply (nsUniqs nc) of + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache cache mod occ name + in + ( nc{ nsUniqs = us, nsNames = new_cache }, name ) + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +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 (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + + +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 (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + 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 -- BasicTypes {-! for IPName derive: Binary !-} @@ -58,7 +332,7 @@ readBinIface hi_path = getBinFileWithDict hi_path {-! for StrictnessMark derive: Binary !-} {-! for Activation derive: Binary !-} --- NewDemand +-- Demand {-! for Demand derive: Binary !-} {-! for Demands derive: Binary !-} {-! for DmdResult derive: Binary !-} @@ -99,97 +373,98 @@ 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_anns = anns, 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_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 + lazyPut bh anns 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 - 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 + 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 + 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 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_anns = anns, 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_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 - if cGhcUnregisterised == "YES" then return ('u':tag) else return tag + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls }) + +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. @@ -201,11 +476,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 @@ -225,40 +503,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 a => Binary (Deprecs a) 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 @@ -285,25 +588,57 @@ instance Binary Activation where _ -> do ab <- get bh return (ActiveAfter ab) -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 +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 a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma a b c d) + +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary HsBang where + put_ bh HsNoBang = putByte bh 0 + put_ bh HsStrict = putByte bh 1 + put_ bh HsUnpack = putByte bh 2 + put_ bh HsUnpackFailed = putByte bh 3 get bh = do h <- getByte bh case h of - 0 -> do return MarkedStrict - 1 -> do return MarkedUnboxed - _ -> do return NotMarkedStrict + 0 -> do return HsNoBang + 1 -> do return HsStrict + 2 -> do return HsUnpack + _ -> do return HsUnpackFailed 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 @@ -330,16 +665,16 @@ instance Binary RecFlag where 0 -> do return Recursive _ -> do return NonRecursive -instance Binary DefMeth where - put_ bh NoDefMeth = putByte bh 0 - put_ bh DefMeth = putByte bh 1 - put_ bh GenDefMeth = putByte bh 2 +instance Binary DefMethSpec where + put_ bh NoDM = putByte bh 0 + put_ bh VanillaDM = putByte bh 1 + put_ bh GenericDM = putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> return NoDefMeth - 1 -> return DefMeth - _ -> return GenDefMeth + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM instance Binary FixityDirection where put_ bh InfixL = do @@ -365,19 +700,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 @@ -385,7 +710,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 @@ -515,36 +840,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 @@ -560,6 +855,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 @@ -594,12 +899,14 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14 put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15 put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16 + put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases - 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 } + put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys } + get bh = do h <- getByte bh case h of @@ -629,13 +936,14 @@ instance Binary IfaceType where 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc []) 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc []) 16 -> return (IfaceTyConApp IfaceArgTypeKindTc []) + 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } - _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 put_ bh IfaceBoolTc = putByte bh 2 put_ bh IfaceCharTc = putByte bh 3 @@ -646,8 +954,9 @@ instance Binary IfaceTyCon where 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 } + 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 } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@ -663,7 +972,28 @@ instance Binary IfaceTyCon where 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) } + 12 -> do { ext <- get bh; return (IfaceTc ext) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } + +instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceCoAx n) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + _ -> do { d <- get bh; return (IfaceNthCo d) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -690,6 +1020,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 @@ -702,48 +1033,52 @@ instance Binary IfaceExpr where put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab - put_ bh (IfaceTuple ac ad) = do + put_ bh (IfaceCo ab) = do putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam ae af) = do - putByte bh 3 + putByte bh 4 put_ bh ae put_ bh af put_ bh (IfaceApp ag ah) = do - putByte bh 4 + putByte bh 5 put_ bh ag put_ bh ah --- gaw 2004 - put_ bh (IfaceCase ai aj al ak) = do - putByte bh 5 + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 put_ bh ai put_ bh aj --- gaw 2004 - put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do - putByte bh 6 + putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceNote an ao) = do - putByte bh 7 + putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do - putByte bh 8 + putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do - putByte bh 9 + putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do - putByte bh 10 + putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do - putByte bh 11 + putByte bh 12 put_ bh ie put_ bh ico + put_ bh (IfaceTick m ix) = do + putByte bh 13 + put_ bh m + put_ bh ix get bh = do h <- getByte bh case h of @@ -751,38 +1086,41 @@ instance Binary IfaceExpr where return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) - 2 -> do ac <- get bh + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) - 3 -> do ae <- get bh + 4 -> do ae <- get bh af <- get bh return (IfaceLam ae af) - 4 -> do ag <- get bh + 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) - 5 -> do ai <- get bh + 6 -> do ai <- get bh aj <- get bh --- gaw 2004 - al <- get bh ak <- get bh --- gaw 2004 - return (IfaceCase ai aj al ak) - 6 -> do al <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh am <- get bh return (IfaceLet al am) - 7 -> do an <- get bh + 8 -> do an <- get bh ao <- get bh return (IfaceNote an ao) - 8 -> do ap <- get bh + 9 -> do ap <- get bh return (IfaceLit ap) - 9 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 10 -> do aa <- get bh + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh return (IfaceExt aa) - 11 -> do ie <- get bh + 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) + 13 -> do m <- get bh + ix <- get bh + return (IfaceTick m ix) + _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceConAlt where put_ bh IfaceDefault = do @@ -824,6 +1162,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 n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do a <- get bh + b <- get bh + return (IfRecSelId a b) + _ -> do { n <- get bh; return (IfDFunId n) } + instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do @@ -844,18 +1195,15 @@ instance Binary IfaceInfoItem where put_ bh (HsStrictness ab) = do putByte bh 1 put_ bh ab - put_ bh (HsUnfold ad) = do + put_ bh (HsUnfold lb ad) = do putByte bh 2 + put_ bh lb put_ bh ad put_ bh (HsInline ad) = do putByte bh 3 put_ bh ad put_ bh HsNoCafRefs = do putByte bh 4 - put_ bh (HsWorker ae af) = do - putByte bh 5 - put_ bh ae - put_ bh af get bh = do h <- getByte bh case h of @@ -863,21 +1211,74 @@ instance Binary IfaceInfoItem where return (HsArity aa) 1 -> do ab <- get bh return (HsStrictness ab) - 2 -> do ad <- get bh - return (HsUnfold ad) + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) 3 -> do ad <- get bh return (HsInline ad) - 4 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) + _ -> do return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfLclWrapper a n) = do + putByte bh 2 + put_ bh a + put_ bh n + put_ bh (IfExtWrapper a n) = do + putByte bh 3 + put_ bh a + put_ bh n + put_ bh (IfDFunUnfold as) = do + putByte bh 4 + put_ bh as + put_ bh (IfCompulsory e) = do + putByte bh 5 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do a <- get bh + n <- get bh + return (IfLclWrapper a n) + 3 -> do a <- get bh + n <- get bh + return (IfExtWrapper a n) + 4 -> do as <- get bh + return (IfDFunUnfold as) + _ -> do e <- get bh + return (IfCompulsory e) + +instance Binary (DFunArg IfaceExpr) where + put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e + put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e + put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh; return (DFunPolyArg a) } + 1 -> do { a <- get bh; return (DFunConstArg a) } + _ -> do { a <- get bh; return (DFunLamArg a) } } instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 put_ bh aa - put_ bh IfaceInlineMe = do - putByte bh 3 put_ bh (IfaceCoreNote s) = do putByte bh 4 put_ bh s @@ -886,53 +1287,63 @@ instance Binary IfaceNote where case h of 0 -> do aa <- get bh return (IfaceSCC aa) - 3 -> do return IfaceInlineMe 4 -> do ac <- get bh return (IfaceCoreNote ac) - + _ -> panic ("get IfaceNote " ++ show h) ------------------------------------------------------------------------- -- 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 + put_ bh (IfaceId name ty details idinfo) = do putByte bh 0 - put_ bh name + put_ bh (occNameFS name) put_ bh ty + put_ bh details 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) = 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) = do + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 - put_ bh aq - put_ bh ar - put_ bh as - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do + 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 put_ bh a6 + put_ bh a7 get bh = do h <- getByte bh case h of - 0 -> do name <- get bh - ty <- get bh - idinfo <- get bh - return (IfaceId name ty idinfo) + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkOccNameFS varName name + return (IfaceId occ ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- get bh @@ -942,12 +1353,16 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7) + occ <- return $! mkOccNameFS tcName a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7) 3 -> do - aq <- get bh - ar <- get bh - as <- get bh - return (IfaceSyn aq ar as) + 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 @@ -955,7 +1370,9 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceClass a1 a2 a3 a4 a5 a6) + a7 <- get bh + 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 @@ -971,6 +1388,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 @@ -980,24 +1407,27 @@ 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 - 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 (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 @@ -1007,6 +1437,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 @@ -1016,21 +1447,23 @@ 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 - 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 + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1038,6 +1471,7 @@ instance Binary IfaceRule where put_ bh a5 put_ bh a6 put_ bh a7 + put_ bh a8 get bh = do a1 <- get bh a2 <- get bh @@ -1046,6 +1480,46 @@ instance Binary IfaceRule where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7) + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +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 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5)