X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=1a4a65a290244a893a09e85e5aadc66e5bf86ada;hb=81709fc3e51b7d328d42367e307ce6af728da7de;hp=a544b625e9247bf7a37fc2af33b258bc8119ef7c;hpb=cae75f82226638691cfa1e85fc168f4b65ddce4d;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index a544b62..1a4a65a 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -18,6 +18,7 @@ import IfaceEnv import HscTypes import BasicTypes import NewDemand +import Annotations import IfaceSyn import Module import Name @@ -44,7 +45,6 @@ import Data.List import Data.Word import Data.Array import Data.IORef -import Control.Exception import Control.Monad data CheckHiWay = CheckHiWay | IgnoreHiWay @@ -82,7 +82,7 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do 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 @@ -264,7 +264,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = 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) @@ -374,6 +374,7 @@ instance Binary ModIface where mi_exp_hash = exp_hash, mi_fixities = fixities, mi_warns = warns, + mi_anns = anns, mi_decls = decls, mi_insts = insts, mi_fam_insts = fam_insts, @@ -393,6 +394,7 @@ instance Binary ModIface where put_ bh exp_hash put_ bh fixities lazyPut bh warns + lazyPut bh anns put_ bh decls put_ bh insts put_ bh fam_insts @@ -414,6 +416,7 @@ instance Binary ModIface where exp_hash <- 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 @@ -432,6 +435,7 @@ instance Binary ModIface where mi_usages = usages, mi_exports = exports, mi_exp_hash = exp_hash, + mi_anns = anns, mi_fixities = fixities, mi_warns = warns, mi_decls = decls, @@ -574,13 +578,28 @@ instance Binary Activation where _ -> 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 activation match_info) = do + put_ bh activation + put_ bh match_info + + get bh = do + act <- get bh + info <- get bh + return (InlinePragma act info) + 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 + put_ bh MarkedStrict = putByte bh 0 + put_ bh MarkedUnboxed = putByte bh 1 + put_ bh NotMarkedStrict = putByte bh 2 get bh = do h <- getByte bh case h of @@ -589,10 +608,8 @@ instance Binary StrictnessMark where _ -> do return NotMarkedStrict 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 @@ -1092,6 +1109,18 @@ instance Binary IfaceBinding where _ -> do ac <- get bh return (IfaceRec ac) +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId b) = do { putByte bh 1; 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 + return (IfRecSelId a) + _ -> return IfDFunId + instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do @@ -1170,10 +1199,11 @@ instance Binary IfaceNote where -- 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" @@ -1206,11 +1236,12 @@ instance Binary IfaceDecl where 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 @@ -1295,7 +1326,7 @@ instance Binary IfaceConDecls where 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 @@ -1305,6 +1336,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 @@ -1314,7 +1346,8 @@ 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 @@ -1347,6 +1380,30 @@ instance Binary IfaceRule where 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