import HscTypes
import BasicTypes
import NewDemand
+import Annotations
import IfaceSyn
import Module
import Name
-import OccName
import VarEnv
-import InstEnv
import Class
import DynFlags
import UniqFM
import Data.Word
import Data.Array
import Data.IORef
-import Control.Exception
import Control.Monad
data CheckHiWay = CheckHiWay | IgnoreHiWay
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
- nc <- getNameCache
- (new_nc, iface) <- liftIO $
- readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
- setNameCache new_nc
- return iface
-
-readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
- -> IO (NameCache, ModIface)
-readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
+ update_nc <- mkNameCacheUpdater
+ dflags <- getDOpts
+ liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+ -> NameCacheUpdater (Array Int Name)
+ -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
errorOnMismatch what wanted got
-- This will be caught by readIface which will emit an error
-- msg containing the iface module name.
- = when (wanted /= got) $ throwDyn $ ProgramError
+ = when (wanted /= got) $ ghcError $ ProgramError
(what ++ " (wanted " ++ show wanted
++ ", got " ++ show got ++ ")")
bh <- Binary.readBinMem hi_path
errorOnMismatch "mismatched interface file versions" our_ver check_ver
check_way <- get bh
- way_descr <- getWayDescr
+ let way_descr = getWayDescr dflags
wantedGot "Way" way_descr check_way
when (checkHiWay == CheckHiWay) $
errorOnMismatch "mismatched interface file ways" way_descr check_way
symtab_p <- Binary.get bh -- Get the symtab ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh symtab_p
- (nc', symtab) <- getSymbolTable bh nc
+ symtab <- getSymbolTable bh update_nc
seekBin bh data_p -- Back to where we were before
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
- return (nc', iface)
+ return iface
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
-- The version and way descriptor go next
put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
- put bh way_descr
+ let way_descr = getWayDescr dflags
+ put_ bh way_descr
-- Remember where the symbol table pointer will go
symtab_p_p <- tellBin bh
initBinMemSize = 1024 * 1024
-- The *host* architecture version:
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
binaryInterfaceMagic :: Word32
#if WORD_SIZE_IN_BITS == 32
let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
-getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
-getSymbolTable bh namecache = do
+getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
+ -> IO (Array Int Name)
+getSymbolTable bh update_namecache = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
- let
+ update_namecache $ \namecache ->
+ let
arr = listArray (0,sz-1) names
(namecache', names) =
mapAccumR (fromOnDiskName arr) namecache od_names
- --
- return (namecache', arr)
+ in (namecache', arr)
type OnDiskName = (PackageId, ModuleName, OccName)
serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
serialiseName bh name _ = do
- let mod = nameModule name
+ let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
mi_exp_hash = exp_hash,
mi_fixities = fixities,
mi_warns = warns,
+ mi_anns = anns,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
put_ bh exp_hash
put_ bh fixities
lazyPut bh warns
+ lazyPut bh anns
put_ bh decls
put_ bh insts
put_ bh fam_insts
exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
warns <- {-# SCC "bin_warns" #-} lazyGet bh
+ anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
+ mi_anns = anns,
mi_fixities = fixities,
mi_warns = warns,
mi_decls = decls,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
-getWayDescr :: IO String
-getWayDescr = do
- tag <- readIORef v_Build_tag
- if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+ | cGhcUnregisterised == "YES" = 'u':tag
+ | otherwise = tag
+ where tag = buildTag dflags
-- if this is an unregisterised build, make sure our interfaces
-- can't be used by a registerised build.
_ -> 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
_ -> 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
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
_ -> 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
-- 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"
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
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
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
get bh = do a1 <- get bh
a2 <- get bh
a3 <- get bh
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
a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+instance Binary IfaceAnnotation where
+ put_ bh (IfaceAnnotation a1 a2) = do
+ put_ bh a1
+ put_ bh a2
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ return (IfaceAnnotation a1 a2)
+
+instance Binary name => Binary (AnnTarget name) where
+ put_ bh (NamedTarget a) = do
+ putByte bh 0
+ put_ bh a
+ put_ bh (ModuleTarget a) = do
+ putByte bh 1
+ put_ bh a
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do a <- get bh
+ return (NamedTarget a)
+ _ -> do a <- get bh
+ return (ModuleTarget a)
+
instance Binary IfaceVectInfo where
put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1
projects / ghc-hetmet.git / blobdiff