compiler/iface/BinIface.hs

   1
   2 {-# OPTIONS_GHC -O #-}
   3 -- We always optimise this, otherwise performance of a non-optimised
   4 -- compiler is severely affected
   5
   6 --
   7 --  (c) The University of Glasgow 2002-2006
   8 --
   9 -- Binary interface file support.
  10
  11 module BinIface ( writeBinIface, readBinIface,
  12                   CheckHiWay(..), TraceBinIFaceReading(..) ) where
  13
  14 #include "HsVersions.h"
  15
  16 import TcRnMonad
  17 import IfaceEnv
  18 import HscTypes
  19 import BasicTypes
  20 import NewDemand
  21 import Annotations
  22 import IfaceSyn
  23 import Module
  24 import Name
  25 import OccName
  26 import VarEnv
  27 import InstEnv
  28 import Class
  29 import DynFlags
  30 import UniqFM
  31 import UniqSupply
  32 import CostCentre
  33 import StaticFlags
  34 import Panic
  35 import Binary
  36 import SrcLoc
  37 import ErrUtils
  38 import Config
  39 import FastMutInt
  40 import Unique
  41 import Outputable
  42 import FastString
  43
  44 import Data.List
  45 import Data.Word
  46 import Data.Array
  47 import Data.IORef
  48 import Control.Monad
  49
  50 data CheckHiWay = CheckHiWay | IgnoreHiWay
  51     deriving Eq
  52
  53 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
  54     deriving Eq
  55
  56 -- ---------------------------------------------------------------------------
  57 -- Reading and writing binary interface files
  58
  59 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
  60              -> TcRnIf a b ModIface
  61 readBinIface checkHiWay traceBinIFaceReading hi_path = do
  62   nc <- getNameCache
  63   (new_nc, iface) <- liftIO $
  64     readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
  65   setNameCache new_nc
  66   return iface
  67
  68 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
  69               -> IO (NameCache, ModIface)
  70 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
  71   let printer :: SDoc -> IO ()
  72       printer = case traceBinIFaceReading of
  73                 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
  74                 QuietBinIFaceReading -> \_ -> return ()
  75       wantedGot :: Outputable a => String -> a -> a -> IO ()
  76       wantedGot what wanted got
  77           = printer (text what <> text ": " <>
  78                      vcat [text "Wanted " <> ppr wanted <> text ",",
  79                            text "got    " <> ppr got])
  80
  81       errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
  82       errorOnMismatch what wanted got
  83             -- This will be caught by readIface which will emit an error
  84             -- msg containing the iface module name.
  85           = when (wanted /= got) $ ghcError $ ProgramError
  86                         (what ++ " (wanted " ++ show wanted
  87                               ++ ", got "    ++ show got ++ ")")
  88   bh <- Binary.readBinMem hi_path
  89
  90         -- Read the magic number to check that this really is a GHC .hi file
  91         -- (This magic number does not change when we change
  92         --  GHC interface file format)
  93   magic <- get bh
  94   wantedGot "Magic" binaryInterfaceMagic magic
  95   errorOnMismatch "magic number mismatch: old/corrupt interface file?"
  96       binaryInterfaceMagic magic
  97
  98         -- Get the dictionary pointer.  We won't attempt to actually
  99         -- read the dictionary until we've done the version checks below,
 100         -- just in case this isn't a valid interface.  In retrospect the
 101         -- version should have come before the dictionary pointer, but this
 102         -- is the way it was done originally, and we can't change it now.
 103   dict_p <- Binary.get bh       -- Get the dictionary ptr
 104
 105         -- Check the interface file version and ways.
 106   check_ver  <- get bh
 107   let our_ver = show opt_HiVersion
 108   wantedGot "Version" our_ver check_ver
 109   errorOnMismatch "mismatched interface file versions" our_ver check_ver
 110
 111   check_way <- get bh
 112   way_descr <- getWayDescr
 113   wantedGot "Way" way_descr check_way
 114   when (checkHiWay == CheckHiWay) $
 115        errorOnMismatch "mismatched interface file ways" way_descr check_way
 116
 117         -- Read the dictionary
 118         -- The next word in the file is a pointer to where the dictionary is
 119         -- (probably at the end of the file)
 120   data_p <- tellBin bh          -- Remember where we are now
 121   seekBin bh dict_p
 122   dict <- getDictionary bh
 123   seekBin bh data_p             -- Back to where we were before
 124
 125         -- Initialise the user-data field of bh
 126   ud <- newReadState dict
 127   bh <- return (setUserData bh ud)
 128
 129   symtab_p <- Binary.get bh     -- Get the symtab ptr
 130   data_p <- tellBin bh          -- Remember where we are now
 131   seekBin bh symtab_p
 132   (nc', symtab) <- getSymbolTable bh nc
 133   seekBin bh data_p             -- Back to where we were before
 134   let ud = getUserData bh
 135   bh <- return $! setUserData bh ud{ud_symtab = symtab}
 136   iface <- get bh
 137   return (nc', iface)
 138
 139
 140 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
 141 writeBinIface dflags hi_path mod_iface = do
 142   bh <- openBinMem initBinMemSize
 143   put_ bh binaryInterfaceMagic
 144
 145         -- Remember where the dictionary pointer will go
 146   dict_p_p <- tellBin bh
 147   put_ bh dict_p_p      -- Placeholder for ptr to dictionary
 148
 149         -- The version and way descriptor go next
 150   put_ bh (show opt_HiVersion)
 151   way_descr <- getWayDescr
 152   put_  bh way_descr
 153
 154         -- Remember where the symbol table pointer will go
 155   symtab_p_p <- tellBin bh
 156   put_ bh symtab_p_p
 157
 158         -- Make some intial state
 159   symtab_next <- newFastMutInt
 160   writeFastMutInt symtab_next 0
 161   symtab_map <- newIORef emptyUFM
 162   let bin_symtab = BinSymbolTable {
 163                       bin_symtab_next = symtab_next,
 164                       bin_symtab_map  = symtab_map }
 165   dict_next_ref <- newFastMutInt
 166   writeFastMutInt dict_next_ref 0
 167   dict_map_ref <- newIORef emptyUFM
 168   let bin_dict = BinDictionary {
 169                       bin_dict_next = dict_next_ref,
 170                       bin_dict_map  = dict_map_ref }
 171   ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
 172
 173         -- Put the main thing,
 174   bh <- return $ setUserData bh ud
 175   put_ bh mod_iface
 176
 177         -- Write the symtab pointer at the fornt of the file
 178   symtab_p <- tellBin bh                -- This is where the symtab will start
 179   putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
 180   seekBin bh symtab_p           -- Seek back to the end of the file
 181
 182         -- Write the symbol table itself
 183   symtab_next <- readFastMutInt symtab_next
 184   symtab_map  <- readIORef symtab_map
 185   putSymbolTable bh symtab_next symtab_map
 186   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
 187                                 <+> text "Names")
 188
 189         -- NB. write the dictionary after the symbol table, because
 190         -- writing the symbol table may create more dictionary entries.
 191
 192         -- Write the dictionary pointer at the fornt of the file
 193   dict_p <- tellBin bh          -- This is where the dictionary will start
 194   putAt bh dict_p_p dict_p      -- Fill in the placeholder
 195   seekBin bh dict_p             -- Seek back to the end of the file
 196
 197         -- Write the dictionary itself
 198   dict_next <- readFastMutInt dict_next_ref
 199   dict_map  <- readIORef dict_map_ref
 200   putDictionary bh dict_next dict_map
 201   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
 202                                  <+> text "dict entries")
 203
 204         -- And send the result to the file
 205   writeBinMem bh hi_path
 206
 207 initBinMemSize :: Int
 208 initBinMemSize = 1024 * 1024
 209
 210 -- The *host* architecture version:
 211 #include "MachDeps.h"
 212
 213 binaryInterfaceMagic :: Word32
 214 #if   WORD_SIZE_IN_BITS == 32
 215 binaryInterfaceMagic = 0x1face
 216 #elif WORD_SIZE_IN_BITS == 64
 217 binaryInterfaceMagic = 0x1face64
 218 #endif
 219
 220 -- -----------------------------------------------------------------------------
 221 -- The symbol table
 222
 223 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
 224 putSymbolTable bh next_off symtab = do
 225   put_ bh next_off
 226   let names = elems (array (0,next_off-1) (eltsUFM symtab))
 227   mapM_ (\n -> serialiseName bh n symtab) names
 228
 229 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
 230 getSymbolTable bh namecache = do
 231   sz <- get bh
 232   od_names <- sequence (replicate sz (get bh))
 233   let
 234         arr = listArray (0,sz-1) names
 235         (namecache', names) =
 236                 mapAccumR (fromOnDiskName arr) namecache od_names
 237   --
 238   return (namecache', arr)
 239
 240 type OnDiskName = (PackageId, ModuleName, OccName)
 241
 242 fromOnDiskName
 243    :: Array Int Name
 244    -> NameCache
 245    -> OnDiskName
 246    -> (NameCache, Name)
 247 fromOnDiskName _ nc (pid, mod_name, occ) =
 248   let
 249         mod   = mkModule pid mod_name
 250         cache = nsNames nc
 251   in
 252   case lookupOrigNameCache cache  mod occ of
 253      Just name -> (nc, name)
 254      Nothing   ->
 255         let
 256                 us        = nsUniqs nc
 257                 uniq      = uniqFromSupply us
 258                 name      = mkExternalName uniq mod occ noSrcSpan
 259                 new_cache = extendNameCache cache mod occ name
 260         in
 261         case splitUniqSupply us of { (us',_) ->
 262         ( nc{ nsUniqs = us', nsNames = new_cache }, name )
 263         }
 264
 265 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 266 serialiseName bh name _ = do
 267   let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
 268   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 269
 270
 271 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
 272 putName BinSymbolTable{
 273             bin_symtab_map = symtab_map_ref,
 274             bin_symtab_next = symtab_next }    bh name
 275   = do
 276     symtab_map <- readIORef symtab_map_ref
 277     case lookupUFM symtab_map name of
 278       Just (off,_) -> put_ bh off
 279       Nothing -> do
 280          off <- readFastMutInt symtab_next
 281          writeFastMutInt symtab_next (off+1)
 282          writeIORef symtab_map_ref
 283              $! addToUFM symtab_map name (off,name)
 284          put_ bh off
 285
 286
 287 data BinSymbolTable = BinSymbolTable {
 288         bin_symtab_next :: !FastMutInt, -- The next index to use
 289         bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
 290                                 -- indexed by Name
 291   }
 292
 293
 294 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
 295 putFastString BinDictionary { bin_dict_next = j_r,
 296                               bin_dict_map  = out_r}  bh f
 297   = do
 298     out <- readIORef out_r
 299     let uniq = getUnique f
 300     case lookupUFM out uniq of
 301         Just (j, _)  -> put_ bh j
 302         Nothing -> do
 303            j <- readFastMutInt j_r
 304            put_ bh j
 305            writeFastMutInt j_r (j + 1)
 306            writeIORef out_r $! addToUFM out uniq (j, f)
 307
 308
 309 data BinDictionary = BinDictionary {
 310         bin_dict_next :: !FastMutInt, -- The next index to use
 311         bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
 312                                 -- indexed by FastString
 313   }
 314
 315 -- -----------------------------------------------------------------------------
 316 -- All the binary instances
 317
 318 -- BasicTypes
 319 {-! for IPName derive: Binary !-}
 320 {-! for Fixity derive: Binary !-}
 321 {-! for FixityDirection derive: Binary !-}
 322 {-! for Boxity derive: Binary !-}
 323 {-! for StrictnessMark derive: Binary !-}
 324 {-! for Activation derive: Binary !-}
 325
 326 -- NewDemand
 327 {-! for Demand derive: Binary !-}
 328 {-! for Demands derive: Binary !-}
 329 {-! for DmdResult derive: Binary !-}
 330 {-! for StrictSig derive: Binary !-}
 331
 332 -- Class
 333 {-! for DefMeth derive: Binary !-}
 334
 335 -- HsTypes
 336 {-! for HsPred derive: Binary !-}
 337 {-! for HsType derive: Binary !-}
 338 {-! for TupCon derive: Binary !-}
 339 {-! for HsTyVarBndr derive: Binary !-}
 340
 341 -- HsCore
 342 {-! for UfExpr derive: Binary !-}
 343 {-! for UfConAlt derive: Binary !-}
 344 {-! for UfBinding derive: Binary !-}
 345 {-! for UfBinder derive: Binary !-}
 346 {-! for HsIdInfo derive: Binary !-}
 347 {-! for UfNote derive: Binary !-}
 348
 349 -- HsDecls
 350 {-! for ConDetails derive: Binary !-}
 351 {-! for BangType derive: Binary !-}
 352
 353 -- CostCentre
 354 {-! for IsCafCC derive: Binary !-}
 355 {-! for IsDupdCC derive: Binary !-}
 356 {-! for CostCentre derive: Binary !-}
 357
 358
 359
 360 -- ---------------------------------------------------------------------------
 361 -- Reading a binary interface into ParsedIface
 362
 363 instance Binary ModIface where
 364    put_ bh (ModIface {
 365                  mi_module    = mod,
 366                  mi_boot      = is_boot,
 367                  mi_iface_hash= iface_hash,
 368                  mi_mod_hash  = mod_hash,
 369                  mi_orphan    = orphan,
 370                  mi_finsts    = hasFamInsts,
 371                  mi_deps      = deps,
 372                  mi_usages    = usages,
 373                  mi_exports   = exports,
 374                  mi_exp_hash  = exp_hash,
 375                  mi_fixities  = fixities,
 376                  mi_warns     = warns,
 377                  mi_anns      = anns,
 378                  mi_decls     = decls,
 379                  mi_insts     = insts,
 380                  mi_fam_insts = fam_insts,
 381                  mi_rules     = rules,
 382                  mi_orphan_hash = orphan_hash,
 383                  mi_vect_info = vect_info,
 384                  mi_hpc       = hpc_info }) = do
 385         put_ bh mod
 386         put_ bh is_boot
 387         put_ bh iface_hash
 388         put_ bh mod_hash
 389         put_ bh orphan
 390         put_ bh hasFamInsts
 391         lazyPut bh deps
 392         lazyPut bh usages
 393         put_ bh exports
 394         put_ bh exp_hash
 395         put_ bh fixities
 396         lazyPut bh warns
 397         lazyPut bh anns
 398         put_ bh decls
 399         put_ bh insts
 400         put_ bh fam_insts
 401         lazyPut bh rules
 402         put_ bh orphan_hash
 403         put_ bh vect_info
 404         put_ bh hpc_info
 405
 406    get bh = do
 407         mod_name  <- get bh
 408         is_boot   <- get bh
 409         iface_hash <- get bh
 410         mod_hash  <- get bh
 411         orphan    <- get bh
 412         hasFamInsts <- get bh
 413         deps      <- lazyGet bh
 414         usages    <- {-# SCC "bin_usages" #-} lazyGet bh
 415         exports   <- {-# SCC "bin_exports" #-} get bh
 416         exp_hash  <- get bh
 417         fixities  <- {-# SCC "bin_fixities" #-} get bh
 418         warns     <- {-# SCC "bin_warns" #-} lazyGet bh
 419         anns      <- {-# SCC "bin_anns" #-} lazyGet bh
 420         decls     <- {-# SCC "bin_tycldecls" #-} get bh
 421         insts     <- {-# SCC "bin_insts" #-} get bh
 422         fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
 423         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 424         orphan_hash <- get bh
 425         vect_info <- get bh
 426         hpc_info  <- get bh
 427         return (ModIface {
 428                  mi_module    = mod_name,
 429                  mi_boot      = is_boot,
 430                  mi_iface_hash = iface_hash,
 431                  mi_mod_hash  = mod_hash,
 432                  mi_orphan    = orphan,
 433                  mi_finsts    = hasFamInsts,
 434                  mi_deps      = deps,
 435                  mi_usages    = usages,
 436                  mi_exports   = exports,
 437                  mi_exp_hash  = exp_hash,
 438                  mi_anns      = anns,
 439                  mi_fixities  = fixities,
 440                  mi_warns     = warns,
 441                  mi_decls     = decls,
 442                  mi_globals   = Nothing,
 443                  mi_insts     = insts,
 444                  mi_fam_insts = fam_insts,
 445                  mi_rules     = rules,
 446                  mi_orphan_hash = orphan_hash,
 447                  mi_vect_info = vect_info,
 448                  mi_hpc       = hpc_info,
 449                         -- And build the cached values
 450                  mi_warn_fn   = mkIfaceWarnCache warns,
 451                  mi_fix_fn    = mkIfaceFixCache fixities,
 452                  mi_hash_fn   = mkIfaceHashCache decls })
 453
 454 getWayDescr :: IO String
 455 getWayDescr = do
 456   tag <- readIORef v_Build_tag
 457   if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
 458         -- if this is an unregisterised build, make sure our interfaces
 459         -- can't be used by a registerised build.
 460
 461 -------------------------------------------------------------------------
 462 --              Types from: HscTypes
 463 -------------------------------------------------------------------------
 464
 465 instance Binary Dependencies where
 466     put_ bh deps = do put_ bh (dep_mods deps)
 467                       put_ bh (dep_pkgs deps)
 468                       put_ bh (dep_orphs deps)
 469                       put_ bh (dep_finsts deps)
 470
 471     get bh = do ms <- get bh
 472                 ps <- get bh
 473                 os <- get bh
 474                 fis <- get bh
 475                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
 476                                dep_finsts = fis })
 477
 478 instance (Binary name) => Binary (GenAvailInfo name) where
 479     put_ bh (Avail aa) = do
 480             putByte bh 0
 481             put_ bh aa
 482     put_ bh (AvailTC ab ac) = do
 483             putByte bh 1
 484             put_ bh ab
 485             put_ bh ac
 486     get bh = do
 487             h <- getByte bh
 488             case h of
 489               0 -> do aa <- get bh
 490                       return (Avail aa)
 491               _ -> do ab <- get bh
 492                       ac <- get bh
 493                       return (AvailTC ab ac)
 494
 495 instance Binary Usage where
 496     put_ bh usg@UsagePackageModule{} = do
 497         putByte bh 0
 498         put_ bh (usg_mod usg)
 499         put_ bh (usg_mod_hash usg)
 500     put_ bh usg@UsageHomeModule{} = do
 501         putByte bh 1
 502         put_ bh (usg_mod_name usg)
 503         put_ bh (usg_mod_hash usg)
 504         put_ bh (usg_exports  usg)
 505         put_ bh (usg_entities usg)
 506
 507     get bh = do
 508         h <- getByte bh
 509         case h of
 510           0 -> do
 511             nm    <- get bh
 512             mod   <- get bh
 513             return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
 514           _ -> do
 515             nm    <- get bh
 516             mod   <- get bh
 517             exps  <- get bh
 518             ents  <- get bh
 519             return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
 520                             usg_exports = exps, usg_entities = ents }
 521
 522 instance Binary Warnings where
 523     put_ bh NoWarnings     = putByte bh 0
 524     put_ bh (WarnAll t) = do
 525             putByte bh 1
 526             put_ bh t
 527     put_ bh (WarnSome ts) = do
 528             putByte bh 2
 529             put_ bh ts
 530
 531     get bh = do
 532             h <- getByte bh
 533             case h of
 534               0 -> return NoWarnings
 535               1 -> do aa <- get bh
 536                       return (WarnAll aa)
 537               _ -> do aa <- get bh
 538                       return (WarnSome aa)
 539
 540 instance Binary WarningTxt where
 541     put_ bh (WarningTxt w) = do
 542             putByte bh 0
 543             put_ bh w
 544     put_ bh (DeprecatedTxt d) = do
 545             putByte bh 1
 546             put_ bh d
 547
 548     get bh = do
 549             h <- getByte bh
 550             case h of
 551               0 -> do w <- get bh
 552                       return (WarningTxt w)
 553               _ -> do d <- get bh
 554                       return (DeprecatedTxt d)
 555
 556 -------------------------------------------------------------------------
 557 --              Types from: BasicTypes
 558 -------------------------------------------------------------------------
 559
 560 instance Binary Activation where
 561     put_ bh NeverActive = do
 562             putByte bh 0
 563     put_ bh AlwaysActive = do
 564             putByte bh 1
 565     put_ bh (ActiveBefore aa) = do
 566             putByte bh 2
 567             put_ bh aa
 568     put_ bh (ActiveAfter ab) = do
 569             putByte bh 3
 570             put_ bh ab
 571     get bh = do
 572             h <- getByte bh
 573             case h of
 574               0 -> do return NeverActive
 575               1 -> do return AlwaysActive
 576               2 -> do aa <- get bh
 577                       return (ActiveBefore aa)
 578               _ -> do ab <- get bh
 579                       return (ActiveAfter ab)
 580
 581 instance Binary RuleMatchInfo where
 582     put_ bh FunLike = putByte bh 0
 583     put_ bh ConLike = putByte bh 1
 584     get bh = do
 585             h <- getByte bh
 586             if h == 1 then return ConLike
 587                       else return FunLike
 588
 589 instance Binary InlinePragma where
 590     put_ bh (InlinePragma activation match_info) = do
 591             put_ bh activation
 592             put_ bh match_info
 593
 594     get bh = do
 595            act  <- get bh
 596            info <- get bh
 597            return (InlinePragma act info)
 598
 599 instance Binary StrictnessMark where
 600     put_ bh MarkedStrict    = putByte bh 0
 601     put_ bh MarkedUnboxed   = putByte bh 1
 602     put_ bh NotMarkedStrict = putByte bh 2
 603     get bh = do
 604             h <- getByte bh
 605             case h of
 606               0 -> do return MarkedStrict
 607               1 -> do return MarkedUnboxed
 608               _ -> do return NotMarkedStrict
 609
 610 instance Binary Boxity where
 611     put_ bh Boxed   = putByte bh 0
 612     put_ bh Unboxed = putByte bh 1
 613     get bh = do
 614             h <- getByte bh
 615             case h of
 616               0 -> do return Boxed
 617               _ -> do return Unboxed
 618
 619 instance Binary TupCon where
 620     put_ bh (TupCon ab ac) = do
 621             put_ bh ab
 622             put_ bh ac
 623     get bh = do
 624           ab <- get bh
 625           ac <- get bh
 626           return (TupCon ab ac)
 627
 628 instance Binary RecFlag where
 629     put_ bh Recursive = do
 630             putByte bh 0
 631     put_ bh NonRecursive = do
 632             putByte bh 1
 633     get bh = do
 634             h <- getByte bh
 635             case h of
 636               0 -> do return Recursive
 637               _ -> do return NonRecursive
 638
 639 instance Binary DefMeth where
 640     put_ bh NoDefMeth  = putByte bh 0
 641     put_ bh DefMeth    = putByte bh 1
 642     put_ bh GenDefMeth = putByte bh 2
 643     get bh = do
 644             h <- getByte bh
 645             case h of
 646               0 -> return NoDefMeth
 647               1 -> return DefMeth
 648               _ -> return GenDefMeth
 649
 650 instance Binary FixityDirection where
 651     put_ bh InfixL = do
 652             putByte bh 0
 653     put_ bh InfixR = do
 654             putByte bh 1
 655     put_ bh InfixN = do
 656             putByte bh 2
 657     get bh = do
 658             h <- getByte bh
 659             case h of
 660               0 -> do return InfixL
 661               1 -> do return InfixR
 662               _ -> do return InfixN
 663
 664 instance Binary Fixity where
 665     put_ bh (Fixity aa ab) = do
 666             put_ bh aa
 667             put_ bh ab
 668     get bh = do
 669           aa <- get bh
 670           ab <- get bh
 671           return (Fixity aa ab)
 672
 673 instance (Binary name) => Binary (IPName name) where
 674     put_ bh (IPName aa) = put_ bh aa
 675     get bh = do aa <- get bh
 676                 return (IPName aa)
 677
 678 -------------------------------------------------------------------------
 679 --              Types from: Demand
 680 -------------------------------------------------------------------------
 681
 682 instance Binary DmdType where
 683         -- Ignore DmdEnv when spitting out the DmdType
 684   put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
 685   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 686
 687 instance Binary Demand where
 688     put_ bh Top = do
 689             putByte bh 0
 690     put_ bh Abs = do
 691             putByte bh 1
 692     put_ bh (Call aa) = do
 693             putByte bh 2
 694             put_ bh aa
 695     put_ bh (Eval ab) = do
 696             putByte bh 3
 697             put_ bh ab
 698     put_ bh (Defer ac) = do
 699             putByte bh 4
 700             put_ bh ac
 701     put_ bh (Box ad) = do
 702             putByte bh 5
 703             put_ bh ad
 704     put_ bh Bot = do
 705             putByte bh 6
 706     get bh = do
 707             h <- getByte bh
 708             case h of
 709               0 -> do return Top
 710               1 -> do return Abs
 711               2 -> do aa <- get bh
 712                       return (Call aa)
 713               3 -> do ab <- get bh
 714                       return (Eval ab)
 715               4 -> do ac <- get bh
 716                       return (Defer ac)
 717               5 -> do ad <- get bh
 718                       return (Box ad)
 719               _ -> do return Bot
 720
 721 instance Binary Demands where
 722     put_ bh (Poly aa) = do
 723             putByte bh 0
 724             put_ bh aa
 725     put_ bh (Prod ab) = do
 726             putByte bh 1
 727             put_ bh ab
 728     get bh = do
 729             h <- getByte bh
 730             case h of
 731               0 -> do aa <- get bh
 732                       return (Poly aa)
 733               _ -> do ab <- get bh
 734                       return (Prod ab)
 735
 736 instance Binary DmdResult where
 737     put_ bh TopRes = do
 738             putByte bh 0
 739     put_ bh RetCPR = do
 740             putByte bh 1
 741     put_ bh BotRes = do
 742             putByte bh 2
 743     get bh = do
 744             h <- getByte bh
 745             case h of
 746               0 -> do return TopRes
 747               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 748                                         -- The wrapper was generated for CPR in
 749                                         -- the imported module!
 750               _ -> do return BotRes
 751
 752 instance Binary StrictSig where
 753     put_ bh (StrictSig aa) = do
 754             put_ bh aa
 755     get bh = do
 756           aa <- get bh
 757           return (StrictSig aa)
 758
 759
 760 -------------------------------------------------------------------------
 761 --              Types from: CostCentre
 762 -------------------------------------------------------------------------
 763
 764 instance Binary IsCafCC where
 765     put_ bh CafCC = do
 766             putByte bh 0
 767     put_ bh NotCafCC = do
 768             putByte bh 1
 769     get bh = do
 770             h <- getByte bh
 771             case h of
 772               0 -> do return CafCC
 773               _ -> do return NotCafCC
 774
 775 instance Binary IsDupdCC where
 776     put_ bh OriginalCC = do
 777             putByte bh 0
 778     put_ bh DupdCC = do
 779             putByte bh 1
 780     get bh = do
 781             h <- getByte bh
 782             case h of
 783               0 -> do return OriginalCC
 784               _ -> do return DupdCC
 785
 786 instance Binary CostCentre where
 787     put_ bh NoCostCentre = do
 788             putByte bh 0
 789     put_ bh (NormalCC aa ab ac ad) = do
 790             putByte bh 1
 791             put_ bh aa
 792             put_ bh ab
 793             put_ bh ac
 794             put_ bh ad
 795     put_ bh (AllCafsCC ae) = do
 796             putByte bh 2
 797             put_ bh ae
 798     get bh = do
 799             h <- getByte bh
 800             case h of
 801               0 -> do return NoCostCentre
 802               1 -> do aa <- get bh
 803                       ab <- get bh
 804                       ac <- get bh
 805                       ad <- get bh
 806                       return (NormalCC aa ab ac ad)
 807               _ -> do ae <- get bh
 808                       return (AllCafsCC ae)
 809
 810 -------------------------------------------------------------------------
 811 --              IfaceTypes and friends
 812 -------------------------------------------------------------------------
 813
 814 instance Binary IfaceBndr where
 815     put_ bh (IfaceIdBndr aa) = do
 816             putByte bh 0
 817             put_ bh aa
 818     put_ bh (IfaceTvBndr ab) = do
 819             putByte bh 1
 820             put_ bh ab
 821     get bh = do
 822             h <- getByte bh
 823             case h of
 824               0 -> do aa <- get bh
 825                       return (IfaceIdBndr aa)
 826               _ -> do ab <- get bh
 827                       return (IfaceTvBndr ab)
 828
 829 instance Binary IfaceLetBndr where
 830     put_ bh (IfLetBndr a b c) = do
 831             put_ bh a
 832             put_ bh b
 833             put_ bh c
 834     get bh = do a <- get bh
 835                 b <- get bh
 836                 c <- get bh
 837                 return (IfLetBndr a b c)
 838
 839 instance Binary IfaceType where
 840     put_ bh (IfaceForAllTy aa ab) = do
 841             putByte bh 0
 842             put_ bh aa
 843             put_ bh ab
 844     put_ bh (IfaceTyVar ad) = do
 845             putByte bh 1
 846             put_ bh ad
 847     put_ bh (IfaceAppTy ae af) = do
 848             putByte bh 2
 849             put_ bh ae
 850             put_ bh af
 851     put_ bh (IfaceFunTy ag ah) = do
 852             putByte bh 3
 853             put_ bh ag
 854             put_ bh ah
 855     put_ bh (IfacePredTy aq) = do
 856             putByte bh 5
 857             put_ bh aq
 858
 859         -- Simple compression for common cases of TyConApp
 860     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 861     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 862     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 863     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 864         -- Unit tuple and pairs
 865     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 866     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 867         -- Kind cases
 868     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 869     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 870     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 871     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 872     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 873
 874         -- Generic cases
 875
 876     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 877     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 878
 879     get bh = do
 880             h <- getByte bh
 881             case h of
 882               0 -> do aa <- get bh
 883                       ab <- get bh
 884                       return (IfaceForAllTy aa ab)
 885               1 -> do ad <- get bh
 886                       return (IfaceTyVar ad)
 887               2 -> do ae <- get bh
 888                       af <- get bh
 889                       return (IfaceAppTy ae af)
 890               3 -> do ag <- get bh
 891                       ah <- get bh
 892                       return (IfaceFunTy ag ah)
 893               5 -> do ap <- get bh
 894                       return (IfacePredTy ap)
 895
 896                 -- Now the special cases for TyConApp
 897               6 -> return (IfaceTyConApp IfaceIntTc [])
 898               7 -> return (IfaceTyConApp IfaceCharTc [])
 899               8 -> return (IfaceTyConApp IfaceBoolTc [])
 900               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 901               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 902               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 903               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 904               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 905               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 906               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 907               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 908
 909               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 910               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 911
 912 instance Binary IfaceTyCon where
 913         -- Int,Char,Bool can't show up here because they can't not be saturated
 914
 915    put_ bh IfaceIntTc         = putByte bh 1
 916    put_ bh IfaceBoolTc        = putByte bh 2
 917    put_ bh IfaceCharTc        = putByte bh 3
 918    put_ bh IfaceListTc        = putByte bh 4
 919    put_ bh IfacePArrTc        = putByte bh 5
 920    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 921    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 922    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 923    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 924    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 925    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 926    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 927
 928    get bh = do
 929         h <- getByte bh
 930         case h of
 931           1 -> return IfaceIntTc
 932           2 -> return IfaceBoolTc
 933           3 -> return IfaceCharTc
 934           4 -> return IfaceListTc
 935           5 -> return IfacePArrTc
 936           6 -> return IfaceLiftedTypeKindTc
 937           7 -> return IfaceOpenTypeKindTc
 938           8 -> return IfaceUnliftedTypeKindTc
 939           9 -> return IfaceUbxTupleKindTc
 940           10 -> return IfaceArgTypeKindTc
 941           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 942           _ -> do { ext <- get bh; return (IfaceTc ext) }
 943
 944 instance Binary IfacePredType where
 945     put_ bh (IfaceClassP aa ab) = do
 946             putByte bh 0
 947             put_ bh aa
 948             put_ bh ab
 949     put_ bh (IfaceIParam ac ad) = do
 950             putByte bh 1
 951             put_ bh ac
 952             put_ bh ad
 953     put_ bh (IfaceEqPred ac ad) = do
 954             putByte bh 2
 955             put_ bh ac
 956             put_ bh ad
 957     get bh = do
 958             h <- getByte bh
 959             case h of
 960               0 -> do aa <- get bh
 961                       ab <- get bh
 962                       return (IfaceClassP aa ab)
 963               1 -> do ac <- get bh
 964                       ad <- get bh
 965                       return (IfaceIParam ac ad)
 966               2 -> do ac <- get bh
 967                       ad <- get bh
 968                       return (IfaceEqPred ac ad)
 969               _ -> panic ("get IfacePredType " ++ show h)
 970
 971 -------------------------------------------------------------------------
 972 --              IfaceExpr and friends
 973 -------------------------------------------------------------------------
 974
 975 instance Binary IfaceExpr where
 976     put_ bh (IfaceLcl aa) = do
 977             putByte bh 0
 978             put_ bh aa
 979     put_ bh (IfaceType ab) = do
 980             putByte bh 1
 981             put_ bh ab
 982     put_ bh (IfaceTuple ac ad) = do
 983             putByte bh 2
 984             put_ bh ac
 985             put_ bh ad
 986     put_ bh (IfaceLam ae af) = do
 987             putByte bh 3
 988             put_ bh ae
 989             put_ bh af
 990     put_ bh (IfaceApp ag ah) = do
 991             putByte bh 4
 992             put_ bh ag
 993             put_ bh ah
 994 -- gaw 2004
 995     put_ bh (IfaceCase ai aj al ak) = do
 996             putByte bh 5
 997             put_ bh ai
 998             put_ bh aj
 999 -- gaw 2004
1000             put_ bh al
1001             put_ bh ak
1002     put_ bh (IfaceLet al am) = do
1003             putByte bh 6
1004             put_ bh al
1005             put_ bh am
1006     put_ bh (IfaceNote an ao) = do
1007             putByte bh 7
1008             put_ bh an
1009             put_ bh ao
1010     put_ bh (IfaceLit ap) = do
1011             putByte bh 8
1012             put_ bh ap
1013     put_ bh (IfaceFCall as at) = do
1014             putByte bh 9
1015             put_ bh as
1016             put_ bh at
1017     put_ bh (IfaceExt aa) = do
1018             putByte bh 10
1019             put_ bh aa
1020     put_ bh (IfaceCast ie ico) = do
1021             putByte bh 11
1022             put_ bh ie
1023             put_ bh ico
1024     put_ bh (IfaceTick m ix) = do
1025             putByte bh 12
1026             put_ bh m
1027             put_ bh ix
1028     get bh = do
1029             h <- getByte bh
1030             case h of
1031               0 -> do aa <- get bh
1032                       return (IfaceLcl aa)
1033               1 -> do ab <- get bh
1034                       return (IfaceType ab)
1035               2 -> do ac <- get bh
1036                       ad <- get bh
1037                       return (IfaceTuple ac ad)
1038               3 -> do ae <- get bh
1039                       af <- get bh
1040                       return (IfaceLam ae af)
1041               4 -> do ag <- get bh
1042                       ah <- get bh
1043                       return (IfaceApp ag ah)
1044               5 -> do ai <- get bh
1045                       aj <- get bh
1046 -- gaw 2004
1047                       al <- get bh
1048                       ak <- get bh
1049 -- gaw 2004
1050                       return (IfaceCase ai aj al ak)
1051               6 -> do al <- get bh
1052                       am <- get bh
1053                       return (IfaceLet al am)
1054               7 -> do an <- get bh
1055                       ao <- get bh
1056                       return (IfaceNote an ao)
1057               8 -> do ap <- get bh
1058                       return (IfaceLit ap)
1059               9 -> do as <- get bh
1060                       at <- get bh
1061                       return (IfaceFCall as at)
1062               10 -> do aa <- get bh
1063                        return (IfaceExt aa)
1064               11 -> do ie <- get bh
1065                        ico <- get bh
1066                        return (IfaceCast ie ico)
1067               12 -> do m <- get bh
1068                        ix <- get bh
1069                        return (IfaceTick m ix)
1070               _ -> panic ("get IfaceExpr " ++ show h)
1071
1072 instance Binary IfaceConAlt where
1073     put_ bh IfaceDefault = do
1074             putByte bh 0
1075     put_ bh (IfaceDataAlt aa) = do
1076             putByte bh 1
1077             put_ bh aa
1078     put_ bh (IfaceTupleAlt ab) = do
1079             putByte bh 2
1080             put_ bh ab
1081     put_ bh (IfaceLitAlt ac) = do
1082             putByte bh 3
1083             put_ bh ac
1084     get bh = do
1085             h <- getByte bh
1086             case h of
1087               0 -> do return IfaceDefault
1088               1 -> do aa <- get bh
1089                       return (IfaceDataAlt aa)
1090               2 -> do ab <- get bh
1091                       return (IfaceTupleAlt ab)
1092               _ -> do ac <- get bh
1093                       return (IfaceLitAlt ac)
1094
1095 instance Binary IfaceBinding where
1096     put_ bh (IfaceNonRec aa ab) = do
1097             putByte bh 0
1098             put_ bh aa
1099             put_ bh ab
1100     put_ bh (IfaceRec ac) = do
1101             putByte bh 1
1102             put_ bh ac
1103     get bh = do
1104             h <- getByte bh
1105             case h of
1106               0 -> do aa <- get bh
1107                       ab <- get bh
1108                       return (IfaceNonRec aa ab)
1109               _ -> do ac <- get bh
1110                       return (IfaceRec ac)
1111
1112 instance Binary IfaceIdDetails where
1113     put_ bh IfVanillaId      = putByte bh 0
1114     put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1115     put_ bh IfDFunId         = putByte bh 2
1116     get bh = do
1117             h <- getByte bh
1118             case h of
1119               0 -> return IfVanillaId
1120               1 -> do a <- get bh
1121                       b <- get bh
1122                       return (IfRecSelId a b)
1123               _ -> return IfDFunId
1124
1125 instance Binary IfaceIdInfo where
1126     put_ bh NoInfo = putByte bh 0
1127     put_ bh (HasInfo i) = do
1128             putByte bh 1
1129             lazyPut bh i                        -- NB lazyPut
1130
1131     get bh = do
1132             h <- getByte bh
1133             case h of
1134               0 -> return NoInfo
1135               _ -> do info <- lazyGet bh        -- NB lazyGet
1136                       return (HasInfo info)
1137
1138 instance Binary IfaceInfoItem where
1139     put_ bh (HsArity aa) = do
1140             putByte bh 0
1141             put_ bh aa
1142     put_ bh (HsStrictness ab) = do
1143             putByte bh 1
1144             put_ bh ab
1145     put_ bh (HsUnfold ad) = do
1146             putByte bh 2
1147             put_ bh ad
1148     put_ bh (HsInline ad) = do
1149             putByte bh 3
1150             put_ bh ad
1151     put_ bh HsNoCafRefs = do
1152             putByte bh 4
1153     put_ bh (HsWorker ae af) = do
1154             putByte bh 5
1155             put_ bh ae
1156             put_ bh af
1157     get bh = do
1158             h <- getByte bh
1159             case h of
1160               0 -> do aa <- get bh
1161                       return (HsArity aa)
1162               1 -> do ab <- get bh
1163                       return (HsStrictness ab)
1164               2 -> do ad <- get bh
1165                       return (HsUnfold ad)
1166               3 -> do ad <- get bh
1167                       return (HsInline ad)
1168               4 -> do return HsNoCafRefs
1169               _ -> do ae <- get bh
1170                       af <- get bh
1171                       return (HsWorker ae af)
1172
1173 instance Binary IfaceNote where
1174     put_ bh (IfaceSCC aa) = do
1175             putByte bh 0
1176             put_ bh aa
1177     put_ bh IfaceInlineMe = do
1178             putByte bh 3
1179     put_ bh (IfaceCoreNote s) = do
1180             putByte bh 4
1181             put_ bh s
1182     get bh = do
1183             h <- getByte bh
1184             case h of
1185               0 -> do aa <- get bh
1186                       return (IfaceSCC aa)
1187               3 -> do return IfaceInlineMe
1188               4 -> do ac <- get bh
1189                       return (IfaceCoreNote ac)
1190               _ -> panic ("get IfaceNote " ++ show h)
1191
1192 -------------------------------------------------------------------------
1193 --              IfaceDecl and friends
1194 -------------------------------------------------------------------------
1195
1196 -- A bit of magic going on here: there's no need to store the OccName
1197 -- for a decl on the disk, since we can infer the namespace from the
1198 -- context; however it is useful to have the OccName in the IfaceDecl
1199 -- to avoid re-building it in various places.  So we build the OccName
1200 -- when de-serialising.
1201
1202 instance Binary IfaceDecl where
1203     put_ bh (IfaceId name ty details idinfo) = do
1204             putByte bh 0
1205             put_ bh (occNameFS name)
1206             put_ bh ty
1207             put_ bh details
1208             put_ bh idinfo
1209     put_ _ (IfaceForeign _ _) =
1210         error "Binary.put_(IfaceDecl): IfaceForeign"
1211     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1212             putByte bh 2
1213             put_ bh (occNameFS a1)
1214             put_ bh a2
1215             put_ bh a3
1216             put_ bh a4
1217             put_ bh a5
1218             put_ bh a6
1219             put_ bh a7
1220             put_ bh a8
1221     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1222             putByte bh 3
1223             put_ bh (occNameFS a1)
1224             put_ bh a2
1225             put_ bh a3
1226             put_ bh a4
1227             put_ bh a5
1228     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1229             putByte bh 4
1230             put_ bh a1
1231             put_ bh (occNameFS a2)
1232             put_ bh a3
1233             put_ bh a4
1234             put_ bh a5
1235             put_ bh a6
1236             put_ bh a7
1237     get bh = do
1238             h <- getByte bh
1239             case h of
1240               0 -> do name    <- get bh
1241                       ty      <- get bh
1242                       details <- get bh
1243                       idinfo  <- get bh
1244                       occ <- return $! mkOccNameFS varName name
1245                       return (IfaceId occ ty details idinfo)
1246               1 -> error "Binary.get(TyClDecl): ForeignType"
1247               2 -> do
1248                     a1 <- get bh
1249                     a2 <- get bh
1250                     a3 <- get bh
1251                     a4 <- get bh
1252                     a5 <- get bh
1253                     a6 <- get bh
1254                     a7 <- get bh
1255                     a8 <- get bh
1256                     occ <- return $! mkOccNameFS tcName a1
1257                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1258               3 -> do
1259                     a1 <- get bh
1260                     a2 <- get bh
1261                     a3 <- get bh
1262                     a4 <- get bh
1263                     a5 <- get bh
1264                     occ <- return $! mkOccNameFS tcName a1
1265                     return (IfaceSyn occ a2 a3 a4 a5)
1266               _ -> do
1267                     a1 <- get bh
1268                     a2 <- get bh
1269                     a3 <- get bh
1270                     a4 <- get bh
1271                     a5 <- get bh
1272                     a6 <- get bh
1273                     a7 <- get bh
1274                     occ <- return $! mkOccNameFS clsName a2
1275                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1276
1277 instance Binary IfaceInst where
1278     put_ bh (IfaceInst cls tys dfun flag orph) = do
1279             put_ bh cls
1280             put_ bh tys
1281             put_ bh dfun
1282             put_ bh flag
1283             put_ bh orph
1284     get bh = do cls  <- get bh
1285                 tys  <- get bh
1286                 dfun <- get bh
1287                 flag <- get bh
1288                 orph <- get bh
1289                 return (IfaceInst cls tys dfun flag orph)
1290
1291 instance Binary IfaceFamInst where
1292     put_ bh (IfaceFamInst fam tys tycon) = do
1293             put_ bh fam
1294             put_ bh tys
1295             put_ bh tycon
1296     get bh = do fam   <- get bh
1297                 tys   <- get bh
1298                 tycon <- get bh
1299                 return (IfaceFamInst fam tys tycon)
1300
1301 instance Binary OverlapFlag where
1302     put_ bh NoOverlap  = putByte bh 0
1303     put_ bh OverlapOk  = putByte bh 1
1304     put_ bh Incoherent = putByte bh 2
1305     get bh = do h <- getByte bh
1306                 case h of
1307                   0 -> return NoOverlap
1308                   1 -> return OverlapOk
1309                   2 -> return Incoherent
1310                   _ -> panic ("get OverlapFlag " ++ show h)
1311
1312 instance Binary IfaceConDecls where
1313     put_ bh IfAbstractTyCon = putByte bh 0
1314     put_ bh IfOpenDataTyCon = putByte bh 1
1315     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1316                                   ; put_ bh cs }
1317     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1318                                   ; put_ bh c }
1319     get bh = do
1320             h <- getByte bh
1321             case h of
1322               0 -> return IfAbstractTyCon
1323               1 -> return IfOpenDataTyCon
1324               2 -> do cs <- get bh
1325                       return (IfDataTyCon cs)
1326               _ -> do aa <- get bh
1327                       return (IfNewTyCon aa)
1328
1329 instance Binary IfaceConDecl where
1330     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1331             put_ bh a1
1332             put_ bh a2
1333             put_ bh a3
1334             put_ bh a4
1335             put_ bh a5
1336             put_ bh a6
1337             put_ bh a7
1338             put_ bh a8
1339             put_ bh a9
1340             put_ bh a10
1341     get bh = do a1 <- get bh
1342                 a2 <- get bh
1343                 a3 <- get bh
1344                 a4 <- get bh
1345                 a5 <- get bh
1346                 a6 <- get bh
1347                 a7 <- get bh
1348                 a8 <- get bh
1349                 a9 <- get bh
1350                 a10 <- get bh
1351                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1352
1353 instance Binary IfaceClassOp where
1354    put_ bh (IfaceClassOp n def ty) = do
1355         put_ bh (occNameFS n)
1356         put_ bh def
1357         put_ bh ty
1358    get bh = do
1359         n <- get bh
1360         def <- get bh
1361         ty <- get bh
1362         occ <- return $! mkOccNameFS varName n
1363         return (IfaceClassOp occ def ty)
1364
1365 instance Binary IfaceRule where
1366     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1367             put_ bh a1
1368             put_ bh a2
1369             put_ bh a3
1370             put_ bh a4
1371             put_ bh a5
1372             put_ bh a6
1373             put_ bh a7
1374     get bh = do
1375             a1 <- get bh
1376             a2 <- get bh
1377             a3 <- get bh
1378             a4 <- get bh
1379             a5 <- get bh
1380             a6 <- get bh
1381             a7 <- get bh
1382             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1383
1384 instance Binary IfaceAnnotation where
1385     put_ bh (IfaceAnnotation a1 a2) = do
1386         put_ bh a1
1387         put_ bh a2
1388     get bh = do
1389         a1 <- get bh
1390         a2 <- get bh
1391         return (IfaceAnnotation a1 a2)
1392
1393 instance Binary name => Binary (AnnTarget name) where
1394     put_ bh (NamedTarget a) = do
1395         putByte bh 0
1396         put_ bh a
1397     put_ bh (ModuleTarget a) = do
1398         putByte bh 1
1399         put_ bh a
1400     get bh = do
1401         h <- getByte bh
1402         case h of
1403           0 -> do a <- get bh
1404                   return (NamedTarget a)
1405           _ -> do a <- get bh
1406                   return (ModuleTarget a)
1407
1408 instance Binary IfaceVectInfo where
1409     put_ bh (IfaceVectInfo a1 a2 a3) = do
1410             put_ bh a1
1411             put_ bh a2
1412             put_ bh a3
1413     get bh = do
1414             a1 <- get bh
1415             a2 <- get bh
1416             a3 <- get bh
1417             return (IfaceVectInfo a1 a2 a3)
1418
1419