---
+{-# 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,
import IfaceEnv
import HscTypes
import BasicTypes
-import NewDemand
+import Demand
+import Annotations
import IfaceSyn
import Module
import Name
-import OccName
import VarEnv
-import InstEnv
import Class
import DynFlags
import UniqFM
import ErrUtils
import Config
import FastMutInt
+import Unique
import Outputable
+import FastString
+import Constants
import Data.List
import Data.Word
import Data.Array
import Data.IORef
-import Control.Exception
import Control.Monad
data CheckHiWay = CheckHiWay | IgnoreHiWay
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
- nc <- getNameCache
- (new_nc, iface) <- liftIO $
- readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
- setNameCache new_nc
- return iface
-
-readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
- -> IO (NameCache, ModIface)
-readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
+ update_nc <- mkNameCacheUpdater
+ dflags <- getDOpts
+ liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> NameCacheUpdater (Array Int Name)
+ -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
= 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) $ throwDyn $ ProgramError
+ = when (wanted /= got) $ ghcError $ ProgramError
(what ++ " (wanted " ++ show wanted
++ ", got " ++ show got ++ ")")
bh <- Binary.readBinMem hi_path
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
binaryInterfaceMagic magic
- -- 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
+ -- 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
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
-- 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
symtab_p <- Binary.get bh -- Get the symtab ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh symtab_p
- (nc', symtab) <- getSymbolTable bh nc
+ symtab <- getSymbolTable bh update_nc
seekBin bh data_p -- Back to where we were before
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
- return (nc', iface)
+ return iface
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
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
+ -- 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)
- way_descr <- getWayDescr
- put bh way_descr
+ 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
- ud <- newWriteState
+ symtab_next <- newFastMutInt
+ writeFastMutInt symtab_next 0
+ symtab_map <- newIORef emptyUFM
+ let bin_symtab = BinSymbolTable {
+ bin_symtab_next = symtab_next,
+ bin_symtab_map = symtab_map }
+ dict_next_ref <- newFastMutInt
+ writeFastMutInt dict_next_ref 0
+ dict_map_ref <- newIORef emptyUFM
+ let bin_dict = BinDictionary {
+ bin_dict_next = dict_next_ref,
+ bin_dict_map = dict_map_ref }
+ ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
-- Put the main thing,
bh <- return $ setUserData bh ud
seekBin bh symtab_p -- Seek back to the end of the file
-- Write the symbol table itself
- symtab_next <- readFastMutInt (ud_symtab_next ud)
- symtab_map <- readIORef (ud_symtab_map ud)
+ symtab_next <- readFastMutInt symtab_next
+ symtab_map <- readIORef symtab_map
putSymbolTable bh symtab_next symtab_map
debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
<+> text "Names")
seekBin bh dict_p -- Seek back to the end of the file
-- Write the dictionary itself
- dict_next <- readFastMutInt (ud_dict_next ud)
- dict_map <- readIORef (ud_dict_map ud)
+ dict_next <- readFastMutInt dict_next_ref
+ dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
<+> text "dict entries")
initBinMemSize = 1024 * 1024
-- The *host* architecture version:
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
binaryInterfaceMagic :: Word32
#if WORD_SIZE_IN_BITS == 32
let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
+getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
+ -> IO (Array Int Name)
+getSymbolTable bh update_namecache = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
- let
+ update_namecache $ \namecache ->
+ let
arr = listArray (0,sz-1) names
(namecache', names) =
mapAccumR (fromOnDiskName arr) namecache od_names
- --
- return (namecache', arr)
+ in (namecache', arr)
type OnDiskName = (PackageId, ModuleName, OccName)
serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName bh name _ = do
- let mod = nameModule name
+ let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+
+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
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
--- NewDemand
+-- Demand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for DmdResult derive: Binary !-}
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,
+ 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
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_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
- mi_ver_fn = mkIfaceVerCache decls })
+ mi_hash_fn = mkIfaceHashCache decls })
-getWayDescr :: IO String
-getWayDescr = do
- tag <- readIORef v_Build_tag
- if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+ | cGhcUnregisterised == "YES" = 'u':tag
+ | otherwise = tag
+ where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
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 Deprecations where
- put_ bh NoDeprecs = putByte bh 0
- put_ bh (DeprecAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (DeprecSome ts) = do
- putByte bh 2
- put_ bh ts
+ 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
_ -> 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 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
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
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
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) }
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 (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
get bh = do
h <- getByte bh
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 IfacePredType where
put_ bh (IfaceClassP aa ab) = do
_ -> do ac <- get bh
return (IfaceRec ac)
+instance Binary IfaceIdDetails where
+ put_ bh IfVanillaId = putByte bh 0
+ put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
+ put_ bh IfDFunId = putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfVanillaId
+ 1 -> do a <- get bh
+ b <- get bh
+ return (IfRecSelId a b)
+ _ -> return IfDFunId
+
instance Binary IfaceIdInfo where
put_ bh NoInfo = putByte bh 0
put_ bh (HasInfo i) = do
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
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 e) = do
+ putByte bh 0
+ 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 (IfWrapper a n) = do
+ putByte bh 2
+ put_ bh a
+ put_ bh n
+ put_ bh (IfDFunUnfold as) = do
+ putByte bh 3
+ put_ bh as
+ put_ bh (IfCompulsory e) = do
+ putByte bh 4
+ put_ bh e
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do e <- get bh
+ return (IfCoreUnfold 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 (IfWrapper a n)
+ 3 -> do as <- get bh
+ return (IfDFunUnfold as)
+ _ -> do e <- get bh
+ return (IfCompulsory e)
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
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)
-- when de-serialising.
instance Binary IfaceDecl where
- put_ bh (IfaceId name ty idinfo) = do
+ put_ bh (IfaceId name ty details idinfo) = do
putByte bh 0
put_ bh (occNameFS name)
put_ bh ty
+ put_ bh details
put_ bh idinfo
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
get bh = do
h <- getByte bh
case h of
- 0 -> do name <- get bh
- ty <- get bh
- idinfo <- get bh
+ 0 -> do name <- get bh
+ ty <- get bh
+ details <- get bh
+ idinfo <- get bh
occ <- return $! mkOccNameFS varName name
- return (IfaceId occ ty idinfo)
+ return (IfaceId occ ty details idinfo)
1 -> error "Binary.get(TyClDecl): ForeignType"
2 -> do
a1 <- get bh
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
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
get bh = do a1 <- get bh
a2 <- get bh
a3 <- get bh
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
a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+instance Binary IfaceAnnotation where
+ put_ bh (IfaceAnnotation a1 a2) = do
+ put_ bh a1
+ put_ bh a2
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ return (IfaceAnnotation a1 a2)
+
+instance Binary name => Binary (AnnTarget name) where
+ put_ bh (NamedTarget a) = do
+ putByte bh 0
+ put_ bh a
+ put_ bh (ModuleTarget a) = do
+ putByte bh 1
+ put_ bh a
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do a <- get bh
+ return (NamedTarget a)
+ _ -> do a <- get bh
+ return (ModuleTarget a)
+
instance Binary IfaceVectInfo where
put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1
projects / ghc-hetmet.git / blobdiff