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