summaryrefslogtreecommitdiff
path: root/compiler/iface/BinIface.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface/BinIface.hs')
-rw-r--r--compiler/iface/BinIface.hs1056
1 files changed, 1056 insertions, 0 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
new file mode 100644
index 0000000000..6d02fe00c7
--- /dev/null
+++ b/compiler/iface/BinIface.hs
@@ -0,0 +1,1056 @@
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Binary interface file support.
+
+module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
+
+#include "HsVersions.h"
+
+import HscTypes
+import BasicTypes
+import NewDemand
+import IfaceSyn
+import VarEnv
+import InstEnv ( OverlapFlag(..) )
+import Packages ( PackageIdH(..) )
+import Class ( DefMeth(..) )
+import CostCentre
+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 )
+import Monad ( when )
+import Outputable
+
+#include "HsVersions.h"
+
+-- ---------------------------------------------------------------------------
+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
+-- %* *
+-- %*********************************************************
+
+-- BasicTypes
+{-! for IPName derive: Binary !-}
+{-! for Fixity derive: Binary !-}
+{-! for FixityDirection derive: Binary !-}
+{-! for Boxity derive: Binary !-}
+{-! for StrictnessMark derive: Binary !-}
+{-! for Activation derive: Binary !-}
+
+-- NewDemand
+{-! for Demand derive: Binary !-}
+{-! for Demands derive: Binary !-}
+{-! for DmdResult derive: Binary !-}
+{-! for StrictSig derive: Binary !-}
+
+-- Class
+{-! for DefMeth derive: Binary !-}
+
+-- HsTypes
+{-! for HsPred derive: Binary !-}
+{-! for HsType derive: Binary !-}
+{-! for TupCon derive: Binary !-}
+{-! for HsTyVarBndr derive: Binary !-}
+
+-- HsCore
+{-! for UfExpr derive: Binary !-}
+{-! for UfConAlt derive: Binary !-}
+{-! for UfBinding derive: Binary !-}
+{-! for UfBinder derive: Binary !-}
+{-! for HsIdInfo derive: Binary !-}
+{-! for UfNote derive: Binary !-}
+
+-- HsDecls
+{-! for ConDetails derive: Binary !-}
+{-! for BangType derive: Binary !-}
+
+-- CostCentre
+{-! for IsCafCC derive: Binary !-}
+{-! for IsDupdCC derive: Binary !-}
+{-! for CostCentre derive: Binary !-}
+
+
+
+-- ---------------------------------------------------------------------------
+-- Reading a binary interface into ParsedIface
+
+instance Binary ModIface where
+ put_ bh (ModIface {
+ mi_module = mod,
+ mi_boot = is_boot,
+ mi_mod_vers = mod_vers,
+ mi_package = _, -- we ignore the package on output
+ mi_orphan = orphan,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = exports,
+ mi_exp_vers = exp_vers,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+ mi_decls = decls,
+ mi_insts = insts,
+ mi_rules = rules,
+ mi_rule_vers = rule_vers }) = do
+ put_ bh (show opt_HiVersion)
+ way_descr <- getWayDescr
+ put bh way_descr
+ put_ bh mod
+ put_ bh is_boot
+ put_ bh mod_vers
+ put_ bh orphan
+ lazyPut bh deps
+ lazyPut bh usages
+ put_ bh exports
+ put_ bh exp_vers
+ put_ bh fixities
+ lazyPut bh deprecs
+ put_ bh decls
+ put_ bh insts
+ lazyPut bh rules
+ put_ bh rule_vers
+
+ 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
+ deps <- lazyGet bh
+ usages <- {-# SCC "bin_usages" #-} lazyGet bh
+ exports <- {-# SCC "bin_exports" #-} get bh
+ exp_vers <- get bh
+ fixities <- {-# SCC "bin_fixities" #-} get bh
+ deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
+ decls <- {-# SCC "bin_tycldecls" #-} get bh
+ insts <- {-# SCC "bin_insts" #-} get bh
+ rules <- {-# SCC "bin_rules" #-} lazyGet bh
+ rule_vers <- get bh
+ return (ModIface {
+ mi_package = HomePackage, -- to be filled in properly later
+ mi_module = mod_name,
+ mi_boot = is_boot,
+ mi_mod_vers = mod_vers,
+ mi_orphan = orphan,
+ mi_deps = deps,
+ mi_usages = usages,
+ mi_exports = exports,
+ mi_exp_vers = exp_vers,
+ mi_fixities = fixities,
+ mi_deprecs = deprecs,
+ mi_decls = decls,
+ mi_globals = Nothing,
+ mi_insts = insts,
+ mi_rules = rules,
+ mi_rule_vers = rule_vers,
+ -- And build the cached values
+ mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_fix_fn = mkIfaceFixCache fixities,
+ mi_ver_fn = mkIfaceVerCache decls })
+
+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 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
+ put_ bh aa
+ put_ bh (AvailTC ab ac) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Avail aa)
+ _ -> do ab <- get bh
+ ac <- get bh
+ return (AvailTC ab ac)
+
+instance Binary Usage 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
+ 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 a => Binary (Deprecs a) where
+ put_ bh NoDeprecs = putByte bh 0
+ put_ bh (DeprecAll t) = do
+ putByte bh 1
+ put_ bh t
+ put_ bh (DeprecSome ts) = do
+ putByte bh 2
+ put_ bh ts
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoDeprecs
+ 1 -> do aa <- get bh
+ return (DeprecAll aa)
+ _ -> do aa <- get bh
+ return (DeprecSome aa)
+
+-------------------------------------------------------------------------
+-- Types from: BasicTypes
+-------------------------------------------------------------------------
+
+instance Binary Activation where
+ put_ bh NeverActive = do
+ putByte bh 0
+ put_ bh AlwaysActive = do
+ putByte bh 1
+ put_ bh (ActiveBefore aa) = do
+ putByte bh 2
+ put_ bh aa
+ put_ bh (ActiveAfter ab) = do
+ putByte bh 3
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return NeverActive
+ 1 -> do return AlwaysActive
+ 2 -> do aa <- get bh
+ return (ActiveBefore aa)
+ _ -> do ab <- get bh
+ return (ActiveAfter ab)
+
+instance Binary StrictnessMark where
+ put_ bh MarkedStrict = do
+ putByte bh 0
+ put_ bh MarkedUnboxed = do
+ putByte bh 1
+ put_ bh NotMarkedStrict = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return MarkedStrict
+ 1 -> do return MarkedUnboxed
+ _ -> do return NotMarkedStrict
+
+instance Binary Boxity where
+ put_ bh Boxed = do
+ putByte bh 0
+ put_ bh Unboxed = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Boxed
+ _ -> do return Unboxed
+
+instance Binary TupCon where
+ put_ bh (TupCon ab ac) = do
+ put_ bh ab
+ put_ bh ac
+ get bh = do
+ ab <- get bh
+ ac <- get bh
+ return (TupCon ab ac)
+
+instance Binary RecFlag where
+ put_ bh Recursive = do
+ putByte bh 0
+ put_ bh NonRecursive = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Recursive
+ _ -> do return NonRecursive
+
+instance Binary DefMeth where
+ put_ bh NoDefMeth = putByte bh 0
+ put_ bh DefMeth = putByte bh 1
+ put_ bh GenDefMeth = putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoDefMeth
+ 1 -> return DefMeth
+ _ -> return GenDefMeth
+
+instance Binary FixityDirection where
+ put_ bh InfixL = do
+ putByte bh 0
+ put_ bh InfixR = do
+ putByte bh 1
+ put_ bh InfixN = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return InfixL
+ 1 -> do return InfixR
+ _ -> do return InfixN
+
+instance Binary Fixity where
+ put_ bh (Fixity aa ab) = do
+ put_ bh aa
+ put_ bh ab
+ get bh = do
+ aa <- get bh
+ ab <- get bh
+ 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)
+
+-------------------------------------------------------------------------
+-- Types from: Demand
+-------------------------------------------------------------------------
+
+instance Binary DmdType where
+ -- Ignore DmdEnv when spitting out the DmdType
+ put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
+ get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
+
+instance Binary Demand where
+ put_ bh Top = do
+ putByte bh 0
+ put_ bh Abs = do
+ putByte bh 1
+ put_ bh (Call aa) = do
+ putByte bh 2
+ put_ bh aa
+ put_ bh (Eval ab) = do
+ putByte bh 3
+ put_ bh ab
+ put_ bh (Defer ac) = do
+ putByte bh 4
+ put_ bh ac
+ put_ bh (Box ad) = do
+ putByte bh 5
+ put_ bh ad
+ put_ bh Bot = do
+ putByte bh 6
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return Top
+ 1 -> do return Abs
+ 2 -> do aa <- get bh
+ return (Call aa)
+ 3 -> do ab <- get bh
+ return (Eval ab)
+ 4 -> do ac <- get bh
+ return (Defer ac)
+ 5 -> do ad <- get bh
+ return (Box ad)
+ _ -> do return Bot
+
+instance Binary Demands where
+ put_ bh (Poly aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (Prod ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (Poly aa)
+ _ -> do ab <- get bh
+ return (Prod ab)
+
+instance Binary DmdResult where
+ put_ bh TopRes = do
+ putByte bh 0
+ put_ bh RetCPR = do
+ putByte bh 1
+ put_ bh BotRes = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return TopRes
+ 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
+ put_ bh (StrictSig aa) = do
+ put_ bh aa
+ get bh = do
+ aa <- get bh
+ return (StrictSig aa)
+
+
+-------------------------------------------------------------------------
+-- Types from: CostCentre
+-------------------------------------------------------------------------
+
+instance Binary IsCafCC where
+ put_ bh CafCC = do
+ putByte bh 0
+ put_ bh NotCafCC = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return CafCC
+ _ -> do return NotCafCC
+
+instance Binary IsDupdCC where
+ put_ bh OriginalCC = do
+ putByte bh 0
+ put_ bh DupdCC = do
+ putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return OriginalCC
+ _ -> do return DupdCC
+
+instance Binary CostCentre where
+ put_ bh NoCostCentre = do
+ putByte bh 0
+ put_ bh (NormalCC aa ab ac ad) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh ab
+ put_ bh ac
+ put_ bh ad
+ put_ bh (AllCafsCC ae) = do
+ putByte bh 2
+ put_ bh ae
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return NoCostCentre
+ 1 -> do aa <- get bh
+ ab <- get bh
+ ac <- get bh
+ ad <- get bh
+ return (NormalCC aa ab ac ad)
+ _ -> do ae <- get bh
+ return (AllCafsCC ae)
+
+-------------------------------------------------------------------------
+-- 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
+ put_ bh aa
+ put_ bh (IfaceTvBndr ab) = do
+ putByte bh 1
+ put_ bh ab
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceIdBndr aa)
+ _ -> do ab <- get bh
+ return (IfaceTvBndr ab)
+
+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 LiftedTypeKind
+ 1 -> return UnliftedTypeKind
+ 2 -> return OpenTypeKind
+ 3 -> return ArgTypeKind
+ 4 -> return UbxTupleKind
+ _ -> do k1 <- get bh
+ k2 <- get bh
+ return (FunKind k1 k2)
+
+instance Binary IfaceType where
+ put_ bh (IfaceForAllTy aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceTyVar ad) = do
+ putByte bh 1
+ put_ bh ad
+ put_ bh (IfaceAppTy ae af) = do
+ putByte bh 2
+ put_ bh ae
+ put_ bh af
+ put_ bh (IfaceFunTy ag ah) = do
+ putByte bh 3
+ put_ bh ag
+ put_ bh ah
+ put_ bh (IfacePredTy aq) = do
+ putByte bh 5
+ put_ bh aq
+
+ -- Simple compression for common cases of TyConApp
+ put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
+ put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
+ put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
+ put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
+ -- Unit tuple and pairs
+ put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) []) = putByte bh 10
+ put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
+ -- Generic cases
+ put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
+ put_ bh (IfaceTyConApp tc tys) = do { putByte bh 13; put_ bh tc; put_ bh tys }
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceForAllTy aa ab)
+ 1 -> do ad <- get bh
+ return (IfaceTyVar ad)
+ 2 -> do ae <- get bh
+ af <- get bh
+ return (IfaceAppTy ae af)
+ 3 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceFunTy ag ah)
+ 5 -> do ap <- get bh
+ return (IfacePredTy ap)
+
+ -- Now the special cases for TyConApp
+ 6 -> return (IfaceTyConApp IfaceIntTc [])
+ 7 -> return (IfaceTyConApp IfaceCharTc [])
+ 8 -> return (IfaceTyConApp IfaceBoolTc [])
+ 9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
+ 10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
+ 11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
+ 12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
+ _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+
+instance Binary IfaceTyCon where
+ -- Int,Char,Bool can't show up here because they can't not be saturated
+
+ 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 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 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceIParam ac ad) = do
+ putByte bh 1
+ put_ bh ac
+ put_ bh ad
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceClassP aa ab)
+ _ -> do ac <- get bh
+ ad <- get bh
+ return (IfaceIParam ac ad)
+
+-------------------------------------------------------------------------
+-- IfaceExpr and friends
+-------------------------------------------------------------------------
+
+instance Binary IfaceExpr where
+ put_ bh (IfaceLcl aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceType ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh (IfaceTuple ac ad) = do
+ putByte bh 2
+ put_ bh ac
+ put_ bh ad
+ put_ bh (IfaceLam ae af) = do
+ putByte bh 3
+ put_ bh ae
+ put_ bh af
+ put_ bh (IfaceApp ag ah) = do
+ putByte bh 4
+ put_ bh ag
+ put_ bh ah
+-- 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
+ put_ bh al
+ put_ bh am
+ put_ bh (IfaceNote an ao) = do
+ putByte bh 7
+ put_ bh an
+ put_ bh ao
+ put_ bh (IfaceLit ap) = do
+ putByte bh 8
+ put_ bh ap
+ put_ bh (IfaceFCall as at) = do
+ putByte bh 9
+ put_ bh as
+ put_ bh at
+ put_ bh (IfaceExt aa) = do
+ putByte bh 10
+ put_ bh aa
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceLcl aa)
+ 1 -> do ab <- get bh
+ return (IfaceType ab)
+ 2 -> do ac <- get bh
+ ad <- get bh
+ return (IfaceTuple ac ad)
+ 3 -> do ae <- get bh
+ af <- get bh
+ return (IfaceLam ae af)
+ 4 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceApp ag ah)
+ 5 -> do ai <- get bh
+ aj <- get bh
+-- gaw 2004
+ al <- get bh
+ ak <- get bh
+-- gaw 2004
+ return (IfaceCase ai aj al ak)
+ 6 -> do al <- get bh
+ am <- get bh
+ return (IfaceLet al am)
+ 7 -> do an <- get bh
+ ao <- get bh
+ return (IfaceNote an ao)
+ 8 -> do ap <- get bh
+ return (IfaceLit ap)
+ 9 -> do as <- get bh
+ at <- get bh
+ return (IfaceFCall as at)
+ _ -> do aa <- get bh
+ return (IfaceExt aa)
+
+instance Binary IfaceConAlt where
+ put_ bh IfaceDefault = do
+ putByte bh 0
+ put_ bh (IfaceDataAlt aa) = do
+ putByte bh 1
+ put_ bh aa
+ put_ bh (IfaceTupleAlt ab) = do
+ putByte bh 2
+ put_ bh ab
+ put_ bh (IfaceLitAlt ac) = do
+ putByte bh 3
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return IfaceDefault
+ 1 -> do aa <- get bh
+ return (IfaceDataAlt aa)
+ 2 -> do ab <- get bh
+ return (IfaceTupleAlt ab)
+ _ -> do ac <- get bh
+ return (IfaceLitAlt ac)
+
+instance Binary IfaceBinding where
+ put_ bh (IfaceNonRec aa ab) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh ab
+ put_ bh (IfaceRec ac) = do
+ putByte bh 1
+ put_ bh ac
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ ab <- get bh
+ return (IfaceNonRec aa ab)
+ _ -> do ac <- get bh
+ return (IfaceRec ac)
+
+instance Binary IfaceIdInfo where
+ put_ bh NoInfo = putByte bh 0
+ put_ bh (HasInfo i) = do
+ putByte bh 1
+ lazyPut bh i -- NB lazyPut
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return NoInfo
+ _ -> do info <- lazyGet bh -- NB lazyGet
+ return (HasInfo info)
+
+instance Binary IfaceInfoItem where
+ put_ bh (HsArity aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (HsStrictness ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh (HsUnfold ac ad) = do
+ putByte bh 2
+ put_ bh ac
+ put_ bh ad
+ put_ bh HsNoCafRefs = do
+ putByte bh 3
+ put_ bh (HsWorker ae af) = do
+ putByte bh 4
+ put_ bh ae
+ put_ bh af
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (HsArity aa)
+ 1 -> do ab <- get bh
+ return (HsStrictness ab)
+ 2 -> do ac <- get bh
+ ad <- get bh
+ return (HsUnfold ac ad)
+ 3 -> do return HsNoCafRefs
+ _ -> do ae <- get bh
+ af <- get bh
+ return (HsWorker ae af)
+
+instance Binary IfaceNote where
+ put_ bh (IfaceSCC aa) = do
+ putByte bh 0
+ put_ bh aa
+ put_ bh (IfaceCoerce ab) = do
+ putByte bh 1
+ put_ bh ab
+ put_ bh IfaceInlineCall = do
+ putByte bh 2
+ put_ bh IfaceInlineMe = do
+ putByte bh 3
+ put_ bh (IfaceCoreNote s) = do
+ putByte bh 4
+ put_ bh s
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do aa <- get bh
+ return (IfaceSCC aa)
+ 1 -> do ab <- get bh
+ return (IfaceCoerce ab)
+ 2 -> do return IfaceInlineCall
+ 3 -> do return IfaceInlineMe
+ _ -> do ac <- get bh
+ return (IfaceCoreNote ac)
+
+
+-------------------------------------------------------------------------
+-- IfaceDecl and friends
+-------------------------------------------------------------------------
+
+instance Binary IfaceDecl where
+ put_ bh (IfaceId name ty idinfo) = do
+ putByte bh 0
+ put_ bh 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) = do
+ putByte bh 2
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+
+ put_ bh (IfaceSyn aq ar as at) = do
+ putByte bh 3
+ put_ bh aq
+ put_ bh ar
+ put_ bh as
+ put_ bh at
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
+ putByte bh 4
+ put_ bh a1
+ put_ bh a2
+ put_ bh a3
+ put_ bh a4
+ put_ bh a5
+ put_ bh a6
+ put_ bh a7
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do name <- get bh
+ ty <- get bh
+ idinfo <- get bh
+ return (IfaceId name ty idinfo)
+ 1 -> error "Binary.get(TyClDecl): ForeignType"
+ 2 -> do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceData a1 a2 a3 a4 a5 a6 a7)
+ 3 -> do
+ aq <- get bh
+ ar <- get bh
+ as <- get bh
+ at <- get bh
+ return (IfaceSyn aq ar as at)
+ _ -> do
+ a1 <- get bh
+ a2 <- get bh
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
+
+instance Binary IfaceInst where
+ put_ bh (IfaceInst cls tys dfun flag orph) = do
+ put_ bh cls
+ put_ bh tys
+ put_ bh dfun
+ put_ bh flag
+ put_ bh orph
+ get bh = do cls <- get bh
+ tys <- get bh
+ dfun <- get bh
+ 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
+ put_ bh (IfDataTyCon cs) = do { putByte bh 1
+ ; 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 cs <- get bh
+ return (IfDataTyCon cs)
+ _ -> do aa <- get bh
+ return (IfNewTyCon aa)
+
+instance Binary IfaceConDecl where
+ 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 a4
+ put_ bh a5
+ put_ bh a6
+ get bh = do
+ 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
+ put_ bh n
+ put_ bh def
+ put_ bh ty
+ get bh = do
+ n <- get bh
+ def <- get bh
+ ty <- get bh
+ return (IfaceClassOp n def ty)
+
+instance Binary IfaceRule where
+ 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
+ a3 <- get bh
+ a4 <- get bh
+ a5 <- get bh
+ a6 <- get bh
+ a7 <- get bh
+ return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+
+
View Lorry Controller Status