/compiler/iface/BinIface.hs
Haskell | 1614 lines | 1299 code | 158 blank | 157 comment | 11 complexity | 94e393225be002d58e44f1c98a985d2d MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0
- --
- -- (c) The University of Glasgow 2002-2006
- --
- {-# OPTIONS_GHC -O #-}
- -- We always optimise this, otherwise performance of a non-optimised
- -- compiler is severely affected
- -- | Binary interface file support.
- module BinIface (
- writeBinIface,
- readBinIface,
- getSymtabName,
- getDictFastString,
- CheckHiWay(..),
- TraceBinIFaceReading(..)
- ) where
- #include "HsVersions.h"
- import TcRnMonad
- import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon, tyConIP_maybe)
- import DataCon (dataConName, dataConWorkId, dataConTyCon)
- import IParam (ipFastString, ipTyConName)
- import PrelInfo (wiredInThings, basicKnownKeyNames)
- import Id (idName, isDataConWorkId_maybe)
- import TysWiredIn
- import IfaceEnv
- import HscTypes
- import BasicTypes
- import Demand
- import Annotations
- import IfaceSyn
- import Module
- import Name
- import Avail
- import VarEnv
- import DynFlags
- import UniqFM
- import UniqSupply
- import CostCentre
- import StaticFlags
- import Panic
- import Binary
- import SrcLoc
- import ErrUtils
- import Config
- import FastMutInt
- import Unique
- import Outputable
- import Platform
- import FastString
- import Constants
- import Data.Bits
- import Data.Char
- import Data.List
- import Data.Word
- import Data.Array
- import Data.IORef
- import Control.Monad
- import System.Time ( ClockTime(..) )
- -- ---------------------------------------------------------------------------
- -- Reading and writing binary interface files
- --
- data CheckHiWay = CheckHiWay | IgnoreHiWay
- deriving Eq
- data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
- deriving Eq
- -- | Read an interface file
- readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
- -> TcRnIf a b ModIface
- readBinIface checkHiWay traceBinIFaceReading hi_path = do
- ncu <- mkNameCacheUpdater
- dflags <- getDOpts
- liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
- readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
- -> NameCacheUpdater
- -> IO ModIface
- readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = 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 dflags) magic
- errorOnMismatch "magic number mismatch: old/corrupt interface file?"
- (binaryInterfaceMagic dflags) 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
- bh <- do
- bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
- (getDictFastString dict)
- 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 ncu
- seekBin bh data_p -- Back to where we were before
-
- -- It is only now that we know how to get a Name
- return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
- (getDictFastString dict)
- -- Read the interface file
- get bh
- -- | Write an interface file
- writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
- writeBinIface dflags hi_path mod_iface = do
- bh <- openBinMem initBinMemSize
- put_ bh (binaryInterfaceMagic dflags)
- -- 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
- -- Placeholder for ptr to dictionary
- put_ bh dict_p_p
- -- 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 }
-
- -- Put the main thing,
- bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
- (putFastString bin_dict)
- 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
- -- | Initial ram buffer to allocate for writing interface files
- initBinMemSize :: Int
- initBinMemSize = 1024 * 1024
- binaryInterfaceMagic :: DynFlags -> Word32
- binaryInterfaceMagic dflags
- | target32Bit (targetPlatform dflags) = 0x1face
- | otherwise = 0x1face64
- -- -----------------------------------------------------------------------------
- -- 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 -> IO SymbolTable
- getSymbolTable bh ncu = do
- sz <- get bh
- od_names <- sequence (replicate sz (get bh))
- updateNameCache ncu $ \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 ->
- let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
- 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)
- -- Note [Symbol table representation of names]
- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- --
- -- An occurrence of a name in an interface file is serialized as a single 32-bit word.
- -- The format of this word is:
- -- 00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
- -- A normal name. x is an index into the symbol table
- -- 01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy
- -- A known-key name. x is the Unique's Char, y is the int part
- -- 10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz
- -- A tuple name:
- -- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint)
- -- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker)
- -- z is the arity
- -- 11xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
- -- An implicit parameter TyCon name. x is an index into the FastString *dictionary*
- --
- -- Note that we have to have special representation for tuples and IP TyCons because they
- -- form an "infinite" family and hence are not recorded explicitly in wiredInTyThings or
- -- basicKnownKeyNames.
- knownKeyNamesMap :: UniqFM Name
- knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
- where
- knownKeyNames :: [Name]
- knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames
- -- See Note [Symbol table representation of names]
- putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
- putName dict BinSymbolTable{
- bin_symtab_map = symtab_map_ref,
- bin_symtab_next = symtab_next } bh name
- | name `elemUFM` knownKeyNamesMap
- , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
- = -- ASSERT(u < 2^(22 :: Int))
- put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32))
- | otherwise
- = case wiredInNameTyThing_maybe name of
- Just (ATyCon tc)
- | isTupleTyCon tc -> putTupleName_ bh tc 0
- | Just ip <- tyConIP_maybe tc -> do
- off <- allocateFastString dict (ipFastString ip)
- -- MASSERT(off < 2^(30 :: Int))
- put_ bh (0xC0000000 .|. off)
- Just (ADataCon dc)
- | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
- Just (AnId x)
- | Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2
- _ -> 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
- -- MASSERT(off < 2^(30 :: Int))
- writeFastMutInt symtab_next (off+1)
- writeIORef symtab_map_ref
- $! addToUFM symtab_map name (off,name)
- put_ bh (fromIntegral off :: Word32)
- putTupleName_ :: BinHandle -> TyCon -> Word32 -> IO ()
- putTupleName_ bh tc thing_tag
- = -- ASSERT(arity < 2^(30 :: Int))
- put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity)
- where
- arity = fromIntegral (tupleTyConArity tc)
- sort_tag = case tupleTyConSort tc of
- BoxedTuple -> 0
- UnboxedTuple -> 1
- ConstraintTuple -> 2
- -- See Note [Symbol table representation of names]
- getSymtabName :: NameCacheUpdater
- -> Dictionary -> SymbolTable
- -> BinHandle -> IO Name
- getSymtabName ncu dict symtab bh = do
- i <- get bh
- case i .&. 0xC0000000 of
- 0x00000000 -> return $! symtab ! fromIntegral (i ::  Word32)
- 0x40000000 -> return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of
- Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i)
- Just n -> n
- where tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
- ix = fromIntegral i .&. 0x003FFFFF
- 0x80000000 -> return $! case thing_tag of
- 0 -> tyConName (tupleTyCon sort arity)
- 1 -> dataConName dc
- 2 -> idName (dataConWorkId dc)
- _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i)
- where
- dc = tupleCon sort arity
- sort = case (i .&. 0x30000000) `shiftR` 28 of
- 0 -> BoxedTuple
- 1 -> UnboxedTuple
- 2 -> ConstraintTuple
- _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
- thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26
- arity = fromIntegral (i .&. 0x03FFFFFF)
- 0xC0000000 -> liftM ipTyConName $ updateNameCache ncu $ flip allocateIPName (dict ! fromIntegral (i .&. 0x3FFFFFFF))
- _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
- 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 dict bh fs = allocateFastString dict fs >>= put_ bh
- allocateFastString :: BinDictionary -> FastString -> IO Word32
- allocateFastString BinDictionary { bin_dict_next = j_r,
- bin_dict_map = out_r} f = do
- out <- readIORef out_r
- let uniq = getUnique f
- case lookupUFM out uniq of
- Just (j, _) -> return (fromIntegral j :: Word32)
- Nothing -> do
- j <- readFastMutInt j_r
- writeFastMutInt j_r (j + 1)
- writeIORef out_r $! addToUFM out uniq (j, f)
- return (fromIntegral j :: Word32)
- getDictFastString :: Dictionary -> BinHandle -> IO FastString
- getDictFastString dict bh = do
- j <- get bh
- return $! (dict ! fromIntegral (j :: Word32))
- 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 !-}
- {-! for Fixity derive: Binary !-}
- {-! for FixityDirection derive: Binary !-}
- {-! for Boxity derive: Binary !-}
- {-! for StrictnessMark derive: Binary !-}
- {-! for Activation derive: Binary !-}
- -- Demand
- {-! for Demand derive: Binary !-}
- {-! for Demands derive: Binary !-}
- {-! for DmdResult derive: Binary !-}
- {-! for StrictSig derive: Binary !-}
- -- Class
- {-! for DefMeth derive: Binary !-}
- -- HsTypes
- {-! for HsPred derive: Binary !-}
- {-! for HsType derive: Binary !-}
- {-! for TupCon derive: Binary !-}
- {-! for HsTyVarBndr derive: Binary !-}
- -- HsCore
- {-! for UfExpr derive: Binary !-}
- {-! for UfConAlt derive: Binary !-}
- {-! for UfBinding derive: Binary !-}
- {-! for UfBinder derive: Binary !-}
- {-! for HsIdInfo derive: Binary !-}
- {-! for UfNote derive: Binary !-}
- -- HsDecls
- {-! for ConDetails derive: Binary !-}
- {-! for BangType derive: Binary !-}
- -- CostCentre
- {-! for IsCafCC derive: Binary !-}
- {-! for CostCentre derive: Binary !-}
- -- ---------------------------------------------------------------------------
- -- Reading a binary interface into ParsedIface
- instance Binary ModIface where
- put_ bh (ModIface {
- mi_module = mod,
- mi_boot = is_boot,
- mi_iface_hash= iface_hash,
- mi_mod_hash = mod_hash,
- mi_flag_hash = flag_hash,
- mi_orphan = orphan,
- mi_finsts = hasFamInsts,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_exp_hash = exp_hash,
- mi_used_th = used_th,
- mi_fixities = fixities,
- mi_warns = warns,
- mi_anns = anns,
- mi_decls = decls,
- mi_insts = insts,
- mi_fam_insts = fam_insts,
- mi_rules = rules,
- mi_orphan_hash = orphan_hash,
- mi_vect_info = vect_info,
- mi_hpc = hpc_info,
- mi_trust = trust,
- mi_trust_pkg = trust_pkg }) = do
- put_ bh mod
- put_ bh is_boot
- put_ bh iface_hash
- put_ bh mod_hash
- put_ bh flag_hash
- put_ bh orphan
- put_ bh hasFamInsts
- lazyPut bh deps
- lazyPut bh usages
- put_ bh exports
- put_ bh exp_hash
- put_ bh used_th
- put_ bh fixities
- lazyPut bh warns
- lazyPut bh anns
- put_ bh decls
- put_ bh insts
- put_ bh fam_insts
- lazyPut bh rules
- put_ bh orphan_hash
- put_ bh vect_info
- put_ bh hpc_info
- put_ bh trust
- put_ bh trust_pkg
- get bh = do
- mod_name <- get bh
- is_boot <- get bh
- iface_hash <- get bh
- mod_hash <- get bh
- flag_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_hash <- get bh
- used_th <- get bh
- fixities <- {-# SCC "bin_fixities" #-} get 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
- orphan_hash <- get bh
- vect_info <- get bh
- hpc_info <- get bh
- trust <- get bh
- trust_pkg <- get bh
- return (ModIface {
- mi_module = mod_name,
- mi_boot = is_boot,
- mi_iface_hash = iface_hash,
- mi_mod_hash = mod_hash,
- mi_flag_hash = flag_hash,
- mi_orphan = orphan,
- mi_finsts = hasFamInsts,
- mi_deps = deps,
- mi_usages = usages,
- mi_exports = exports,
- mi_exp_hash = exp_hash,
- mi_used_th = used_th,
- mi_anns = anns,
- mi_fixities = fixities,
- mi_warns = warns,
- mi_decls = decls,
- mi_globals = Nothing,
- mi_insts = insts,
- mi_fam_insts = fam_insts,
- mi_rules = rules,
- mi_orphan_hash = orphan_hash,
- mi_vect_info = vect_info,
- mi_hpc = hpc_info,
- mi_trust = trust,
- mi_trust_pkg = trust_pkg,
- -- And build the cached values
- 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.
- -------------------------------------------------------------------------
- -- Types from: HscTypes
- -------------------------------------------------------------------------
- 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
- fis <- get bh
- return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
- dep_finsts = fis })
- instance Binary AvailInfo where
- put_ bh (Avail aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (AvailTC ab ac) = do
- putByte bh 1
- put_ bh ab
- put_ bh ac
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (Avail aa)
- _ -> do ab <- get bh
- ac <- get bh
- return (AvailTC ab ac)
-
- -- where should this be located?
- instance Binary ClockTime where
- put_ bh (TOD x y) = put_ bh x >> put_ bh y
-
- get bh = do
- x <- get bh
- y <- get bh
- return $ TOD x y
- instance Binary Usage where
- put_ bh usg@UsagePackageModule{} = do
- putByte bh 0
- put_ bh (usg_mod usg)
- put_ bh (usg_mod_hash usg)
- put_ bh (usg_safe 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_safe usg)
- put_ bh usg@UsageFile{} = do
- putByte bh 2
- put_ bh (usg_file_path usg)
- put_ bh (usg_mtime usg)
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do
- nm <- get bh
- mod <- get bh
- safe <- get bh
- return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
- 1 -> do
- nm <- get bh
- mod <- get bh
- exps <- get bh
- ents <- get bh
- safe <- get bh
- return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
- usg_exports = exps, usg_entities = ents, usg_safe = safe }
- 2 -> do
- fp <- get bh
- mtime <- get bh
- return UsageFile { usg_file_path = fp, usg_mtime = mtime }
- i -> error ("Binary.get(Usage): " ++ show i)
- 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 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
- -------------------------------------------------------------------------
- instance Binary Activation where
- put_ bh NeverActive = do
- putByte bh 0
- put_ bh AlwaysActive = do
- putByte bh 1
- put_ bh (ActiveBefore aa) = do
- putByte bh 2
- put_ bh aa
- put_ bh (ActiveAfter ab) = do
- putByte bh 3
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return NeverActive
- 1 -> do return AlwaysActive
- 2 -> do aa <- get bh
- return (ActiveBefore aa)
- _ -> 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 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
- put_ bh HsNoUnpack = putByte bh 4
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return HsNoBang
- 1 -> do return HsStrict
- 2 -> do return HsUnpack
- 3 -> do return HsUnpackFailed
- _ -> do return HsNoUnpack
- instance Binary TupleSort where
- put_ bh BoxedTuple = putByte bh 0
- put_ bh UnboxedTuple = putByte bh 1
- put_ bh ConstraintTuple = putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return BoxedTuple
- 1 -> do return UnboxedTuple
- _ -> do return ConstraintTuple
- instance Binary RecFlag where
- put_ bh Recursive = do
- putByte bh 0
- put_ bh NonRecursive = do
- putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return Recursive
- _ -> do return NonRecursive
- 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 NoDM
- 1 -> return VanillaDM
- _ -> return GenericDM
- instance Binary FixityDirection where
- put_ bh InfixL = do
- putByte bh 0
- put_ bh InfixR = do
- putByte bh 1
- put_ bh InfixN = do
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return InfixL
- 1 -> do return InfixR
- _ -> do return InfixN
- instance Binary Fixity where
- put_ bh (Fixity aa ab) = do
- put_ bh aa
- put_ bh ab
- get bh = do
- aa <- get bh
- ab <- get bh
- return (Fixity aa ab)
- instance (Binary name) => Binary (IPName name) where
- put_ bh (IPName aa) = put_ bh aa
- get bh = do aa <- get bh
- return (IPName aa)
- -------------------------------------------------------------------------
- -- Types from: Demand
- -------------------------------------------------------------------------
- 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)
- get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
- instance Binary Demand where
- put_ bh Top = do
- putByte bh 0
- put_ bh Abs = do
- putByte bh 1
- put_ bh (Call aa) = do
- putByte bh 2
- put_ bh aa
- put_ bh (Eval ab) = do
- putByte bh 3
- put_ bh ab
- put_ bh (Defer ac) = do
- putByte bh 4
- put_ bh ac
- put_ bh (Box ad) = do
- putByte bh 5
- put_ bh ad
- put_ bh Bot = do
- putByte bh 6
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return Top
- 1 -> do return Abs
- 2 -> do aa <- get bh
- return (Call aa)
- 3 -> do ab <- get bh
- return (Eval ab)
- 4 -> do ac <- get bh
- return (Defer ac)
- 5 -> do ad <- get bh
- return (Box ad)
- _ -> do return Bot
- instance Binary Demands where
- put_ bh (Poly aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (Prod ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (Poly aa)
- _ -> do ab <- get bh
- return (Prod ab)
- instance Binary DmdResult where
- put_ bh TopRes = do
- putByte bh 0
- put_ bh RetCPR = do
- putByte bh 1
- put_ bh BotRes = do
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return TopRes
- 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
- -- The wrapper was generated for CPR in
- -- the imported module!
- _ -> do return BotRes
- instance Binary StrictSig where
- put_ bh (StrictSig aa) = do
- put_ bh aa
- get bh = do
- aa <- get bh
- return (StrictSig aa)
- -------------------------------------------------------------------------
- -- Types from: CostCentre
- -------------------------------------------------------------------------
- instance Binary IsCafCC where
- put_ bh CafCC = do
- putByte bh 0
- put_ bh NotCafCC = do
- putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return CafCC
- _ -> do return NotCafCC
- instance Binary CostCentre where
- put_ bh (NormalCC aa ab ac _ad ae) = do
- putByte bh 0
- put_ bh aa
- put_ bh ab
- put_ bh ac
- put_ bh ae
- put_ bh (AllCafsCC ae _af) = do
- putByte bh 1
- put_ bh ae
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- ab <- get bh
- ac <- get bh
- ae <- get bh
- return (NormalCC aa ab ac noSrcSpan ae)
- _ -> do ae <- get bh
- return (AllCafsCC ae noSrcSpan)
- -- We ignore the SrcSpans in CostCentres when we serialise them,
- -- and set the SrcSpans to noSrcSpan when deserialising. This is
- -- ok, because we only need the SrcSpan when declaring the
- -- CostCentre in the original module, it is not used by importing
- -- modules.
- -------------------------------------------------------------------------
- -- IfaceTypes and friends
- -------------------------------------------------------------------------
- instance Binary IfaceBndr where
- put_ bh (IfaceIdBndr aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (IfaceTvBndr ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (IfaceIdBndr aa)
- _ -> 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
- put_ bh aa
- put_ bh ab
- put_ bh (IfaceTyVar ad) = do
- putByte bh 1
- put_ bh ad
- put_ bh (IfaceAppTy ae af) = do
- putByte bh 2
- put_ bh ae
- put_ bh af
- put_ bh (IfaceFunTy ag ah) = do
- putByte bh 3
- put_ bh ag
- put_ bh ah
-
- -- Simple compression for common cases of TyConApp
- put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
- put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
- put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
- put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
- -- Unit tuple and pairs
- put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
- put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 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
- put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 17
- put_ bh (IfaceTyConApp IfaceSuperKindTc []) = putByte bh 18
- put_ bh (IfaceCoConApp cc tys)
- = do { putByte bh 19; put_ bh cc; put_ bh tys }
- -- Generic cases
- put_ bh (IfaceTyConApp (IfaceTc tc) tys)
- = do { putByte bh 20; put_ bh tc; put_ bh tys }
- put_ bh (IfaceTyConApp tc tys)
- = do { putByte bh 21; put_ bh tc; put_ bh tys }
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- ab <- get bh
- return (IfaceForAllTy aa ab)
- 1 -> do ad <- get bh
- return (IfaceTyVar ad)
- 2 -> do ae <- get bh
- af <- get bh
- return (IfaceAppTy ae af)
- 3 -> do ag <- get bh
- ah <- get bh
- return (IfaceFunTy ag ah)
-
- -- Now the special cases for TyConApp
- 6 -> return (IfaceTyConApp IfaceIntTc [])
- 7 -> return (IfaceTyConApp IfaceCharTc [])
- 8 -> return (IfaceTyConApp IfaceBoolTc [])
- 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
- 10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
- 11 -> do { t1 <- get bh; t2 <- get bh
- ; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
- 12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
- 13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
- 14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
- 15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
- 16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
- 17 -> return (IfaceTyConApp IfaceConstraintKindTc [])
- 18 -> return (IfaceTyConApp IfaceSuperKindTc [])
- 19 -> do { cc <- get bh; tys <- get bh
- ; return (IfaceCoConApp cc tys) }
- 20 -> do { tc <- get bh; tys <- get bh
- ; return (IfaceTyConApp (IfaceTc tc) tys) }
- 21 -> do { tc <- get bh; tys <- get bh
- ; return (IfaceTyConApp tc tys) }
- _ -> panic ("get IfaceType " ++ show h)
- 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
- put_ bh IfaceListTc = putByte bh 4
- put_ bh IfacePArrTc = putByte bh 5
- 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 IfaceConstraintKindTc = putByte bh 11
- put_ bh IfaceSuperKindTc = putByte bh 12
- put_ bh (IfaceTupTc bx ar) = do { putByte bh 13; put_ bh bx; put_ bh ar }
- put_ bh (IfaceTc ext) = do { putByte bh 14; put_ bh ext }
- put_ bh (IfaceIPTc n) = do { putByte bh 15; put_ bh n }
- get bh = do
- h <- getByte bh
- case h of
- 1 -> return IfaceIntTc
- 2 -> return IfaceBoolTc
- 3 -> return IfaceCharTc
- 4 -> return IfaceListTc
- 5 -> return IfacePArrTc
- 6 -> return IfaceLiftedTypeKindTc
- 7 -> return IfaceOpenTypeKindTc
- 8 -> return IfaceUnliftedTypeKindTc
- 9 -> return IfaceUbxTupleKindTc
- 10 -> return IfaceArgTypeKindTc
- 11 -> return IfaceConstraintKindTc
- 12 -> return IfaceSuperKindTc
- 13 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
- 14 -> do { ext <- get bh; return (IfaceTc ext) }
- 15 -> do { n <- get bh; return (IfaceIPTc n) }
- _ -> panic ("get IfaceTyCon " ++ show h)
- 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 }
- put_ bh (IfaceIPCoAx ip) = do { putByte bh 7; put_ bh ip }
-
- 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
- 6 -> do { d <- get bh; return (IfaceNthCo d) }
- 7 -> do { ip <- get bh; return (IfaceIPCoAx ip) }
- _ -> panic ("get IfaceCoCon " ++ show h)
- -------------------------------------------------------------------------
- -- IfaceExpr and friends
- -------------------------------------------------------------------------
- instance Binary IfaceExpr where
- put_ bh (IfaceLcl aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (IfaceType ab) = do
- putByte bh 1
- put_ bh ab
- 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 4
- put_ bh ae
- put_ bh af
- put_ bh (IfaceApp ag ah) = do
- putByte bh 5
- put_ bh ag
- put_ bh ah
- put_ bh (IfaceCase ai aj ak) = do
- putByte bh 6
- put_ bh ai
- put_ bh aj
- put_ bh ak
- put_ bh (IfaceLet al am) = do
- putByte bh 7
- put_ bh al
- put_ bh am
- put_ bh (IfaceTick an ao) = do
- putByte bh 8
- put_ bh an
- put_ bh ao
- put_ bh (IfaceLit ap) = do
- putByte bh 9
- put_ bh ap
- put_ bh (IfaceFCall as at) = do
- putByte bh 10
- put_ bh as
- put_ bh at
- put_ bh (IfaceExt aa) = do
- putByte bh 11
- put_ bh aa
- put_ bh (IfaceCast ie ico) = do
- putByte bh 12
- put_ bh ie
- put_ bh ico
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (IfaceLcl aa)
- 1 -> do ab <- get bh
- return (IfaceType ab)
- 2 -> do ab <- get bh
- return (IfaceCo ab)
- 3 -> do ac <- get bh
- ad <- get bh
- return (IfaceTuple ac ad)
- 4 -> do ae <- get bh
- af <- get bh
- return (IfaceLam ae af)
- 5 -> do ag <- get bh
- ah <- get bh
- return (IfaceApp ag ah)
- 6 -> do ai <- get bh
- aj <- get bh
- ak <- get bh
- return (IfaceCase ai aj ak)
- 7 -> do al <- get bh
- am <- get bh
- return (IfaceLet al am)
- 8 -> do an <- get bh
- ao <- get bh
- return (IfaceTick an ao)
- 9 -> do ap <- get bh
- return (IfaceLit ap)
- 10 -> do as <- get bh
- at <- get bh
- return (IfaceFCall as at)
- 11 -> do aa <- get bh
- return (IfaceExt aa)
- 12 -> do ie <- get bh
- ico <- get bh
- return (IfaceCast ie ico)
- _ -> panic ("get IfaceExpr " ++ show h)
- instance Binary IfaceConAlt where
- put_ bh IfaceDefault = putByte bh 0
- put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
- put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return IfaceDefault
- 1 -> get bh >>= (return . IfaceDataAlt)
- _ -> get bh >>= (return . IfaceLitAlt)
- instance Binary IfaceBinding where
- put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
- put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
- _ -> do { ac <- get bh; return (IfaceRec ac) }
- instance Binary IfaceIdDetails where
- put_ bh IfVanillaId = putByte bh 0
- put_ bh (IfRecSelId a b) = 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) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoInfo
- _ -> lazyGet bh >>= (return . HasInfo) -- NB lazyGet
- instance Binary IfaceInfoItem where
- put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa
- put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
- put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad
- put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad
- put_ bh HsNoCafRefs = putByte bh 4
- get bh = do
- h <- getByte bh
- case h of
- 0 -> get bh >>= (return . HsArity)
- 1 -> get bh >>= (return . HsStrictness)
- 2 -> do lb <- get bh
- ad <- get bh
- return (HsUnfold lb ad)
- 3 -> get bh >>= (return . HsInline)
- _ -> 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 IfaceTickish where
- put_ bh (IfaceHpcTick m ix) = do
- putByte bh 0
- put_ bh m
- put_ bh ix
- put_ bh (IfaceSCC cc tick push) = do
- putByte bh 1
- put_ bh cc
- put_ bh tick
- put_ bh push
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do m <- get bh
- ix <- get bh
- return (IfaceHpcTick m ix)
- 1 -> do cc <- get bh
- tick <- get bh
- push <- get bh
- return (IfaceSCC cc tick push)
- _ -> panic ("get IfaceTickish " ++ 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 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"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
- putByte bh 2
- 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 a1 a2 a3 a4 a5) = do
- putByte bh 3
- 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 (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
- 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
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- a7 <- get bh
- occ <- return $! mkOccNameFS tcName a1
- return (IfaceData occ a2 a3 a4 a5 a6 a7)
- 3 -> do 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
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- 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
- put_ bh cls
- put_ bh tys
- put_ bh dfun
- put_ bh flag
- put_ bh orph
- get bh = do
- cls <- get bh
- tys <- get bh
- dfun <- get bh
- flag <- get bh
- 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 b) = putByte bh 0 >> put_ bh b
- put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b
- put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
- get bh = do
- h <- getByte bh
- b <- get bh
- case h of
- 0 -> return $ NoOverlap b
- 1 -> return $ OverlapOk b
- 2 -> return $ Incoherent b
- _ -> panic ("get OverlapFlag " ++ show h)
- instance Binary IfaceConDecls where
- put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
- put_ bh IfOpenDataTyCon = putByte bh 1
- put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs
- put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c
- get bh = do
- h <- getByte bh
- case h of
- 0 -> get bh >>= (return . IfAbstractTyCon)
- 1 -> return IfOpenDataTyCon
- 2 -> get bh >>= (return . IfDataTyCon)
- _ -> get bh >>= (return . IfNewTyCon)
- instance Binary IfaceConDecl where
- put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- put_ bh a7
- put_ bh a8
- put_ bh a9
- put_ bh a10
- 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
- a10 <- get bh
- return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
- instance Binary IfaceAT where
- put_ bh (IfaceAT dec defs) = do
- put_ bh dec
- put_ bh defs
- get bh = do
- dec <- get bh
- defs <- get bh
- return (IfaceAT dec defs)
- instance Binary IfaceATDefault where
- put_ bh (IfaceATD tvs pat_tys ty) = do
- put_ bh tvs
- put_ bh pat_tys
- put_ bh ty
- get bh = liftM3 IfaceATD (get bh) (get bh) (get bh)
- instance Binary IfaceClassOp where
- put_ bh (IfaceClassOp n def ty) = do
- put_ bh (occNameFS n)
- put_ bh def
- put_ bh ty
- get bh = do
- n <- get bh
- def <- get bh
- ty <- get bh
- occ <- return $! mkOccNameFS varName n
- return (IfaceClassOp occ def ty)
- instance Binary IfaceRule where
- put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
- put_ bh a1
- put_ bh a2
- put_ bh a3
- put_ bh a4
- put_ bh a5
- put_ bh a6
- put_ bh a7
- put_ bh a8
- 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
- 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 -> get bh >>= (return . NamedTarget)
- _ -> get bh >>= (return . ModuleTarget)
- 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)
- instance Binary IfaceTrustInfo where
- put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
- get bh = getByte bh >>= (return . numToTrustInfo)