-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
-{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
--
--- (c) The University of Glasgow 2002
+-- (c) The University of Glasgow 2002-2006
--
-- Binary interface file support.
#include "HsVersions.h"
+import TcRnMonad
+import IfaceEnv
import HscTypes
import BasicTypes
import NewDemand
import IfaceSyn
+import Module
+import Name
+import OccName
import VarEnv
-import InstEnv ( OverlapFlag(..) )
-import Class ( DefMeth(..) )
+import InstEnv
+import Class
+import DynFlags
+import UniqFM
+import UniqSupply
import CostCentre
-import StaticFlags ( opt_HiVersion, v_Build_tag )
-import Type ( Kind,
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isArgTypeKind, isUbxTupleKind, liftedTypeKind,
- unliftedTypeKind, openTypeKind, argTypeKind,
- ubxTupleKind, mkArrowKind, splitFunTy_maybe )
+import StaticFlags
+import PackageConfig
import Panic
import Binary
+import SrcLoc
import Util
-import Config ( cGhcUnregisterised )
-
-import DATA_IOREF
-import EXCEPTION ( throwDyn )
-import Monad ( when )
+import ErrUtils
+import Config
+import FastMutInt
import Outputable
-#include "HsVersions.h"
+import Data.List
+import Data.Word
+import Data.Array
+import Data.IORef
+import Control.Exception
+import Control.Monad
-- ---------------------------------------------------------------------------
-writeBinIface :: FilePath -> ModIface -> IO ()
-writeBinIface hi_path mod_iface
- = putBinFileWithDict hi_path mod_iface
-
-readBinIface :: FilePath -> IO ModIface
-readBinIface hi_path = getBinFileWithDict hi_path
-
-
--- %*********************************************************
--- %* *
--- All the Binary instances
--- %* *
--- %*********************************************************
+-- Reading and writing binary interface files
+
+readBinIface :: FilePath -> TcRnIf a b ModIface
+readBinIface hi_path = do
+ nc <- getNameCache
+ (new_nc, iface) <- ioToIOEnv $ readBinIface_ hi_path nc
+ setNameCache new_nc
+ return iface
+
+readBinIface_ :: FilePath -> NameCache -> IO (NameCache, ModIface)
+readBinIface_ hi_path nc = do
+ bh <- Binary.readBinMem hi_path
+
+ -- Read the magic number to check that this really is a GHC .hi file
+ -- (This magic number does not change when we change
+ -- GHC interface file format)
+ magic <- get bh
+ when (magic /= binaryInterfaceMagic) $
+ throwDyn (ProgramError (
+ "magic number mismatch: old/corrupt interface file?"))
+
+ -- 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
+
+ -- Check the interface file version and ways.
+ check_ver <- get bh
+ let our_ver = show opt_HiVersion
+ when (check_ver /= our_ver) $
+ -- This will be caught by readIface which will emit an error
+ -- msg containing the iface module name.
+ throwDyn (ProgramError (
+ "mismatched interface file versions: expected "
+ ++ our_ver ++ ", found " ++ check_ver))
+
+ check_way <- get bh
+ ignore_way <- readIORef v_IgnoreHiWay
+ way_descr <- getWayDescr
+ when (not ignore_way && check_way /= way_descr) $
+ -- This will be caught by readIface
+ -- which will emit an error msg containing the iface module name.
+ throwDyn (ProgramError (
+ "mismatched interface file ways: expected "
+ ++ way_descr ++ ", found " ++ check_way))
+
+ -- Read the dictionary
+ -- The next word in the file is a pointer to where the dictionary is
+ -- (probably at the end of the file)
+ data_p <- tellBin bh -- Remember where we are now
+ seekBin bh dict_p
+ dict <- getDictionary bh
+ seekBin bh data_p -- Back to where we were before
+
+ -- Initialise the user-data field of bh
+ ud <- newReadState dict
+ bh <- return (setUserData bh ud)
+
+ 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
+ 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)
+
+
+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
+writeBinIface dflags hi_path mod_iface = do
+ 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
+
+ -- The version and way descriptor go next
+ put_ bh (show opt_HiVersion)
+ way_descr <- getWayDescr
+ put bh way_descr
+
+ -- Remember where the symbol table pointer will go
+ symtab_p_p <- tellBin bh
+ put_ bh symtab_p_p
+
+ -- Make some intial state
+ ud <- newWriteState
+
+ -- Put the main thing,
+ bh <- return $ setUserData bh ud
+ put_ bh mod_iface
+
+ -- Write the symtab pointer at the fornt of the file
+ symtab_p <- tellBin bh -- This is where the symtab will start
+ putAt bh symtab_p_p symtab_p -- Fill in the placeholder
+ seekBin bh symtab_p -- Seek back to the end of the file
+
+ -- Write the symbol table itself
+ symtab_next <- readFastMutInt (ud_symtab_next ud)
+ symtab_map <- readIORef (ud_symtab_map ud)
+ putSymbolTable bh symtab_next symtab_map
+ debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
+ <+> text "Names")
+
+ -- NB. write the dictionary after the symbol table, because
+ -- writing the symbol table may create more dictionary entries.
+
+ -- Write the dictionary pointer at the fornt of the file
+ dict_p <- tellBin bh -- This is where the dictionary will start
+ putAt bh dict_p_p dict_p -- Fill in the placeholder
+ seekBin bh dict_p -- Seek back to the end of the file
+
+ -- Write the dictionary itself
+ dict_next <- readFastMutInt (ud_dict_next ud)
+ dict_map <- readIORef (ud_dict_map ud)
+ putDictionary bh dict_next dict_map
+ debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
+ <+> text "dict entries")
+
+ -- And send the result to the file
+ writeBinMem bh hi_path
+
+initBinMemSize = (1024*1024) :: Int
+
+-- The *host* architecture version:
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS == 32
+binaryInterfaceMagic = 0x1face :: Word32
+#elif WORD_SIZE_IN_BITS == 64
+binaryInterfaceMagic = 0x1face64 :: Word32
+#endif
+
+-- -----------------------------------------------------------------------------
+-- The symbol table
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable bh next_off symtab = do
+ put_ bh next_off
+ 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
+ sz <- get bh
+ od_names <- sequence (replicate sz (get bh))
+ let
+ arr = listArray (0,sz-1) names
+ (namecache', names) =
+ mapAccumR (fromOnDiskName arr) namecache od_names
+ --
+ return (namecache', arr)
+
+type OnDiskName = (PackageId, ModuleName, OccName)
+
+fromOnDiskName
+ :: Array Int Name
+ -> NameCache
+ -> OnDiskName
+ -> (NameCache, Name)
+fromOnDiskName arr nc (pid, mod_name, occ) =
+ 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
+ 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 )
+ }
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name symtab = do
+ let mod = nameModule name
+ put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
+
+-- -----------------------------------------------------------------------------
+-- All the binary instances
-- BasicTypes
{-! for IPName derive: Binary !-}
mi_boot = is_boot,
mi_mod_vers = mod_vers,
mi_orphan = orphan,
+ mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
mi_deprecs = deprecs,
mi_decls = decls,
mi_insts = insts,
+ mi_fam_insts = fam_insts,
mi_rules = rules,
- mi_rule_vers = rule_vers }) = do
- put_ bh (show opt_HiVersion)
- way_descr <- getWayDescr
- put bh way_descr
+ mi_rule_vers = rule_vers,
+ mi_vect_info = vect_info,
+ mi_hpc = hpc_info }) = do
put_ bh mod
put_ bh is_boot
put_ bh mod_vers
put_ bh orphan
+ put_ bh hasFamInsts
lazyPut bh deps
lazyPut bh usages
put_ bh exports
lazyPut bh deprecs
put_ bh decls
put_ bh insts
+ put_ bh fam_insts
lazyPut bh rules
put_ bh rule_vers
+ put_ bh vect_info
+ put_ bh hpc_info
get bh = do
- check_ver <- get bh
- let our_ver = show opt_HiVersion
- when (check_ver /= our_ver) $
- -- use userError because this will be caught by readIface
- -- which will emit an error msg containing the iface module name.
- throwDyn (ProgramError (
- "mismatched interface file versions: expected "
- ++ our_ver ++ ", found " ++ check_ver))
-
- check_way <- get bh
- ignore_way <- readIORef v_IgnoreHiWay
- way_descr <- getWayDescr
- when (not ignore_way && check_way /= way_descr) $
- -- use userError because this will be caught by readIface
- -- which will emit an error msg containing the iface module name.
- throwDyn (ProgramError (
- "mismatched interface file ways: expected "
- ++ way_descr ++ ", found " ++ check_way))
-
mod_name <- get bh
is_boot <- get bh
mod_vers <- get bh
orphan <- get bh
+ hasFamInsts <- get bh
deps <- lazyGet bh
usages <- {-# SCC "bin_usages" #-} lazyGet bh
exports <- {-# SCC "bin_exports" #-} get bh
deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
+ fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
+ vect_info <- get bh
+ hpc_info <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
mi_mod_vers = mod_vers,
mi_orphan = orphan,
+ mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
+ mi_fam_insts = fam_insts,
mi_rules = rules,
mi_rule_vers = rule_vers,
+ mi_vect_info = vect_info,
+ mi_hpc = hpc_info,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
- mi_fix_fn = mkIfaceFixCache fixities,
- mi_ver_fn = mkIfaceVerCache decls })
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_ver_fn = mkIfaceVerCache decls })
GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
put_ bh deps = do put_ bh (dep_mods deps)
put_ bh (dep_pkgs deps)
put_ bh (dep_orphs deps)
+ put_ bh (dep_finsts deps)
get bh = do ms <- get bh
ps <- get bh
os <- get bh
- return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
+ fis <- get bh
+ return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
+ dep_finsts = fis })
instance (Binary name) => Binary (GenAvailInfo name) where
put_ bh (Avail aa) = do
return (Fixity aa ab)
instance (Binary name) => Binary (IPName name) where
- put_ bh (Dupable aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (Linear ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (Dupable aa)
- _ -> do ab <- get bh
- return (Linear ab)
+ put_ bh (IPName aa) = put_ bh aa
+ get bh = do aa <- get bh
+ return (IPName aa)
-------------------------------------------------------------------------
-- Types from: Demand
-- IfaceTypes and friends
-------------------------------------------------------------------------
-instance Binary IfaceExtName where
- put_ bh (ExtPkg mod occ) = do
- putByte bh 0
- put_ bh mod
- put_ bh occ
- put_ bh (HomePkg mod occ vers) = do
- putByte bh 1
- put_ bh mod
- put_ bh occ
- put_ bh vers
- put_ bh (LocalTop occ) = do
- putByte bh 2
- put_ bh occ
- put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop
- putByte bh 2
- put_ bh occ
-
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do mod <- get bh
- occ <- get bh
- return (ExtPkg mod occ)
- 1 -> do mod <- get bh
- occ <- get bh
- vers <- get bh
- return (HomePkg mod occ vers)
- _ -> do occ <- get bh
- return (LocalTop occ)
-
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
putByte bh 0
_ -> do ab <- get bh
return (IfaceTvBndr ab)
+instance Binary IfaceLetBndr where
+ put_ bh (IfLetBndr a b c) = do
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ get bh = do a <- get bh
+ b <- get bh
+ c <- get bh
+ return (IfLetBndr a b c)
+
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 0
putByte bh 11
put_ bh ie
put_ bh ico
+ put_ bh (IfaceTick m ix) = do
+ putByte bh 12
+ put_ bh m
+ put_ bh ix
get bh = do
h <- getByte bh
case h of
11 -> do ie <- get bh
ico <- get bh
return (IfaceCast ie ico)
+ 12 -> do m <- get bh
+ ix <- get bh
+ return (IfaceTick m ix)
instance Binary IfaceConAlt where
put_ bh IfaceDefault = do
4 -> do ac <- get bh
return (IfaceCoreNote ac)
-
-------------------------------------------------------------------------
-- IfaceDecl and friends
-------------------------------------------------------------------------
+-- A bit of magic going on here: there's no need to store the OccName
+-- for a decl on the disk, since we can infer the namespace from the
+-- context; however it is useful to have the OccName in the IfaceDecl
+-- to avoid re-building it in various places. So we build the OccName
+-- when de-serialising.
+
instance Binary IfaceDecl where
put_ bh (IfaceId name ty idinfo) = do
putByte bh 0
- put_ bh name
+ put_ bh (occNameFS name)
put_ bh ty
put_ bh idinfo
put_ bh (IfaceForeign ae af) =
error "Binary.put_(IfaceDecl): IfaceForeign"
put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
putByte bh 2
- put_ bh a1
+ put_ bh (occNameFS a1)
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a6
put_ bh a7
put_ bh a8
- put_ bh (IfaceSyn aq ar as at) = do
+ put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
- put_ bh aq
- put_ bh ar
- put_ bh as
- put_ bh at
+ put_ bh (occNameFS a1)
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 4
put_ bh a1
- put_ bh a2
+ put_ bh (occNameFS a2)
put_ bh a3
put_ bh a4
put_ bh a5
0 -> do name <- get bh
ty <- get bh
idinfo <- get bh
- return (IfaceId name ty idinfo)
+ occ <- return $! mkOccNameFS varName name
+ return (IfaceId occ ty idinfo)
1 -> error "Binary.get(TyClDecl): ForeignType"
2 -> do
a1 <- get bh
a6 <- get bh
a7 <- get bh
a8 <- get bh
- return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
+ occ <- return $! mkOccNameFS tcName a1
+ return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
3 -> do
- aq <- get bh
- ar <- get bh
- as <- get bh
- at <- get bh
- return (IfaceSyn aq ar as at)
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ occ <- return $! mkOccNameFS tcName a1
+ return (IfaceSyn occ a2 a3 a4 a5)
_ -> do
a1 <- get bh
a2 <- get bh
a5 <- get bh
a6 <- get bh
a7 <- get bh
- return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
+ occ <- return $! mkOccNameFS clsName a2
+ return (IfaceClass a1 occ a3 a4 a5 a6 a7)
instance Binary IfaceInst where
put_ bh (IfaceInst cls tys dfun flag orph) = do
orph <- get bh
return (IfaceInst cls tys dfun flag orph)
+instance Binary IfaceFamInst where
+ put_ bh (IfaceFamInst fam tys tycon) = do
+ put_ bh fam
+ put_ bh tys
+ put_ bh tycon
+ get bh = do fam <- get bh
+ tys <- get bh
+ tycon <- get bh
+ return (IfaceFamInst fam tys tycon)
+
instance Binary OverlapFlag where
put_ bh NoOverlap = putByte bh 0
put_ bh OverlapOk = putByte bh 1
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
put_ bh IfOpenDataTyCon = putByte bh 1
- put_ bh IfOpenNewTyCon = putByte bh 2
- put_ bh (IfDataTyCon cs) = do { putByte bh 3
+ put_ bh (IfDataTyCon cs) = do { putByte bh 2
; put_ bh cs }
- put_ bh (IfNewTyCon c) = do { putByte bh 4
+ put_ bh (IfNewTyCon c) = do { putByte bh 3
; put_ bh c }
get bh = do
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
1 -> return IfOpenDataTyCon
- 2 -> return IfOpenNewTyCon
- 3 -> do cs <- get bh
+ 2 -> do cs <- get bh
return (IfDataTyCon cs)
_ -> do aa <- get bh
return (IfNewTyCon aa)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
- put_ bh n
+ put_ bh (occNameFS n)
put_ bh def
put_ bh ty
get bh = do
n <- get bh
def <- get bh
ty <- get bh
- return (IfaceClassOp n def ty)
+ occ <- return $! mkOccNameFS varName n
+ return (IfaceClassOp occ def ty)
instance Binary IfaceRule where
put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+instance Binary IfaceVectInfo where
+ put_ bh (IfaceVectInfo a1 a2 a3) = do
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ get bh = do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ return (IfaceVectInfo a1 a2 a3)
+
projects / ghc-hetmet.git / blobdiff