--
-- Binary interface file support.
-module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where
+module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
#include "HsVersions.h"
import NewDemand
import IfaceSyn
import VarEnv
-import TyCon ( DataConDetails(..) )
import Class ( DefMeth(..) )
import CostCentre
-import Module ( moduleName, mkModule )
-import OccName ( OccName )
import DriverState ( v_Build_tag )
import CmdLineOpts ( opt_HiVersion )
+import Kind ( Kind(..) )
import Panic
import Binary
import Util
{-! for IPName derive: Binary !-}
{-! for Fixity derive: Binary !-}
{-! for FixityDirection derive: Binary !-}
-{-! for NewOrData derive: Binary !-}
{-! for Boxity derive: Binary !-}
{-! for StrictnessMark derive: Binary !-}
{-! for Activation derive: Binary !-}
{-! for DmdResult derive: Binary !-}
{-! for StrictSig derive: Binary !-}
--- TyCon
-{-! for DataConDetails derive: Binary !-}
-
-- Class
{-! for DefMeth derive: Binary !-}
put_ bh (ModIface {
mi_module = mod,
mi_mod_vers = mod_vers,
- mi_package = pkg_name,
+ mi_package = _, -- we ignore the package on output
mi_orphan = orphan,
mi_deps = deps,
mi_usages = usages,
mi_insts = insts,
mi_rules = rules,
mi_rule_vers = rule_vers }) = do
+ put_ bh (show opt_HiVersion)
build_tag <- readIORef v_Build_tag
- put_ bh (show opt_HiVersion ++ build_tag)
- put_ bh pkg_name
- put_ bh (moduleName mod)
+ put bh build_tag
+ put_ bh mod
put_ bh mod_vers
put_ bh orphan
lazyPut bh deps
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 && not ignore_ver) $
+ 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))
- pkg_name <- get bh
+ check_way <- get bh
+ ignore_way <- readIORef v_IgnoreHiWay
+ build_tag <- readIORef v_Build_tag
+ when (not ignore_way && check_way /= build_tag) $
+ -- 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 "
+ ++ build_tag ++ ", found " ++ check_way))
+
mod_name <- get bh
mod_vers <- get bh
rules <- {-# SCC "bin_rules" #-} lazyGet bh
rule_vers <- get bh
return (ModIface {
- mi_package = pkg_name,
- mi_module = mkModule pkg_name mod_name,
- -- We write the module as a ModuleName, becuase whether
- -- or not it's a home-package module depends on the importer
- -- mkModule reconstructs the Module, by comparing the static
- -- opt_InPackage flag with the package name in the interface file
+ mi_package = ThisPackage, -- to be filled in properly later
+ mi_module = mod_name,
mi_mod_vers = mod_vers,
mi_boot = False, -- Binary interfaces are never .hi-boot files!
mi_orphan = orphan,
mi_fix_fn = mkIfaceFixCache fixities,
mi_ver_fn = mkIfaceVerCache decls })
-GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)
+GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
-------------------------------------------------------------------------
-- Types from: HscTypes
ac <- get bh
return (TupCon ab ac)
-instance Binary NewOrData where
- put_ bh NewType = do
- putByte bh 0
- put_ bh DataType = do
- putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do return NewType
- _ -> do return DataType
-
instance Binary RecFlag where
put_ bh Recursive = do
putByte bh 0
_ -> do ab <- get bh
return (IfaceTvBndr ab)
-instance Binary IfaceKind where
- put_ bh IfaceLiftedTypeKind = putByte bh 0
- put_ bh IfaceUnliftedTypeKind = putByte bh 1
- put_ bh IfaceOpenTypeKind = putByte bh 2
- put_ bh (IfaceFunKind k1 k2) = do
- putByte bh 3
+instance Binary Kind where
+ put_ bh LiftedTypeKind = putByte bh 0
+ put_ bh UnliftedTypeKind = putByte bh 1
+ put_ bh OpenTypeKind = putByte bh 2
+ put_ bh ArgTypeKind = putByte bh 3
+ put_ bh UbxTupleKind = putByte bh 4
+ put_ bh (FunKind k1 k2) = do
+ putByte bh 5
put_ bh k1
put_ bh k2
+ put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
+
get bh = do
h <- getByte bh
case h of
- 0 -> return IfaceLiftedTypeKind
- 1 -> return IfaceUnliftedTypeKind
- 2 -> return IfaceOpenTypeKind
+ 0 -> return LiftedTypeKind
+ 1 -> return UnliftedTypeKind
+ 2 -> return OpenTypeKind
+ 3 -> return ArgTypeKind
+ 4 -> return UbxTupleKind
_ -> do k1 <- get bh
k2 <- get bh
- return (IfaceFunKind k1 k2)
+ return (FunKind k1 k2)
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
putByte bh 4
put_ bh ag
put_ bh ah
- put_ bh (IfaceCase ai aj ak) = do
+-- gaw 2004
+ put_ bh (IfaceCase ai aj al ak) = do
putByte bh 5
put_ bh ai
put_ bh aj
+-- gaw 2004
+ put_ bh al
put_ bh ak
put_ bh (IfaceLet al am) = do
putByte bh 6
return (IfaceApp ag ah)
5 -> do ai <- get bh
aj <- get bh
+-- gaw 2004
+ al <- get bh
ak <- get bh
- return (IfaceCase ai aj ak)
+-- gaw 2004
+ return (IfaceCase ai aj al ak)
6 -> do al <- get bh
am <- get bh
return (IfaceLet al am)
put_ bh (HasInfo i) = do
putByte bh 1
lazyPut bh i
- put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo"
get bh = do
h <- getByte bh
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
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
putByte bh 2
put_ bh a1
put_ bh a2
put_ bh a4
put_ bh a5
put_ bh a6
- put_ bh a7
- put_ bh a8
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
a4 <- get bh
a5 <- get bh
a6 <- get bh
- a7 <- get bh
- a8 <- get bh
- return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
+ return (IfaceData a1 a2 a3 a4 a5 a6)
3 -> do
aq <- get bh
ar <- get bh
dfun <- get bh
return (IfaceInst ty dfun)
+instance Binary IfaceConDecls where
+ put_ bh IfAbstractTyCon = putByte bh 0
+ put_ bh (IfDataTyCon st cs) = do { putByte bh 1
+ ; put_ bh st
+ ; put_ bh cs }
+ put_ bh (IfNewTyCon c) = do { putByte bh 2
+ ; put_ bh c }
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfAbstractTyCon
+ 1 -> do st <- get bh
+ cs <- get bh
+ return (IfDataTyCon st cs)
+ _ -> do aa <- get bh
+ return (IfNewTyCon aa)
+
instance Binary IfaceConDecl where
- put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
+ put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
+ putByte bh 0
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
+ putByte bh 1
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a5
put_ bh a6
get bh = do
- a1 <- get bh
- a2 <- get bh
- a3 <- get bh
- a4 <- get bh
- a5 <- get bh
- a6 <- get bh
- return (IfaceConDecl a1 a2 a3 a4 a5 a6)
+ h <- getByte bh
+ case h of
+ 0 -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ return (IfVanillaCon a1 a2 a3 a4 a5)
+ _ -> do a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ return (IfGadtCon a1 a2 a3 a4 a5 a6)
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
a6 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6)
-instance (Binary datacon) => Binary (DataConDetails datacon) where
- put_ bh (DataCons aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh Unknown = do
- putByte bh 1
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (DataCons aa)
- _ -> do return Unknown
projects / ghc-hetmet.git / blobdiff