X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=ec85995b45263199c8556212e0b2744759dc28f7;hp=b04e6e104edce58b087922ce3b97e887fd4a72f9;hb=a51fe79ebcdcb8285573a18f12cade2101533419;hpb=388e3356f71daffa62f1d4157e1e07e4c68f218a diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index b04e6e1..ec85995 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -17,13 +17,12 @@ import TcRnMonad import IfaceEnv import HscTypes import BasicTypes -import NewDemand +import Demand import Annotations import IfaceSyn import Module import Name import VarEnv -import Class import DynFlags import UniqFM import UniqSupply @@ -335,7 +334,7 @@ data BinDictionary = BinDictionary { {-! for StrictnessMark derive: Binary !-} {-! for Activation derive: Binary !-} --- NewDemand +-- Demand {-! for Demand derive: Binary !-} {-! for Demands derive: Binary !-} {-! for DmdResult derive: Binary !-} @@ -600,25 +599,44 @@ instance Binary RuleMatchInfo where else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma activation match_info) = do - put_ bh activation - put_ bh match_info + put_ bh (InlinePragma a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d get bh = do - act <- get bh - info <- get bh - return (InlinePragma act info) - -instance Binary StrictnessMark where - put_ bh MarkedStrict = putByte bh 0 - put_ bh MarkedUnboxed = putByte bh 1 - put_ bh NotMarkedStrict = putByte bh 2 + 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 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 = putByte bh 0 @@ -649,16 +667,16 @@ instance Binary RecFlag where 0 -> do return Recursive _ -> do return NonRecursive -instance Binary DefMeth where - put_ bh NoDefMeth = putByte bh 0 - put_ bh DefMeth = putByte bh 1 - put_ bh GenDefMeth = putByte bh 2 +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 NoDefMeth - 1 -> return DefMeth - _ -> return GenDefMeth + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM instance Binary FixityDirection where put_ bh InfixL = do @@ -1159,18 +1177,15 @@ instance Binary IfaceInfoItem where 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 @@ -1178,21 +1193,57 @@ instance Binary IfaceInfoItem where 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 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 (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 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 (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 @@ -1201,7 +1252,6 @@ 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)