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 activation match_info) = do
 604             put_ bh activation
 605             put_ bh match_info
 606
 607     get bh = do
 608            act  <- get bh
 609            info <- get bh
 610            return (InlinePragma act info)
 611
 612 instance Binary StrictnessMark where
 613     put_ bh MarkedStrict    = putByte bh 0
 614     put_ bh MarkedUnboxed   = putByte bh 1
 615     put_ bh NotMarkedStrict = putByte bh 2
 616     get bh = do
 617             h <- getByte bh
 618             case h of
 619               0 -> do return MarkedStrict
 620               1 -> do return MarkedUnboxed
 621               _ -> do return NotMarkedStrict
 622
 623 instance Binary Boxity where
 624     put_ bh Boxed   = putByte bh 0
 625     put_ bh Unboxed = putByte bh 1
 626     get bh = do
 627             h <- getByte bh
 628             case h of
 629               0 -> do return Boxed
 630               _ -> do return Unboxed
 631
 632 instance Binary TupCon where
 633     put_ bh (TupCon ab ac) = do
 634             put_ bh ab
 635             put_ bh ac
 636     get bh = do
 637           ab <- get bh
 638           ac <- get bh
 639           return (TupCon ab ac)
 640
 641 instance Binary RecFlag where
 642     put_ bh Recursive = do
 643             putByte bh 0
 644     put_ bh NonRecursive = do
 645             putByte bh 1
 646     get bh = do
 647             h <- getByte bh
 648             case h of
 649               0 -> do return Recursive
 650               _ -> do return NonRecursive
 651
 652 instance Binary DefMeth where
 653     put_ bh NoDefMeth  = putByte bh 0
 654     put_ bh DefMeth    = putByte bh 1
 655     put_ bh GenDefMeth = putByte bh 2
 656     get bh = do
 657             h <- getByte bh
 658             case h of
 659               0 -> return NoDefMeth
 660               1 -> return DefMeth
 661               _ -> return GenDefMeth
 662
 663 instance Binary FixityDirection where
 664     put_ bh InfixL = do
 665             putByte bh 0
 666     put_ bh InfixR = do
 667             putByte bh 1
 668     put_ bh InfixN = do
 669             putByte bh 2
 670     get bh = do
 671             h <- getByte bh
 672             case h of
 673               0 -> do return InfixL
 674               1 -> do return InfixR
 675               _ -> do return InfixN
 676
 677 instance Binary Fixity where
 678     put_ bh (Fixity aa ab) = do
 679             put_ bh aa
 680             put_ bh ab
 681     get bh = do
 682           aa <- get bh
 683           ab <- get bh
 684           return (Fixity aa ab)
 685
 686 instance (Binary name) => Binary (IPName name) where
 687     put_ bh (IPName aa) = put_ bh aa
 688     get bh = do aa <- get bh
 689                 return (IPName aa)
 690
 691 -------------------------------------------------------------------------
 692 --              Types from: Demand
 693 -------------------------------------------------------------------------
 694
 695 instance Binary DmdType where
 696         -- Ignore DmdEnv when spitting out the DmdType
 697   put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
 698   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 699
 700 instance Binary Demand where
 701     put_ bh Top = do
 702             putByte bh 0
 703     put_ bh Abs = do
 704             putByte bh 1
 705     put_ bh (Call aa) = do
 706             putByte bh 2
 707             put_ bh aa
 708     put_ bh (Eval ab) = do
 709             putByte bh 3
 710             put_ bh ab
 711     put_ bh (Defer ac) = do
 712             putByte bh 4
 713             put_ bh ac
 714     put_ bh (Box ad) = do
 715             putByte bh 5
 716             put_ bh ad
 717     put_ bh Bot = do
 718             putByte bh 6
 719     get bh = do
 720             h <- getByte bh
 721             case h of
 722               0 -> do return Top
 723               1 -> do return Abs
 724               2 -> do aa <- get bh
 725                       return (Call aa)
 726               3 -> do ab <- get bh
 727                       return (Eval ab)
 728               4 -> do ac <- get bh
 729                       return (Defer ac)
 730               5 -> do ad <- get bh
 731                       return (Box ad)
 732               _ -> do return Bot
 733
 734 instance Binary Demands where
 735     put_ bh (Poly aa) = do
 736             putByte bh 0
 737             put_ bh aa
 738     put_ bh (Prod ab) = do
 739             putByte bh 1
 740             put_ bh ab
 741     get bh = do
 742             h <- getByte bh
 743             case h of
 744               0 -> do aa <- get bh
 745                       return (Poly aa)
 746               _ -> do ab <- get bh
 747                       return (Prod ab)
 748
 749 instance Binary DmdResult where
 750     put_ bh TopRes = do
 751             putByte bh 0
 752     put_ bh RetCPR = do
 753             putByte bh 1
 754     put_ bh BotRes = do
 755             putByte bh 2
 756     get bh = do
 757             h <- getByte bh
 758             case h of
 759               0 -> do return TopRes
 760               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 761                                         -- The wrapper was generated for CPR in
 762                                         -- the imported module!
 763               _ -> do return BotRes
 764
 765 instance Binary StrictSig where
 766     put_ bh (StrictSig aa) = do
 767             put_ bh aa
 768     get bh = do
 769           aa <- get bh
 770           return (StrictSig aa)
 771
 772
 773 -------------------------------------------------------------------------
 774 --              Types from: CostCentre
 775 -------------------------------------------------------------------------
 776
 777 instance Binary IsCafCC where
 778     put_ bh CafCC = do
 779             putByte bh 0
 780     put_ bh NotCafCC = do
 781             putByte bh 1
 782     get bh = do
 783             h <- getByte bh
 784             case h of
 785               0 -> do return CafCC
 786               _ -> do return NotCafCC
 787
 788 instance Binary IsDupdCC where
 789     put_ bh OriginalCC = do
 790             putByte bh 0
 791     put_ bh DupdCC = do
 792             putByte bh 1
 793     get bh = do
 794             h <- getByte bh
 795             case h of
 796               0 -> do return OriginalCC
 797               _ -> do return DupdCC
 798
 799 instance Binary CostCentre where
 800     put_ bh NoCostCentre = do
 801             putByte bh 0
 802     put_ bh (NormalCC aa ab ac ad) = do
 803             putByte bh 1
 804             put_ bh aa
 805             put_ bh ab
 806             put_ bh ac
 807             put_ bh ad
 808     put_ bh (AllCafsCC ae) = do
 809             putByte bh 2
 810             put_ bh ae
 811     get bh = do
 812             h <- getByte bh
 813             case h of
 814               0 -> do return NoCostCentre
 815               1 -> do aa <- get bh
 816                       ab <- get bh
 817                       ac <- get bh
 818                       ad <- get bh
 819                       return (NormalCC aa ab ac ad)
 820               _ -> do ae <- get bh
 821                       return (AllCafsCC ae)
 822
 823 -------------------------------------------------------------------------
 824 --              IfaceTypes and friends
 825 -------------------------------------------------------------------------
 826
 827 instance Binary IfaceBndr where
 828     put_ bh (IfaceIdBndr aa) = do
 829             putByte bh 0
 830             put_ bh aa
 831     put_ bh (IfaceTvBndr ab) = do
 832             putByte bh 1
 833             put_ bh ab
 834     get bh = do
 835             h <- getByte bh
 836             case h of
 837               0 -> do aa <- get bh
 838                       return (IfaceIdBndr aa)
 839               _ -> do ab <- get bh
 840                       return (IfaceTvBndr ab)
 841
 842 instance Binary IfaceLetBndr where
 843     put_ bh (IfLetBndr a b c) = do
 844             put_ bh a
 845             put_ bh b
 846             put_ bh c
 847     get bh = do a <- get bh
 848                 b <- get bh
 849                 c <- get bh
 850                 return (IfLetBndr a b c)
 851
 852 instance Binary IfaceType where
 853     put_ bh (IfaceForAllTy aa ab) = do
 854             putByte bh 0
 855             put_ bh aa
 856             put_ bh ab
 857     put_ bh (IfaceTyVar ad) = do
 858             putByte bh 1
 859             put_ bh ad
 860     put_ bh (IfaceAppTy ae af) = do
 861             putByte bh 2
 862             put_ bh ae
 863             put_ bh af
 864     put_ bh (IfaceFunTy ag ah) = do
 865             putByte bh 3
 866             put_ bh ag
 867             put_ bh ah
 868     put_ bh (IfacePredTy aq) = do
 869             putByte bh 5
 870             put_ bh aq
 871
 872         -- Simple compression for common cases of TyConApp
 873     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 874     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 875     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 876     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 877         -- Unit tuple and pairs
 878     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 879     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 880         -- Kind cases
 881     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 882     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 883     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 884     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 885     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 886     put_ bh (IfaceTyConApp (IfaceAnyTc k) [])          = do { putByte bh 17; put_ bh k }
 887
 888         -- Generic cases
 889
 890     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 891     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 892
 893     get bh = do
 894             h <- getByte bh
 895             case h of
 896               0 -> do aa <- get bh
 897                       ab <- get bh
 898                       return (IfaceForAllTy aa ab)
 899               1 -> do ad <- get bh
 900                       return (IfaceTyVar ad)
 901               2 -> do ae <- get bh
 902                       af <- get bh
 903                       return (IfaceAppTy ae af)
 904               3 -> do ag <- get bh
 905                       ah <- get bh
 906                       return (IfaceFunTy ag ah)
 907               5 -> do ap <- get bh
 908                       return (IfacePredTy ap)
 909
 910                 -- Now the special cases for TyConApp
 911               6 -> return (IfaceTyConApp IfaceIntTc [])
 912               7 -> return (IfaceTyConApp IfaceCharTc [])
 913               8 -> return (IfaceTyConApp IfaceBoolTc [])
 914               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 915               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 916               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 917               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 918               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 919               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 920               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 921               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 922               17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
 923
 924               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 925               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 926
 927 instance Binary IfaceTyCon where
 928         -- Int,Char,Bool can't show up here because they can't not be saturated
 929
 930    put_ bh IfaceIntTc         = putByte bh 1
 931    put_ bh IfaceBoolTc        = putByte bh 2
 932    put_ bh IfaceCharTc        = putByte bh 3
 933    put_ bh IfaceListTc        = putByte bh 4
 934    put_ bh IfacePArrTc        = putByte bh 5
 935    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 936    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 937    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 938    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 939    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 940    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 941    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 942    put_ bh (IfaceAnyTc k)     = do { putByte bh 13; put_ bh k }
 943
 944    get bh = do
 945         h <- getByte bh
 946         case h of
 947           1 -> return IfaceIntTc
 948           2 -> return IfaceBoolTc
 949           3 -> return IfaceCharTc
 950           4 -> return IfaceListTc
 951           5 -> return IfacePArrTc
 952           6 -> return IfaceLiftedTypeKindTc
 953           7 -> return IfaceOpenTypeKindTc
 954           8 -> return IfaceUnliftedTypeKindTc
 955           9 -> return IfaceUbxTupleKindTc
 956           10 -> return IfaceArgTypeKindTc
 957           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 958           12 -> do { ext <- get bh; return (IfaceTc ext) }
 959           _  -> do { k <- get bh; return (IfaceAnyTc k) }
 960
 961 instance Binary IfacePredType where
 962     put_ bh (IfaceClassP aa ab) = do
 963             putByte bh 0
 964             put_ bh aa
 965             put_ bh ab
 966     put_ bh (IfaceIParam ac ad) = do
 967             putByte bh 1
 968             put_ bh ac
 969             put_ bh ad
 970     put_ bh (IfaceEqPred ac ad) = do
 971             putByte bh 2
 972             put_ bh ac
 973             put_ bh ad
 974     get bh = do
 975             h <- getByte bh
 976             case h of
 977               0 -> do aa <- get bh
 978                       ab <- get bh
 979                       return (IfaceClassP aa ab)
 980               1 -> do ac <- get bh
 981                       ad <- get bh
 982                       return (IfaceIParam ac ad)
 983               2 -> do ac <- get bh
 984                       ad <- get bh
 985                       return (IfaceEqPred ac ad)
 986               _ -> panic ("get IfacePredType " ++ show h)
 987
 988 -------------------------------------------------------------------------
 989 --              IfaceExpr and friends
 990 -------------------------------------------------------------------------
 991
 992 instance Binary IfaceExpr where
 993     put_ bh (IfaceLcl aa) = do
 994             putByte bh 0
 995             put_ bh aa
 996     put_ bh (IfaceType ab) = do
 997             putByte bh 1
 998             put_ bh ab
 999     put_ bh (IfaceTuple ac ad) = do
