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
-> 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
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
--- NewDemand
+-- Demand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for DmdResult derive: Binary !-}
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 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
-instance Binary StrictnessMark where
- 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
+ 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
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
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
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
_ -> 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
-- to avoid re-building it in various places. So we build the OccName
-- when de-serialising.
+-- NOTE regarding HetMet extensions: this screws up Adam's heinous
+-- hide-the-syntactical-level-in-the-namespace trick.
+
instance Binary IfaceDecl where
put_ bh (IfaceId name ty details idinfo) = do
putByte bh 0
put_ bh (occNameFS name)
+ put_ bh (getOccNameDepth name)
put_ bh ty
put_ bh details
put_ bh idinfo
h <- getByte bh
case h of
0 -> do name <- get bh
+ depth <- get bh
ty <- get bh
details <- get bh
idinfo <- get bh
- occ <- return $! mkOccNameFS varName name
+ occ <- return $! mkOccNameFS (varNameDepth depth) name
return (IfaceId occ ty details idinfo)
1 -> error "Binary.get(TyClDecl): ForeignType"
2 -> do
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
put_ bh (occNameFS n)
+ put_ bh (getOccNameDepth n)
put_ bh def
put_ bh ty
get bh = do
n <- get bh
+ depth <- get bh
def <- get bh
ty <- get bh
- occ <- return $! mkOccNameFS varName n
+ occ <- return $! mkOccNameFS (varNameDepth depth) n
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
put_ bh a5
put_ bh a6
put_ bh a7
+ put_ bh a8
get bh = do
a1 <- get bh
a2 <- get bh
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
projects / ghc-hetmet.git / blobdiff