X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FBinIface.hs;h=e489fb2ed2d2ddbbccc726d615b9e9bf6e2ca6ab;hb=3a223cd2811d46295048b3a2dab11403ca291b20;hp=f949171ae85c06589fc2d5fb2af2a768c149a50c;hpb=1b853dc9d423bd74625fdf8f1293ce7127d43189;p=ghc-hetmet.git diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index f949171..e489fb2 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -5,7 +5,9 @@ -- -- Binary interface file support. -module BinIface ( writeBinIface ) where +module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where + +#include "HsVersions.h" import HscTypes import BasicTypes @@ -14,29 +16,64 @@ import HsTypes 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 Util -import IOExts ( readIORef ) +import DATA_IOREF +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 !-} @@ -46,6 +83,20 @@ import Exception ( throwDyn ) {-! 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 !-} @@ -81,7 +132,7 @@ instance Binary DmdType where {-! 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 @@ -89,7 +140,7 @@ instance (Binary name) => Binary (TyClDecl name pat) where 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 @@ -97,13 +148,13 @@ instance (Binary name) => Binary (TyClDecl name pat) where 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 @@ -111,7 +162,6 @@ instance (Binary name) => Binary (TyClDecl name pat) where put_ bh fds put_ bh sigs -- ignore methods (there should be none) - put_ bh sysnames -- ignore SrcLoc get bh = do h <- getByte bh @@ -130,9 +180,9 @@ instance (Binary name) => Binary (TyClDecl name pat) where 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 @@ -144,27 +194,24 @@ instance (Binary name) => Binary (TyClDecl name pat) where 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 @@ -176,7 +223,7 @@ instance (Binary name) => Binary (InstDecl name pat) where 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 @@ -217,38 +264,19 @@ instance Binary name => Binary (Sig name) where {-! 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)) @@ -260,7 +288,7 @@ instance Binary ModIface where 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 @@ -283,14 +311,9 @@ deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env)) {-! 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) @@ -323,7 +346,7 @@ instance Binary ParsedIface where 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 @@ -332,9 +355,10 @@ instance Binary ParsedIface where lazyPut bh deprecs get bh = do check_ver <- get bh + ignore_ver <- readIORef v_IgnoreHiVersion build_tag <- readIORef v_Build_tag let our_ver = show opt_HiVersion ++ build_tag - when (check_ver /= our_ver) $ + when (check_ver /= our_ver && not ignore_ver) $ -- use userError because this will be caught by readIface -- which will emit an error msg containing the iface module name. throwDyn (ProgramError ( @@ -344,18 +368,20 @@ instance Binary ParsedIface where 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, @@ -364,18 +390,23 @@ instance Binary ParsedIface where pi_rules = rules, 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 +GLOBAL_VAR(v_IgnoreHiVersion, False, Bool) -- ---------------------------------------------------------------------------- {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} -- Imported from other files :- +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) + instance (Binary name) => Binary (GenAvailInfo name) where put_ bh (Avail aa) = do putByte bh 0 @@ -393,29 +424,23 @@ instance (Binary name) => Binary (GenAvailInfo name) where 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 @@ -500,6 +525,15 @@ instance Binary Fixity where 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 @@ -604,16 +638,25 @@ instance (Binary name) => Binary (HsTyVarBndr name) 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 @@ -897,6 +940,9 @@ instance (Binary name) => Binary (UfNote name) where putByte bh 2 put_ bh UfInlineMe = do putByte bh 3 + put_ bh (UfCoreNote s) = do + putByte bh 4 + put_ bh s get bh = do h <- getByte bh case h of @@ -905,7 +951,9 @@ instance (Binary name) => Binary (UfNote name) where 1 -> do ab <- get bh return (UfCoerce ab) 2 -> do return UfInlineCall - _ -> do return UfInlineMe + 3 -> do return UfInlineMe + _ -> do ac <- get bh + return (UfCoreNote ac) instance (Binary name) => Binary (BangType name) where put_ bh (BangType aa ab) = do @@ -916,8 +964,8 @@ instance (Binary name) => Binary (BangType name) where 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 @@ -931,7 +979,7 @@ instance (Binary name) => Binary (ConDetails name) where 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) @@ -1017,5 +1065,3 @@ instance Binary CostCentre where return (NormalCC aa ab ac ad) _ -> do ae <- get bh return (AllCafsCC ae) - -