1000             putByte bh 2
1001             put_ bh ac
1002             put_ bh ad
1003     put_ bh (IfaceLam ae af) = do
1004             putByte bh 3
1005             put_ bh ae
1006             put_ bh af
1007     put_ bh (IfaceApp ag ah) = do
1008             putByte bh 4
1009             put_ bh ag
1010             put_ bh ah
1011 -- gaw 2004
1012     put_ bh (IfaceCase ai aj al ak) = do
1013             putByte bh 5
1014             put_ bh ai
1015             put_ bh aj
1016 -- gaw 2004
1017             put_ bh al
1018             put_ bh ak
1019     put_ bh (IfaceLet al am) = do
1020             putByte bh 6
1021             put_ bh al
1022             put_ bh am
1023     put_ bh (IfaceNote an ao) = do
1024             putByte bh 7
1025             put_ bh an
1026             put_ bh ao
1027     put_ bh (IfaceLit ap) = do
1028             putByte bh 8
1029             put_ bh ap
1030     put_ bh (IfaceFCall as at) = do
1031             putByte bh 9
1032             put_ bh as
1033             put_ bh at
1034     put_ bh (IfaceExt aa) = do
1035             putByte bh 10
1036             put_ bh aa
1037     put_ bh (IfaceCast ie ico) = do
1038             putByte bh 11
1039             put_ bh ie
1040             put_ bh ico
1041     put_ bh (IfaceTick m ix) = do
1042             putByte bh 12
1043             put_ bh m
1044             put_ bh ix
1045     get bh = do
1046             h <- getByte bh
1047             case h of
1048               0 -> do aa <- get bh
1049                       return (IfaceLcl aa)
1050               1 -> do ab <- get bh
1051                       return (IfaceType ab)
1052               2 -> do ac <- get bh
1053                       ad <- get bh
1054                       return (IfaceTuple ac ad)
1055               3 -> do ae <- get bh
1056                       af <- get bh
1057                       return (IfaceLam ae af)
1058               4 -> do ag <- get bh
1059                       ah <- get bh
1060                       return (IfaceApp ag ah)
1061               5 -> do ai <- get bh
1062                       aj <- get bh
1063 -- gaw 2004
1064                       al <- get bh
1065                       ak <- get bh
1066 -- gaw 2004
1067                       return (IfaceCase ai aj al ak)
1068               6 -> do al <- get bh
1069                       am <- get bh
1070                       return (IfaceLet al am)
1071               7 -> do an <- get bh
1072                       ao <- get bh
1073                       return (IfaceNote an ao)
1074               8 -> do ap <- get bh
1075                       return (IfaceLit ap)
1076               9 -> do as <- get bh
1077                       at <- get bh
1078                       return (IfaceFCall as at)
1079               10 -> do aa <- get bh
1080                        return (IfaceExt aa)
1081               11 -> do ie <- get bh
1082                        ico <- get bh
1083                        return (IfaceCast ie ico)
1084               12 -> do m <- get bh
1085                        ix <- get bh
1086                        return (IfaceTick m ix)
1087               _ -> panic ("get IfaceExpr " ++ show h)
1088
1089 instance Binary IfaceConAlt where
1090     put_ bh IfaceDefault = do
1091             putByte bh 0
1092     put_ bh (IfaceDataAlt aa) = do
1093             putByte bh 1
1094             put_ bh aa
1095     put_ bh (IfaceTupleAlt ab) = do
1096             putByte bh 2
1097             put_ bh ab
1098     put_ bh (IfaceLitAlt ac) = do
1099             putByte bh 3
1100             put_ bh ac
1101     get bh = do
1102             h <- getByte bh
1103             case h of
1104               0 -> do return IfaceDefault
1105               1 -> do aa <- get bh
1106                       return (IfaceDataAlt aa)
1107               2 -> do ab <- get bh
1108                       return (IfaceTupleAlt ab)
1109               _ -> do ac <- get bh
1110                       return (IfaceLitAlt ac)
1111
1112 instance Binary IfaceBinding where
1113     put_ bh (IfaceNonRec aa ab) = do
1114             putByte bh 0
1115             put_ bh aa
1116             put_ bh ab
1117     put_ bh (IfaceRec ac) = do
1118             putByte bh 1
1119             put_ bh ac
1120     get bh = do
1121             h <- getByte bh
1122             case h of
1123               0 -> do aa <- get bh
1124                       ab <- get bh
1125                       return (IfaceNonRec aa ab)
1126               _ -> do ac <- get bh
1127                       return (IfaceRec ac)
1128
1129 instance Binary IfaceIdDetails where
1130     put_ bh IfVanillaId      = putByte bh 0
1131     put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1132     put_ bh IfDFunId         = putByte bh 2
1133     get bh = do
1134             h <- getByte bh
1135             case h of
1136               0 -> return IfVanillaId
1137               1 -> do a <- get bh
1138                       b <- get bh
1139                       return (IfRecSelId a b)
1140               _ -> return IfDFunId
1141
1142 instance Binary IfaceIdInfo where
1143     put_ bh NoInfo = putByte bh 0
1144     put_ bh (HasInfo i) = do
1145             putByte bh 1
1146             lazyPut bh i                        -- NB lazyPut
1147
1148     get bh = do
1149             h <- getByte bh
1150             case h of
1151               0 -> return NoInfo
1152               _ -> do info <- lazyGet bh        -- NB lazyGet
1153                       return (HasInfo info)
1154
1155 instance Binary IfaceInfoItem where
1156     put_ bh (HsArity aa) = do
1157             putByte bh 0
1158             put_ bh aa
1159     put_ bh (HsStrictness ab) = do
1160             putByte bh 1
1161             put_ bh ab
1162     put_ bh (HsUnfold ad) = do
1163             putByte bh 2
1164             put_ bh ad
1165     put_ bh (HsInline ad) = do
1166             putByte bh 3
1167             put_ bh ad
1168     put_ bh HsNoCafRefs = do
1169             putByte bh 4
1170     put_ bh (HsWorker ae af) = do
1171             putByte bh 5
1172             put_ bh ae
1173             put_ bh af
1174     get bh = do
1175             h <- getByte bh
1176             case h of
1177               0 -> do aa <- get bh
1178                       return (HsArity aa)
1179               1 -> do ab <- get bh
1180                       return (HsStrictness ab)
1181               2 -> do ad <- get bh
1182                       return (HsUnfold ad)
1183               3 -> do ad <- get bh
1184                       return (HsInline ad)
1185               4 -> do return HsNoCafRefs
1186               _ -> do ae <- get bh
1187                       af <- get bh
1188                       return (HsWorker ae af)
1189
1190 instance Binary IfaceNote where
1191     put_ bh (IfaceSCC aa) = do
1192             putByte bh 0
1193             put_ bh aa
1194     put_ bh IfaceInlineMe = do
1195             putByte bh 3
1196     put_ bh (IfaceCoreNote s) = do
1197             putByte bh 4
1198             put_ bh s
1199     get bh = do
1200             h <- getByte bh
1201             case h of
1202               0 -> do aa <- get bh
1203                       return (IfaceSCC aa)
1204               3 -> do return IfaceInlineMe
1205               4 -> do ac <- get bh
1206                       return (IfaceCoreNote ac)
1207               _ -> panic ("get IfaceNote " ++ show h)
1208
1209 -------------------------------------------------------------------------
1210 --              IfaceDecl and friends
1211 -------------------------------------------------------------------------
1212
1213 -- A bit of magic going on here: there's no need to store the OccName
1214 -- for a decl on the disk, since we can infer the namespace from the
1215 -- context; however it is useful to have the OccName in the IfaceDecl
1216 -- to avoid re-building it in various places.  So we build the OccName
1217 -- when de-serialising.
1218
1219 instance Binary IfaceDecl where
1220     put_ bh (IfaceId name ty details idinfo) = do
1221             putByte bh 0
1222             put_ bh (occNameFS name)
1223             put_ bh ty
1224             put_ bh details
1225             put_ bh idinfo
1226     put_ _ (IfaceForeign _ _) =
1227         error "Binary.put_(IfaceDecl): IfaceForeign"
1228     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1229             putByte bh 2
1230             put_ bh (occNameFS a1)
1231             put_ bh a2
1232             put_ bh a3
1233             put_ bh a4
1234             put_ bh a5
1235             put_ bh a6
1236             put_ bh a7
1237             put_ bh a8
1238     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1239             putByte bh 3
1240             put_ bh (occNameFS a1)
1241             put_ bh a2
1242             put_ bh a3
1243             put_ bh a4
1244             put_ bh a5
1245     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1246             putByte bh 4
1247             put_ bh a1
1248             put_ bh (occNameFS a2)
1249             put_ bh a3
1250             put_ bh a4
1251             put_ bh a5
1252             put_ bh a6
1253             put_ bh a7
1254     get bh = do
1255             h <- getByte bh
1256             case h of
1257               0 -> do name    <- get bh
1258                       ty      <- get bh
1259                       details <- get bh
1260                       idinfo  <- get bh
1261                       occ <- return $! mkOccNameFS varName name
1262                       return (IfaceId occ ty details idinfo)
1263               1 -> error "Binary.get(TyClDecl): ForeignType"
1264               2 -> do
1265                     a1 <- get bh
1266                     a2 <- get bh
1267                     a3 <- get bh
1268                     a4 <- get bh
1269                     a5 <- get bh
1270                     a6 <- get bh
1271                     a7 <- get bh
1272                     a8 <- get bh
1273                     occ <- return $! mkOccNameFS tcName a1
1274                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1275               3 -> do
1276                     a1 <- get bh
1277                     a2 <- get bh
1278                     a3 <- get bh
1279                     a4 <- get bh
1280                     a5 <- get bh
1281                     occ <- return $! mkOccNameFS tcName a1
1282                     return (IfaceSyn occ a2 a3 a4 a5)
1283               _ -> do
1284                     a1 <- get bh
1285                     a2 <- get bh
1286                     a3 <- get bh
1287                     a4 <- get bh
1288                     a5 <- get bh
1289                     a6 <- get bh
1290                     a7 <- get bh
1291                     occ <- return $! mkOccNameFS clsName a2
1292                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1293
1294 instance Binary IfaceInst where
1295     put_ bh (IfaceInst cls tys dfun flag orph) = do
1296             put_ bh cls
1297             put_ bh tys
1298             put_ bh dfun
1299             put_ bh flag
1300             put_ bh orph
1301     get bh = do cls  <- get bh
1302                 tys  <- get bh
1303                 dfun <- get bh
1304                 flag <- get bh
1305                 orph <- get bh
1306                 return (IfaceInst cls tys dfun flag orph)
1307
1308 instance Binary IfaceFamInst where
1309     put_ bh (IfaceFamInst fam tys tycon) = do
1310             put_ bh fam
1311             put_ bh tys
1312             put_ bh tycon
1313     get bh = do fam   <- get bh
1314                 tys   <- get bh
1315                 tycon <- get bh
1316                 return (IfaceFamInst fam tys tycon)
1317
1318 instance Binary OverlapFlag where
1319     put_ bh NoOverlap  = putByte bh 0
1320     put_ bh OverlapOk  = putByte bh 1
1321     put_ bh Incoherent = putByte bh 2
1322     get bh = do h <- getByte bh
1323                 case h of
1324                   0 -> return NoOverlap
1325                   1 -> return OverlapOk
1326                   2 -> return Incoherent
1327                   _ -> panic ("get OverlapFlag " ++ show h)
1328
1329 instance Binary IfaceConDecls where
1330     put_ bh IfAbstractTyCon = putByte bh 0
1331     put_ bh IfOpenDataTyCon = putByte bh 1
1332     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1333                                   ; put_ bh cs }
1334     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1335                                   ; put_ bh c }
1336     get bh = do
1337             h <- getByte bh
1338             case h of
1339               0 -> return IfAbstractTyCon
1340               1 -> return IfOpenDataTyCon
1341               2 -> do cs <- get bh
1342                       return (IfDataTyCon cs)
1343               _ -> do aa <- get bh
1344                       return (IfNewTyCon aa)
1345
1346 instance Binary IfaceConDecl where
1347     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1348             put_ bh a1
1349             put_ bh a2
1350             put_ bh a3
1351             put_ bh a4
1352             put_ bh a5
1353             put_ bh a6
1354             put_ bh a7
1355             put_ bh a8
1356             put_ bh a9
1357             put_ bh a10
1358     get bh = do a1 <- get bh
1359                 a2 <- get bh
1360                 a3 <- get bh
1361                 a4 <- get bh
1362                 a5 <- get bh
1363                 a6 <- get bh
1364                 a7 <- get bh
1365                 a8 <- get bh
1366                 a9 <- get bh
1367                 a10 <- get bh
1368                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1369
1370 instance Binary IfaceClassOp where
1371    put_ bh (IfaceClassOp n def ty) = do
1372         put_ bh (occNameFS n)
1373         put_ bh def
1374         put_ bh ty
1375    get bh = do
1376         n <- get bh
1377         def <- get bh
1378         ty <- get bh
1379         occ <- return $! mkOccNameFS varName n
1380         return (IfaceClassOp occ def ty)
1381
1382 instance Binary IfaceRule where
1383     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1384             put_ bh a1
1385             put_ bh a2
1386             put_ bh a3
1387             put_ bh a4
1388             put_ bh a5
1389             put_ bh a6
1390             put_ bh a7
1391     get bh = do
1392             a1 <- get bh
1393             a2 <- get bh
1394             a3 <- get bh
1395             a4 <- get bh
1396             a5 <- get bh
1397             a6 <- get bh
1398             a7 <- get bh
1399             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1400
1401 instance Binary IfaceAnnotation where
1402     put_ bh (IfaceAnnotation a1 a2) = do
1403         put_ bh a1
1404         put_ bh a2
1405     get bh = do
1406         a1 <- get bh
1407         a2 <- get bh
1408         return (IfaceAnnotation a1 a2)
1409
1410 instance Binary name => Binary (AnnTarget name) where
1411     put_ bh (NamedTarget a) = do
1412         putByte bh 0
1413         put_ bh a
1414     put_ bh (ModuleTarget a) = do
1415         putByte bh 1
1416         put_ bh a
1417     get bh = do
1418         h <- getByte bh
1419         case h of
1420           0 -> do a <- get bh
1421                   return (NamedTarget a)
1422           _ -> do a <- get bh
1423                   return (ModuleTarget a)
1424
1425 instance Binary IfaceVectInfo where
1426     put_ bh (IfaceVectInfo a1 a2 a3) = do
1427             put_ bh a1
1428             put_ bh a2
1429             put_ bh a3
1430     get bh = do
1431             a1 <- get bh
1432             a2 <- get bh
1433             a3 <- get bh
1434             return (IfaceVectInfo a1 a2 a3)
1435
1436