--
-- Binary interface file support.
-module BinIface ( writeBinIface ) where
+module BinIface ( writeBinIface, readBinIface ) where
+
+#include "HsVersions.h"
import HscTypes
import BasicTypes
import HsCore
import HsDecls
import HsBinds
+import HsPat ( HsConDetails(..) )
import TyCon
import Class
import VarEnv
import CostCentre
-import Name ( Name, nameOccName )
+import RdrName ( mkRdrUnqual, mkRdrQual )
+import Name ( Name, nameOccName, nameModule_maybe )
import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts )
+import Module ( moduleName )
import OccName ( OccName )
-import RnMonad ( ParsedIface(..) )
import RnHsSyn
import DriverState ( v_Build_tag )
import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
-import StringBuffer ( hGetStringBuffer )
import Panic
import SrcLoc
-
import Binary
-import IOExts ( readIORef )
+import DATA_IOREF ( readIORef )
+import EXCEPTION ( throwDyn )
import Monad ( when )
-import Exception ( throwDyn )
#include "HsVersions.h"
+-- ---------------------------------------------------------------------------
+-- We write out a ModIface, but read it in as a ParsedIface.
+-- There are some big differences, and some subtle ones. We do most
+-- of the conversion on the way out, so there is minimal fuss when we
+-- read it back in again (see RnMonad.lhs)
+
+-- The main difference is that all Names in a ModIface are RdrNames in
+-- a ParsedIface, so when writing out a Name in binary we make sure it
+-- is binary-compatible with a RdrName.
+
+-- Other subtle differences:
+-- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
+-- Modules as ModuleNames.
+-- - pi_exports and pi_usages, Names have
+-- to be converted to OccNames.
+-- - pi_fixity is a NameEnv in ModIface,
+-- but a list of (Name,Fixity) pairs in ParsedIface.
+-- - versioning is totally different.
+-- - deprecations are different.
+
+writeBinIface :: FilePath -> ModIface -> IO ()
+writeBinIface hi_path mod_iface
+ = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
+
+readBinIface :: FilePath -> IO ParsedIface
+readBinIface hi_path = getBinFileWithDict hi_path
+
+
+-- %*********************************************************
+-- %* *
+-- All the Binary instances
+-- %* *
+-- %*********************************************************
+
-- BasicTypes
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
+instance Binary Name where
+ -- we must print these as RdrNames, because that's how they will be read in
+ put_ bh name
+ = case nameModule_maybe name of
+ Just mod
+ | this_mod == mod -> put_ bh (mkRdrUnqual occ)
+ | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ)
+ _ -> put_ bh (mkRdrUnqual occ)
+ where
+ occ = nameOccName name
+ (this_mod,_,_,_) = getUserData bh
+
+ get bh = error "can't Binary.get a Name"
+
-- NewDemand
{-! for Demand derive: Binary !-}
{-! for Demands derive: Binary !-}
{-! for ConDetails derive: Binary !-}
{-! for BangType derive: Binary !-}
-instance (Binary name) => Binary (TyClDecl name pat) where
+instance (Binary name) => Binary (TyClDecl name) where
put_ bh (IfaceSig name ty idinfo _) = do
putByte bh 0
put_ bh name
lazyPut bh idinfo
put_ bh (ForeignType ae af ag ah) =
error "Binary.put_(TyClDecl): ForeignType"
- put_ bh (TyData ai aj ak al am an ao _) = do
+ put_ bh (TyData ai aj ak al am _ (Just generics) _) = do
putByte bh 2
put_ bh ai
put_ bh aj
put_ bh al
put_ bh am
-- ignore Derivs
- put_ bh ao -- store the SysNames for now (later: derive them)
+ put_ bh generics -- Record whether generics needed or not
put_ bh (TySynonym aq ar as _) = do
putByte bh 3
put_ bh aq
put_ bh ar
put_ bh as
- put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ sysnames _) = do
+ put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do
putByte bh 4
put_ bh ctxt
put_ bh nm
put_ bh fds
put_ bh sigs
-- ignore methods (there should be none)
- put_ bh sysnames
-- ignore SrcLoc
get bh = do
h <- getByte bh
nm <- get bh
tyvars <- get bh
cons <- get bh
- sysnames <- get bh
+ generics <- get bh
return (TyData n_or_d ctx nm tyvars cons
- Nothing sysnames noSrcLoc)
+ Nothing (Just generics) noSrcLoc)
3 -> do
aq <- get bh
ar <- get bh
tyvars <- get bh
fds <- get bh
sigs <- get bh
- sysnames <- get bh
return (ClassDecl ctxt nm tyvars fds sigs
- Nothing sysnames noSrcLoc)
+ Nothing noSrcLoc)
instance (Binary name) => Binary (ConDecl name) where
- put_ bh (ConDecl aa ab ac ad ae _) = do
+ put_ bh (ConDecl aa ac ad ae _) = do
put_ bh aa
- put_ bh ab
put_ bh ac
put_ bh ad
put_ bh ae
-- ignore SrcLoc
get bh = do
aa <- get bh
- ab <- get bh
ac <- get bh
ad <- get bh
ae <- get bh
- return (ConDecl aa ab ac ad ae noSrcLoc)
+ return (ConDecl aa ac ad ae noSrcLoc)
-instance (Binary name) => Binary (InstDecl name pat) where
+instance (Binary name) => Binary (InstDecl name) where
put_ bh (InstDecl aa _ _ ad _) = do
put_ bh aa
-- ignore MonoBinds
ad <- get bh
return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
-instance (Binary name) => Binary (RuleDecl name pat) where
+instance (Binary name) => Binary (RuleDecl name) where
put_ bh (IfaceRule ag ah ai aj ak al _) = do
put_ bh ag
put_ bh ah
{-! for IsDupdCC derive: Binary !-}
{-! for CostCentre derive: Binary !-}
--- ---------------------------------------------------------------------------
--- HscTypes
-
--- NB. we write out a ModIface, but read it in as a ParsedIface.
--- There are some big differences, and some subtle ones. We do most
--- of the conversion on the way out, so there is minimal fuss when we
--- read it back in again (see RnMonad.lhs)
--- The main difference is that all Names in a ModIface are RdrNames in
--- a ParsedIface, so when writing out a Name in binary we make sure it
--- is binary-compatible with a RdrName.
-
--- Other subtle differences:
--- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
--- Modules as ModuleNames.
--- - pi_exports and pi_usages, Names have
--- to be converted to OccNames.
--- - pi_fixity is a NameEnv in ModIface,
--- but a list of (Name,Fixity) pairs in ParsedIface.
--- - versioning is totally different.
--- - deprecations are different.
instance Binary ModIface where
put_ bh iface = do
build_tag <- readIORef v_Build_tag
put_ bh (show opt_HiVersion ++ build_tag)
- p <- put_ bh (mi_module iface)
+ p <- put_ bh (moduleName (mi_module iface))
put_ bh (mi_package iface)
put_ bh (vers_module (mi_version iface))
put_ bh (mi_orphan iface)
-- no: mi_boot
- put_ bh (map importVersionNameToOccName (mi_usages iface))
+ lazyPut bh (mi_deps iface)
+ lazyPut bh (map usageToOccName (mi_usages iface))
put_ bh (vers_exports (mi_version iface),
map exportItemToRdrExportItem (mi_exports iface))
put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
- -- Read in an a ParsedIface, not a ModIface. See above.
+ -- Read in as a ParsedIface, not a ModIface. See above.
get bh = error "Binary.get: ModIface"
declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
{-! for WhatsImported derive: Binary !-}
-- For binary interfaces we need to convert the ImportVersion Names to OccNames
-importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
-importVersionNameToOccName (mod, orphans, boot, what)
- = (mod, orphans, boot, fiddle_with what)
- where fiddle_with NothingAtAll = NothingAtAll
- fiddle_with (Everything v) = Everything v
- fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
- where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
-
+usageToOccName :: Usage Name -> Usage OccName
+usageToOccName usg
+ = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] }
exportItemToRdrExportItem (mn, avails)
= (mn, map availInfoToRdrAvailInfo avails)
put_ bh pkg_name
put_ bh module_ver
put_ bh orphan
- put_ bh usages
+ lazyPut bh usages
put_ bh exports
put_ bh tycl_decls
put_ bh fixities
pkg_name <- get bh
module_ver <- get bh
orphan <- get bh
- usages <- get bh
- exports <- get bh
- tycl_decls <- get bh
- fixities <- get bh
- insts <- get bh
- rules <- lazyGet bh
- deprecs <- lazyGet bh
+ deps <- lazyGet bh
+ usages <- {-# SCC "bin_usages" #-} lazyGet bh
+ exports <- {-# SCC "bin_exports" #-} get bh
+ tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh
+ fixities <- {-# SCC "bin_fixities" #-} get bh
+ insts <- {-# SCC "bin_insts" #-} get bh
+ rules <- {-# SCC "bin_rules" #-} lazyGet bh
+ deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
return (ParsedIface {
pi_mod = module_name,
pi_pkg = pkg_name,
pi_vers = module_ver,
pi_orphan = orphan,
+ pi_deps = deps,
pi_usages = usages,
pi_exports = exports,
pi_decls = tycl_decls,
pi_deprecs = deprecs })
-- ----------------------------------------------------------------------------
--- Writing a binary interface
-
-writeBinIface :: FilePath -> ModIface -> IO ()
-writeBinIface hi_path mod_iface =
- putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
-
--- ----------------------------------------------------------------------------
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
-- Imported from other files :-
ac <- get bh
return (AvailTC ab ac)
-instance (Binary name) => Binary (WhatsImported name) where
- put_ bh NothingAtAll = do
- putByte bh 0
- put_ bh (Everything aa) = do
- putByte bh 1
- put_ bh aa
- put_ bh (Specifically ab ac ad ae) = do
- putByte bh 2
- put_ bh ab
- put_ bh ac
- put_ bh ad
- put_ bh ae
+instance (Binary name) => Binary (Usage name) where
+ put_ bh usg = do
+ put_ bh (usg_name usg)
+ put_ bh (usg_mod usg)
+ put_ bh (usg_exports usg)
+ put_ bh (usg_entities usg)
+ put_ bh (usg_rules usg)
+
get bh = do
- h <- getByte bh
- case h of
- 0 -> do return NothingAtAll
- 1 -> do aa <- get bh
- return (Everything aa)
- _ -> do ab <- get bh
- ac <- get bh
- ad <- get bh
- ae <- get bh
- return (Specifically ab ac ad ae)
+ nm <- get bh
+ mod <- get bh
+ exps <- get bh
+ ents <- get bh
+ rules <- get bh
+ return (Usage { usg_name = nm, usg_mod = mod,
+ usg_exports = exps, usg_entities = ents,
+ usg_rules = rules })
instance Binary Activation where
put_ bh NeverActive = do
ab <- get bh
return (Fixity aa ab)
+instance (Binary name) => Binary (FixitySig name) where
+ put_ bh (FixitySig aa ab _) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ return (FixitySig aa ab noSrcLoc)
+
instance (Binary name) => Binary (IPName name) where
put_ bh (Dupable aa) = do
putByte bh 0
h <- getByte bh
case h of
0 -> do return TopRes
- 1 -> do return retCPR
+ 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
+ -- The wrapper was generated for CPR in
+ -- the imported module!
_ -> do return BotRes
instance Binary StrictSig where
ac <- get bh
return (IfaceTyVar ab ac)
-instance (Binary name) => Binary (HsTupCon name) where
- put_ bh (HsTupCon aa ab ac) = do
- put_ bh aa
+instance Binary HsTupCon where
+ put_ bh (HsTupCon ab ac) = do
put_ bh ab
put_ bh ac
get bh = do
- aa <- get bh
ab <- get bh
ac <- get bh
- return (HsTupCon aa ab ac)
+ return (HsTupCon ab ac)
+
+instance (Binary name) => Binary (HsTyOp name) where
+ put_ bh HsArrow = putByte bh 0
+ put_ bh (HsTyOp n) = do putByte bh 1
+ put_ bh n
+
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return HsArrow
+ 1 -> do a <- get bh
+ return (HsTyOp a)
instance (Binary name) => Binary (HsType name) where
put_ bh (HsForAllTy aa ab ac) = do
ab <- get bh
return (BangType aa ab)
-instance (Binary name) => Binary (ConDetails name) where
- put_ bh (VanillaCon aa) = do
+instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
+ put_ bh (PrefixCon aa) = do
putByte bh 0
put_ bh aa
put_ bh (InfixCon ab ac) = do
h <- getByte bh
case h of
0 -> do aa <- get bh
- return (VanillaCon aa)
+ return (PrefixCon aa)
1 -> do ab <- get bh
ac <- get bh
return (InfixCon ab ac)
return (NormalCC aa ab ac ad)
_ -> do ae <- get bh
return (AllCafsCC ae)
-
-
projects / ghc-hetmet.git / blobdiff