X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FBinIface.hs;h=502eefa57842cc5248cffb97b9f61e1c503deb2e;hp=ce023d729e458618138a96416f7b3b710ba83089;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=6a944ae7fe1e8e2e456c68717188463263f8978f diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index ce023d7..502eefa 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1,4 +1,3 @@ - {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -17,13 +16,13 @@ import TcRnMonad import IfaceEnv import HscTypes import BasicTypes -import NewDemand +import Demand import Annotations +import CoreSyn import IfaceSyn import Module import Name import VarEnv -import Class import DynFlags import UniqFM import UniqSupply @@ -257,22 +256,20 @@ fromOnDiskName -> OnDiskName -> (NameCache, Name) fromOnDiskName _ nc (pid, mod_name, occ) = - let + let mod = mkModule pid mod_name cache = nsNames nc in case lookupOrigNameCache cache mod occ of Just name -> (nc, name) - Nothing -> - let - us = nsUniqs nc - uniq = uniqFromSupply us + Nothing -> + case takeUniqFromSupply (nsUniqs nc) of + (uniq, us) -> + let name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache cache mod occ name - in - case splitUniqSupply us of { (us',_) -> - ( nc{ nsUniqs = us', nsNames = new_cache }, name ) - } + in + ( nc{ nsUniqs = us, nsNames = new_cache }, name ) serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do @@ -335,7 +332,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,27 +597,44 @@ instance Binary RuleMatchInfo where else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma a b c) = do + 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 - return (InlinePragma a b c) + d <- get bh + return (InlinePragma a b c d) -instance Binary StrictnessMark where - put_ bh MarkedStrict = putByte bh 0 - put_ bh MarkedUnboxed = putByte bh 1 - put_ bh NotMarkedStrict = putByte bh 2 +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 @@ -651,16 +665,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 @@ -888,10 +902,11 @@ instance Binary IfaceType where put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys } + put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys } + get bh = do h <- getByte bh case h of @@ -924,11 +939,11 @@ instance Binary IfaceType where 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) } + 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 put_ bh IfaceBoolTc = putByte bh 2 put_ bh IfaceCharTc = putByte bh 3 @@ -939,9 +954,9 @@ instance Binary IfaceTyCon where put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 put_ bh IfaceUbxTupleKindTc = putByte bh 9 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 } + 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 @@ -958,7 +973,27 @@ instance Binary IfaceTyCon where 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } 12 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } + +instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceCoAx n) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + _ -> do { d <- get bh; return (IfaceNthCo d) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -998,50 +1033,50 @@ instance Binary IfaceExpr where put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab - put_ bh (IfaceTuple ac ad) = do + put_ bh (IfaceCo ab) = do putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam ae af) = do - putByte bh 3 + putByte bh 4 put_ bh ae put_ bh af put_ bh (IfaceApp ag ah) = do - putByte bh 4 + putByte bh 5 put_ bh ag put_ bh ah --- gaw 2004 - put_ bh (IfaceCase ai aj al ak) = do - putByte bh 5 + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 put_ bh ai put_ bh aj --- gaw 2004 - put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do - putByte bh 6 + putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceNote an ao) = do - putByte bh 7 + putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do - putByte bh 8 + putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do - putByte bh 9 + putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do - putByte bh 10 + putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do - putByte bh 11 + putByte bh 12 put_ bh ie put_ bh ico put_ bh (IfaceTick m ix) = do - putByte bh 12 + putByte bh 13 put_ bh m put_ bh ix get bh = do @@ -1051,39 +1086,38 @@ instance Binary IfaceExpr where return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) - 2 -> do ac <- get bh + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) - 3 -> do ae <- get bh + 4 -> do ae <- get bh af <- get bh return (IfaceLam ae af) - 4 -> do ag <- get bh + 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) - 5 -> do ai <- get bh + 6 -> do ai <- get bh aj <- get bh --- gaw 2004 - al <- get bh ak <- get bh --- gaw 2004 - return (IfaceCase ai aj al ak) - 6 -> do al <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh am <- get bh return (IfaceLet al am) - 7 -> do an <- get bh + 8 -> do an <- get bh ao <- get bh return (IfaceNote an ao) - 8 -> do ap <- get bh + 9 -> do ap <- get bh return (IfaceLit ap) - 9 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 10 -> do aa <- get bh + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh return (IfaceExt aa) - 11 -> do ie <- get bh + 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) - 12 -> do m <- get bh + 13 -> do m <- get bh ix <- get bh return (IfaceTick m ix) _ -> panic ("get IfaceExpr " ++ show h) @@ -1131,7 +1165,7 @@ instance Binary IfaceBinding where 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 + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } get bh = do h <- getByte bh case h of @@ -1139,7 +1173,7 @@ instance Binary IfaceIdDetails where 1 -> do a <- get bh b <- get bh return (IfRecSelId a b) - _ -> return IfDFunId + _ -> do { n <- get bh; return (IfDFunId n) } instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 @@ -1185,35 +1219,61 @@ instance Binary IfaceInfoItem where _ -> do return HsNoCafRefs instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold e) = do + put_ bh (IfCoreUnfold s e) = do putByte bh 0 + put_ bh s put_ bh e - put_ bh (IfInlineRule a b e) = do + put_ bh (IfInlineRule a b c d) = do putByte bh 1 put_ bh a put_ bh b - put_ bh e - put_ bh (IfWrapper a n) = do + put_ bh c + put_ bh d + put_ bh (IfLclWrapper a n) = do putByte bh 2 put_ bh a put_ bh n - put_ bh (IfDFunUnfold as) = do + put_ bh (IfExtWrapper a n) = do putByte bh 3 + put_ bh a + put_ bh n + put_ bh (IfDFunUnfold as) = do + putByte bh 4 put_ bh as + put_ bh (IfCompulsory e) = do + putByte bh 5 + put_ bh e get bh = do h <- getByte bh case h of - 0 -> do e <- get bh - return (IfCoreUnfold e) + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) 1 -> do a <- get bh b <- get bh - e <- get bh - return (IfInlineRule a b e) + c <- get bh + d <- get bh + return (IfInlineRule a b c d) 2 -> do a <- get bh n <- get bh - return (IfWrapper a n) - _ -> do as <- get bh + return (IfLclWrapper a n) + 3 -> do a <- get bh + n <- get bh + return (IfExtWrapper a n) + 4 -> do as <- get bh return (IfDFunUnfold as) + _ -> do e <- get bh + return (IfCompulsory e) + +instance Binary (DFunArg IfaceExpr) where + put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e + put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e + put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i + get bh = do { h <- getByte bh + ; case h of + 0 -> do { a <- get bh; return (DFunPolyArg a) } + 1 -> do { a <- get bh; return (DFunConstArg a) } + _ -> do { a <- get bh; return (DFunLamArg a) } } instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do @@ -1250,7 +1310,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@ -1259,7 +1319,6 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 put_ bh (occNameFS a1) @@ -1294,9 +1353,8 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) + return (IfaceData occ a2 a3 a4 a5 a6 a7) 3 -> do a1 <- get bh a2 <- get bh @@ -1405,7 +1463,7 @@ instance Binary IfaceClassOp where return (IfaceClassOp occ def ty) instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do put_ bh a1 put_ bh a2 put_ bh a3 @@ -1413,6 +1471,7 @@ instance Binary IfaceRule where put_ bh a5 put_ bh a6 put_ bh a7 + put_ bh a8 get bh = do a1 <- get bh a2 <- get bh @@ -1421,7 +1480,8 @@ instance Binary IfaceRule where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7) + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) instance Binary IfaceAnnotation where put_ bh (IfaceAnnotation a1 a2) = do @@ -1448,14 +1508,18 @@ instance Binary name => Binary (AnnTarget name) where return (ModuleTarget a) instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3) = do + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do put_ bh a1 put_ bh a2 put_ bh a3 + put_ bh a4 + put_ bh a5 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh - return (IfaceVectInfo a1 a2 a3) + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5)