X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fiface%2FBinIface.hs;h=72a62a66de2e40a491dd59d6979f24bece3338b0;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hp=2ee8310f9e5b725f88241ef8da7e588edd35e44a;hpb=d95ce839533391e7118257537044f01cbb1d6694;p=ghc-hetmet.git diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 2ee8310..72a62a6 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -149,7 +149,7 @@ writeBinIface dflags hi_path mod_iface = do -- The version and way descriptor go next put_ bh (show opt_HiVersion) way_descr <- getWayDescr - put bh way_descr + put_ bh way_descr -- Remember where the symbol table pointer will go symtab_p_p <- tellBin bh @@ -578,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 @@ -593,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 @@ -668,7 +681,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 @@ -1096,6 +1109,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 = 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 @@ -1124,6 +1150,10 @@ instance Binary IfaceInfoItem where 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 @@ -1135,36 +1165,17 @@ instance Binary IfaceInfoItem where return (HsUnfold ad) 3 -> do ad <- get bh return (HsInline ad) - _ -> 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) + 4 -> do return HsNoCafRefs + _ -> do ae <- get bh + af <- get bh + return (HsWorker ae af) 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 @@ -1173,6 +1184,7 @@ 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) @@ -1188,10 +1200,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" @@ -1224,11 +1237,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 @@ -1313,7 +1327,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 @@ -1323,6 +1337,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 @@ -1332,7 +1347,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