---
+{-# 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 HscTypes
import BasicTypes
import NewDemand
+import Annotations
import IfaceSyn
import Module
import Name
import Data.Word
import Data.Array
import Data.IORef
-import Control.Exception
import Control.Monad
data CheckHiWay = CheckHiWay | IgnoreHiWay
= 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
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)
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_fixities = fixities,
- mi_deprecs = deprecs,
+ mi_warns = warns,
+ mi_anns = anns,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
put_ bh exports
put_ bh exp_hash
put_ bh fixities
- lazyPut bh deprecs
+ lazyPut bh warns
+ lazyPut bh anns
put_ bh decls
put_ bh insts
put_ bh fam_insts
exports <- {-# SCC "bin_exports" #-} get bh
exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
- deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
+ warns <- {-# SCC "bin_warns" #-} lazyGet bh
+ anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
+ mi_anns = anns,
mi_fixities = fixities,
- mi_deprecs = deprecs,
+ mi_warns = warns,
mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
mi_vect_info = vect_info,
mi_hpc = hpc_info,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
usg_exports = exps, usg_entities = ents }
-instance Binary Deprecations where
- put_ bh NoDeprecs = putByte bh 0
- put_ bh (DeprecAll t) = do
- putByte bh 1
- put_ bh t
- put_ bh (DeprecSome ts) = do
- putByte bh 2
- put_ bh ts
+instance Binary Warnings where
+ put_ bh NoWarnings = putByte bh 0
+ put_ bh (WarnAll t) = do
+ putByte bh 1
+ put_ bh t
+ put_ bh (WarnSome ts) = do
+ putByte bh 2
+ put_ bh ts
get bh = do
- h <- getByte bh
- case h of
- 0 -> return NoDeprecs
- 1 -> do aa <- get bh
- return (DeprecAll aa)
- _ -> do aa <- get bh
- return (DeprecSome aa)
+ h <- getByte bh
+ case h of
+ 0 -> return NoWarnings
+ 1 -> do aa <- get bh
+ return (WarnAll aa)
+ _ -> do aa <- get bh
+ return (WarnSome aa)
+
+instance Binary WarningTxt where
+ put_ bh (WarningTxt w) = do
+ putByte bh 0
+ put_ bh w
+ put_ bh (DeprecatedTxt d) = do
+ putByte bh 1
+ put_ bh d
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do w <- get bh
+ return (WarningTxt w)
+ _ -> do d <- get bh
+ return (DeprecatedTxt d)
-------------------------------------------------------------------------
-- Types from: BasicTypes
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 (HsUnfold 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 e) = do
+ putByte bh 1
+ put_ bh a
+ put_ bh e
+ put_ bh (IfWrapper a n) = do
+ putByte bh 2
+ put_ bh a
+ put_ bh n
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do e <- get bh
+ return (IfCoreUnfold e)
+ 1 -> do a <- get bh
+ e <- get bh
+ return (IfInlineRule a e)
+ _ -> do a <- get bh
+ n <- get bh
+ return (IfWrapper a n)
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)
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