-
{-# OPTIONS_GHC -O #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
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
import Unique
import Outputable
import FastString
+import Constants
import Data.List
import Data.Word
errorOnMismatch "magic number mismatch: old/corrupt interface file?"
binaryInterfaceMagic magic
- -- Get the dictionary pointer. We won't attempt to actually
- -- read the dictionary until we've done the version checks below,
- -- just in case this isn't a valid interface. In retrospect the
- -- version should have come before the dictionary pointer, but this
- -- is the way it was done originally, and we can't change it now.
- dict_p <- Binary.get bh -- Get the dictionary ptr
+ -- Note [dummy iface field]
+ -- read a dummy 32/64 bit value. This field used to hold the
+ -- dictionary pointer in old interface file formats, but now
+ -- the dictionary pointer is after the version (where it
+ -- should be). Also, the serialisation of value of type "Bin
+ -- a" used to depend on the word size of the machine, now they
+ -- are always 32 bits.
+ --
+ if wORD_SIZE == 4
+ then do _ <- Binary.get bh :: IO Word32; return ()
+ else do _ <- Binary.get bh :: IO Word64; return ()
-- Check the interface file version and ways.
check_ver <- get bh
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
+ dict_p <- Binary.get bh
data_p <- tellBin bh -- Remember where we are now
seekBin bh dict_p
dict <- getDictionary bh
bh <- openBinMem initBinMemSize
put_ bh binaryInterfaceMagic
- -- Remember where the dictionary pointer will go
- dict_p_p <- tellBin bh
- put_ bh dict_p_p -- Placeholder for ptr to dictionary
+ -- dummy 32/64-bit field before the version/way for
+ -- compatibility with older interface file formats.
+ -- See Note [dummy iface field] above.
+ if wORD_SIZE == 4
+ then Binary.put_ bh (0 :: Word32)
+ else Binary.put_ bh (0 :: Word64)
-- The version and way descriptor go next
put_ bh (show opt_HiVersion)
let way_descr = getWayDescr dflags
put_ bh way_descr
+ -- Remember where the dictionary pointer will go
+ dict_p_p <- tellBin bh
+ put_ bh dict_p_p -- Placeholder for ptr to dictionary
+
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
put_ bh symtab_p_p
-> 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
= do
symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
- Just (off,_) -> put_ bh off
+ Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
- put_ bh off
+ put_ bh (fromIntegral off :: Word32)
data BinSymbolTable = BinSymbolTable {
out <- readIORef out_r
let uniq = getUnique f
case lookupUFM out uniq of
- Just (j, _) -> put_ bh j
+ Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
- put_ bh j
+ put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out uniq (j, f)
{-! 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 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
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
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
+ 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
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
+ 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
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 (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
9 -> return IfaceUbxTupleKindTc
10 -> return IfaceArgTypeKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
- _ -> do { ext <- get bh; return (IfaceTc ext) }
+ 12 -> do { ext <- get bh; return (IfaceTc ext) }
+ _ -> 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
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
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)
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
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
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 (IfLclWrapper a n) = do
+ putByte bh 2
+ put_ bh a
+ put_ bh n
+ 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 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 (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
putByte bh 0
put_ bh aa
- put_ bh IfaceInlineMe = do
- putByte bh 3
put_ bh (IfaceCoreNote s) = do
putByte bh 4
put_ bh s
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)
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