import NewDemand
import IfaceSyn
import VarEnv
+import InstEnv ( OverlapFlag(..) )
+import Packages ( PackageIdH(..) )
import Class ( DefMeth(..) )
import CostCentre
-import Module ( moduleName, mkModule )
-import DriverState ( v_Build_tag )
-import CmdLineOpts ( opt_HiVersion )
+import StaticFlags ( opt_HiVersion, v_Build_tag )
import Kind ( Kind(..) )
import Panic
import Binary
import Util
+import Config ( cGhcUnregisterised )
import DATA_IOREF
import EXCEPTION ( throwDyn )
instance Binary ModIface where
put_ bh (ModIface {
mi_module = mod,
+ mi_boot = is_boot,
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_rules = rules,
mi_rule_vers = rule_vers }) = do
put_ bh (show opt_HiVersion)
- build_tag <- readIORef v_Build_tag
- put bh build_tag
- put_ bh pkg_name
- put_ bh (moduleName mod)
+ way_descr <- getWayDescr
+ put bh way_descr
+ put_ bh mod
+ put_ bh is_boot
put_ bh mod_vers
put_ bh orphan
lazyPut bh deps
check_way <- get bh
ignore_way <- readIORef v_IgnoreHiWay
- build_tag <- readIORef v_Build_tag
- when (not ignore_way && check_way /= build_tag) $
+ 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 "
- ++ build_tag ++ ", found " ++ check_way))
+ ++ way_descr ++ ", found " ++ check_way))
- pkg_name <- get bh
mod_name <- get bh
-
+ is_boot <- get bh
mod_vers <- get bh
orphan <- get bh
deps <- lazyGet 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 = HomePackage, -- to be filled in properly later
+ mi_module = mod_name,
+ mi_boot = is_boot,
mi_mod_vers = mod_vers,
- mi_boot = False, -- Binary interfaces are never .hi-boot files!
mi_orphan = orphan,
mi_deps = deps,
mi_usages = usages,
mi_fixities = fixities,
mi_deprecs = deprecs,
mi_decls = decls,
+ mi_globals = Nothing,
mi_insts = insts,
mi_rules = rules,
mi_rule_vers = rule_vers,
GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
+getWayDescr :: IO String
+getWayDescr = do
+ tag <- readIORef v_Build_tag
+ if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
+ -- if this is an unregisterised build, make sure our interfaces
+ -- can't be used by a registerised build.
+
-------------------------------------------------------------------------
-- Types from: HscTypes
-------------------------------------------------------------------------
instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated
- put_ bh IfaceListTc = putByte bh 1
- put_ bh IfacePArrTc = putByte bh 2
- put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
- put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance
+
+ put_ bh IfaceIntTc = putByte bh 1
+ put_ bh IfaceBoolTc = putByte bh 2
+ put_ bh IfaceCharTc = putByte bh 3
+ put_ bh IfaceListTc = putByte bh 4
+ put_ bh IfacePArrTc = putByte bh 5
+ put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar }
+ put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext }
get bh = do
h <- getByte bh
case h of
- 1 -> return IfaceListTc
- 2 -> return IfacePArrTc
- _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+ 1 -> return IfaceIntTc
+ 2 -> return IfaceBoolTc
+ 3 -> return IfaceCharTc
+ 4 -> return IfaceListTc
+ 5 -> return IfacePArrTc
+ 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
+ _ -> do { ext <- get bh; return (IfaceTc ext) }
instance Binary IfacePredType where
put_ bh (IfaceClassP 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 NoInfo = putByte bh 0
put_ bh (HasInfo i) = do
putByte bh 1
- lazyPut bh i
- put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo"
+ lazyPut bh i -- NB lazyPut
get bh = do
h <- getByte bh
case h of
0 -> return NoInfo
- _ -> do info <- lazyGet bh
+ _ -> do info <- lazyGet bh -- NB lazyGet
return (HasInfo info)
instance Binary IfaceInfoItem where
return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceInst where
- put_ bh (IfaceInst ty dfun) = do
- put_ bh ty
+ put_ bh (IfaceInst cls tys dfun flag orph) = do
+ put_ bh cls
+ put_ bh tys
put_ bh dfun
- get bh = do ty <- get bh
+ put_ bh flag
+ put_ bh orph
+ get bh = do cls <- get bh
+ tys <- get bh
dfun <- get bh
- return (IfaceInst ty dfun)
+ flag <- get bh
+ orph <- get bh
+ return (IfaceInst cls tys dfun flag orph)
+
+instance Binary OverlapFlag where
+ put_ bh NoOverlap = putByte bh 0
+ put_ bh OverlapOk = putByte bh 1
+ put_ bh Incoherent = putByte bh 2
+ get bh = do h <- getByte bh
+ case h of
+ 0 -> return NoOverlap
+ 1 -> return OverlapOk
+ 2 -> return Incoherent
instance Binary IfaceConDecls where
put_ bh IfAbstractTyCon = putByte bh 0
h <- getByte bh
case h of
0 -> return IfAbstractTyCon
- 1 -> do aa <- get bh
- return (IfDataTyCon aa)
+ 1 -> do cs <- get bh
+ return (IfDataTyCon 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
return (IfaceClassOp n def ty)
instance Binary IfaceRule where
- -- IfaceBuiltinRule should not happen here
- put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
+ put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
put_ bh a6
+ put_ bh a7
get bh = do
a1 <- get bh
a2 <- get bh
a4 <- get bh
a5 <- get bh
a6 <- get bh
- return (IfaceRule a1 a2 a3 a4 a5 a6)
+ a7 <- get bh
+ return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
projects / ghc-hetmet.git / blobdiff