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
 887         -- Generic cases
 888
 889     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 890     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 891
 892     get bh = do
 893             h <- getByte bh
 894             case h of
 895               0 -> do aa <- get bh
 896                       ab <- get bh
 897                       return (IfaceForAllTy aa ab)
 898               1 -> do ad <- get bh
 899                       return (IfaceTyVar ad)
 900               2 -> do ae <- get bh
 901                       af <- get bh
 902                       return (IfaceAppTy ae af)
 903               3 -> do ag <- get bh
 904                       ah <- get bh
 905                       return (IfaceFunTy ag ah)
 906               5 -> do ap <- get bh
 907                       return (IfacePredTy ap)
 908
 909                 -- Now the special cases for TyConApp
 910               6 -> return (IfaceTyConApp IfaceIntTc [])
 911               7 -> return (IfaceTyConApp IfaceCharTc [])
 912               8 -> return (IfaceTyConApp IfaceBoolTc [])
 913               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 914               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 915               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 916               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 917               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 918               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 919               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 920               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 921
 922               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 923               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 924
 925 instance Binary IfaceTyCon where
 926         -- Int,Char,Bool can't show up here because they can't not be saturated
 927
 928    put_ bh IfaceIntTc         = putByte bh 1
 929    put_ bh IfaceBoolTc        = putByte bh 2
 930    put_ bh IfaceCharTc        = putByte bh 3
 931    put_ bh IfaceListTc        = putByte bh 4
 932    put_ bh IfacePArrTc        = putByte bh 5
 933    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 934    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 935    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 936    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 937    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 938    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 939    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 940
 941    get bh = do
 942         h <- getByte bh
 943         case h of
 944           1 -> return IfaceIntTc
 945           2 -> return IfaceBoolTc
 946           3 -> return IfaceCharTc
 947           4 -> return IfaceListTc
 948           5 -> return IfacePArrTc
 949           6 -> return IfaceLiftedTypeKindTc
 950           7 -> return IfaceOpenTypeKindTc
 951           8 -> return IfaceUnliftedTypeKindTc
 952           9 -> return IfaceUbxTupleKindTc
 953           10 -> return IfaceArgTypeKindTc
 954           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 955           _ -> do { ext <- get bh; return (IfaceTc ext) }
 956
 957 instance Binary IfacePredType where
 958     put_ bh (IfaceClassP aa ab) = do
 959             putByte bh 0
 960             put_ bh aa
 961             put_ bh ab
 962     put_ bh (IfaceIParam ac ad) = do
 963             putByte bh 1
 964             put_ bh ac
 965             put_ bh ad
 966     put_ bh (IfaceEqPred ac ad) = do
 967             putByte bh 2
 968             put_ bh ac
 969             put_ bh ad
 970     get bh = do
 971             h <- getByte bh
 972             case h of
 973               0 -> do aa <- get bh
 974                       ab <- get bh
 975                       return (IfaceClassP aa ab)
 976               1 -> do ac <- get bh
 977                       ad <- get bh
 978                       return (IfaceIParam ac ad)
 979               2 -> do ac <- get bh
 980                       ad <- get bh
 981                       return (IfaceEqPred ac ad)
 982               _ -> panic ("get IfacePredType " ++ show h)
 983
 984 -------------------------------------------------------------------------
 985 --              IfaceExpr and friends
 986 -------------------------------------------------------------------------
 987
 988 instance Binary IfaceExpr where
 989     put_ bh (IfaceLcl aa) = do
 990             putByte bh 0
 991             put_ bh aa
 992     put_ bh (IfaceType ab) = do
 993             putByte bh 1
 994             put_ bh ab
 995     put_ bh (IfaceTuple ac ad) = do
 996             putByte bh 2
 997             put_ bh ac
 998             put_ bh ad
 999     put_ bh (IfaceLam ae af) = do
1000             putByte bh 3
1001             put_ bh ae
1002             put_ bh af
1003     put_ bh (IfaceApp ag ah) = do
1004             putByte bh 4
1005             put_ bh ag
1006             put_ bh ah
1007 -- gaw 2004
1008     put_ bh (IfaceCase ai aj al ak) = do
1009             putByte bh 5
1010             put_ bh ai
1011             put_ bh aj
1012 -- gaw 2004
1013             put_ bh al
1014             put_ bh ak
1015     put_ bh (IfaceLet al am) = do
1016             putByte bh 6
1017             put_ bh al
1018             put_ bh am
1019     put_ bh (IfaceNote an ao) = do
1020             putByte bh 7
1021             put_ bh an
1022             put_ bh ao
1023     put_ bh (IfaceLit ap) = do
1024             putByte bh 8
1025             put_ bh ap
1026     put_ bh (IfaceFCall as at) = do
1027             putByte bh 9
1028             put_ bh as
1029             put_ bh at
1030     put_ bh (IfaceExt aa) = do
1031             putByte bh 10
1032             put_ bh aa
1033     put_ bh (IfaceCast ie ico) = do
1034             putByte bh 11
1035             put_ bh ie
1036             put_ bh ico
1037     put_ bh (IfaceTick m ix) = do
1038             putByte bh 12
1039             put_ bh m
1040             put_ bh ix
1041     get bh = do
1042             h <- getByte bh
1043             case h of
1044               0 -> do aa <- get bh
1045                       return (IfaceLcl aa)
1046               1 -> do ab <- get bh
1047                       return (IfaceType ab)
1048               2 -> do ac <- get bh
1049                       ad <- get bh
1050                       return (IfaceTuple ac ad)
1051               3 -> do ae <- get bh
1052                       af <- get bh
1053                       return (IfaceLam ae af)
1054               4 -> do ag <- get bh
1055                       ah <- get bh
1056                       return (IfaceApp ag ah)
1057               5 -> do ai <- get bh
1058                       aj <- get bh
1059 -- gaw 2004
1060                       al <- get bh
1061                       ak <- get bh
1062 -- gaw 2004
1063                       return (IfaceCase ai aj al ak)
1064               6 -> do al <- get bh
1065                       am <- get bh
1066                       return (IfaceLet al am)
1067               7 -> do an <- get bh
1068                       ao <- get bh
1069                       return (IfaceNote an ao)
1070               8 -> do ap <- get bh
1071                       return (IfaceLit ap)
1072               9 -> do as <- get bh
1073                       at <- get bh
1074                       return (IfaceFCall as at)
1075               10 -> do aa <- get bh
1076                        return (IfaceExt aa)
1077               11 -> do ie <- get bh
1078                        ico <- get bh
1079                        return (IfaceCast ie ico)
1080               12 -> do m <- get bh
1081                        ix <- get bh
1082                        return (IfaceTick m ix)
1083               _ -> panic ("get IfaceExpr " ++ show h)
1084
1085 instance Binary IfaceConAlt where
1086     put_ bh IfaceDefault = do
1087             putByte bh 0
1088     put_ bh (IfaceDataAlt aa) = do
1089             putByte bh 1
1090             put_ bh aa
1091     put_ bh (IfaceTupleAlt ab) = do
1092             putByte bh 2
1093             put_ bh ab
1094     put_ bh (IfaceLitAlt ac) = do
1095             putByte bh 3
1096             put_ bh ac
1097     get bh = do
1098             h <- getByte bh
1099             case h of
1100               0 -> do return IfaceDefault
1101               1 -> do aa <- get bh
1102                       return (IfaceDataAlt aa)
1103               2 -> do ab <- get bh
1104                       return (IfaceTupleAlt ab)
1105               _ -> do ac <- get bh
1106                       return (IfaceLitAlt ac)
1107
1108 instance Binary IfaceBinding where
1109     put_ bh (IfaceNonRec aa ab) = do
1110             putByte bh 0
1111             put_ bh aa
1112             put_ bh ab
1113     put_ bh (IfaceRec ac) = do
1114             putByte bh 1
1115             put_ bh ac
1116     get bh = do
1117             h <- getByte bh
1118             case h of
1119               0 -> do aa <- get bh
1120                       ab <- get bh
1121                       return (IfaceNonRec aa ab)
1122               _ -> do ac <- get bh
1123                       return (IfaceRec ac)
1124
1125 instance Binary IfaceIdDetails where
1126     put_ bh IfVanillaId      = putByte bh 0
1127     put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1128     put_ bh IfDFunId         = putByte bh 2
1129     get bh = do
1130             h <- getByte bh
1131             case h of
1132               0 -> return IfVanillaId
1133               1 -> do a <- get bh
1134                       b <- get bh
1135                       return (IfRecSelId a b)
1136               _ -> return IfDFunId
1137
1138 instance Binary IfaceIdInfo where
1139     put_ bh NoInfo = putByte bh 0
1140     put_ bh (HasInfo i) = do
1141             putByte bh 1
1142             lazyPut bh i                        -- NB lazyPut
1143
1144     get bh = do
1145             h <- getByte bh
1146             case h of
1147               0 -> return NoInfo
1148               _ -> do info <- lazyGet bh        -- NB lazyGet
1149                       return (HasInfo info)
1150
1151 instance Binary IfaceInfoItem where
1152     put_ bh (HsArity aa) = do
1153             putByte bh 0
1154             put_ bh aa
1155     put_ bh (HsStrictness ab) = do
1156             putByte bh 1
1157             put_ bh ab
1158     put_ bh (HsUnfold ad) = do
1159             putByte bh 2
1160             put_ bh ad
1161     put_ bh (HsInline ad) = do
1162             putByte bh 3
1163             put_ bh ad
1164     put_ bh HsNoCafRefs = do
1165             putByte bh 4
1166     put_ bh (HsWorker ae af) = do
1167             putByte bh 5
1168             put_ bh ae
1169             put_ bh af
1170     get bh = do
1171             h <- getByte bh
1172             case h of
1173               0 -> do aa <- get bh
1174                       return (HsArity aa)
1175               1 -> do ab <- get bh
1176                       return (HsStrictness ab)
1177               2 -> do ad <- get bh
1178                       return (HsUnfold ad)
1179               3 -> do ad <- get bh
1180                       return (HsInline ad)
1181               4 -> do return HsNoCafRefs
1182               _ -> do ae <- get bh
1183                       af <- get bh
1184                       return (HsWorker ae af)
1185
1186 instance Binary IfaceNote where
1187     put_ bh (IfaceSCC aa) = do
1188             putByte bh 0
1189             put_ bh aa
1190     put_ bh IfaceInlineMe = do
1191             putByte bh 3
1192     put_ bh (IfaceCoreNote s) = do
1193             putByte bh 4
1194             put_ bh s
1195     get bh = do
1196             h <- getByte bh
1197             case h of
1198               0 -> do aa <- get bh
1199                       return (IfaceSCC aa)
1200               3 -> do return IfaceInlineMe
1201               4 -> do ac <- get bh
1202                       return (IfaceCoreNote ac)
1203               _ -> panic ("get IfaceNote " ++ show h)
1204
1205 -------------------------------------------------------------------------
1206 --              IfaceDecl and friends
1207 -------------------------------------------------------------------------
1208
1209 -- A bit of magic going on here: there's no need to store the OccName
1210 -- for a decl on the disk, since we can infer the namespace from the
1211 -- context; however it is useful to have the OccName in the IfaceDecl
1212 -- to avoid re-building it in various places.  So we build the OccName
1213 -- when de-serialising.
1214
1215 instance Binary IfaceDecl where
1216     put_ bh (IfaceId name ty details idinfo) = do
1217             putByte bh 0
1218             put_ bh (occNameFS name)
1219             put_ bh ty
1220             put_ bh details
1221             put_ bh idinfo
1222     put_ _ (IfaceForeign _ _) =
1223         error "Binary.put_(IfaceDecl): IfaceForeign"
1224     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1225             putByte bh 2
1226             put_ bh (occNameFS a1)
1227             put_ bh a2
1228             put_ bh a3
1229             put_ bh a4
1230             put_ bh a5
1231             put_ bh a6
1232             put_ bh a7
1233             put_ bh a8
1234     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1235             putByte bh 3
1236             put_ bh (occNameFS a1)
1237             put_ bh a2
1238             put_ bh a3
1239             put_ bh a4
1240             put_ bh a5
1241     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1242             putByte bh 4
1243             put_ bh a1
1244             put_ bh (occNameFS a2)
1245             put_ bh a3
1246             put_ bh a4
1247             put_ bh a5
1248             put_ bh a6
1249             put_ bh a7
1250     get bh = do
1251             h <- getByte bh
1252             case h of
1253               0 -> do name    <- get bh
1254                       ty      <- get bh
1255                       details <- get bh
1256                       idinfo  <- get bh
1257                       occ <- return $! mkOccNameFS varName name
1258                       return (IfaceId occ ty details idinfo)
1259               1 -> error "Binary.get(TyClDecl): ForeignType"
1260               2 -> do
1261                     a1 <- get bh
1262                     a2 <- get bh
1263                     a3 <- get bh
1264                     a4 <- get bh
1265                     a5 <- get bh
1266                     a6 <- get bh
1267                     a7 <- get bh
1268                     a8 <- get bh
1269                     occ <- return $! mkOccNameFS tcName a1
1270                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1271               3 -> do
1272                     a1 <- get bh
1273                     a2 <- get bh
1274                     a3 <- get bh
1275                     a4 <- get bh
1276                     a5 <- get bh
1277                     occ <- return $! mkOccNameFS tcName a1
1278                     return (IfaceSyn occ a2 a3 a4 a5)
1279               _ -> do
1280                     a1 <- get bh
1281                     a2 <- get bh
1282                     a3 <- get bh
1283                     a4 <- get bh
1284                     a5 <- get bh
1285                     a6 <- get bh
1286                     a7 <- get bh
1287                     occ <- return $! mkOccNameFS clsName a2
1288                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1289
1290 instance Binary IfaceInst where
1291     put_ bh (IfaceInst cls tys dfun flag orph) = do
1292             put_ bh cls
1293             put_ bh tys
1294             put_ bh dfun
1295             put_ bh flag
1296             put_ bh orph
1297     get bh = do cls  <- get bh
1298                 tys  <- get bh
1299                 dfun <- get bh
1300                 flag <- get bh
1301                 orph <- get bh
1302                 return (IfaceInst cls tys dfun flag orph)
1303
1304 instance Binary IfaceFamInst where
1305     put_ bh (IfaceFamInst fam tys tycon) = do
1306             put_ bh fam
1307             put_ bh tys
1308             put_ bh tycon
1309     get bh = do fam   <- get bh
1310                 tys   <- get bh
1311                 tycon <- get bh
1312                 return (IfaceFamInst fam tys tycon)
1313
1314 instance Binary OverlapFlag where
1315     put_ bh NoOverlap  = putByte bh 0
1316     put_ bh OverlapOk  = putByte bh 1
1317     put_ bh Incoherent = putByte bh 2
1318     get bh = do h <- getByte bh
1319                 case h of
1320                   0 -> return NoOverlap
1321                   1 -> return OverlapOk
1322                   2 -> return Incoherent
1323                   _ -> panic ("get OverlapFlag " ++ show h)
1324
1325 instance Binary IfaceConDecls where
1326     put_ bh IfAbstractTyCon = putByte bh 0
1327     put_ bh IfOpenDataTyCon = putByte bh 1
1328     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1329                                   ; put_ bh cs }
1330     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1331                                   ; put_ bh c }
1332     get bh = do
1333             h <- getByte bh
1334             case h of
1335               0 -> return IfAbstractTyCon
1336               1 -> return IfOpenDataTyCon
1337               2 -> do cs <- get bh
1338                       return (IfDataTyCon cs)
1339               _ -> do aa <- get bh
1340                       return (IfNewTyCon aa)
1341
1342 instance Binary IfaceConDecl where
1343     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1344             put_ bh a1
1345             put_ bh a2
1346             put_ bh a3
1347             put_ bh a4
1348             put_ bh a5
1349             put_ bh a6
1350             put_ bh a7
1351             put_ bh a8
1352             put_ bh a9
1353             put_ bh a10
1354     get bh = do a1 <- get bh
1355                 a2 <- get bh
1356                 a3 <- get bh
1357                 a4 <- get bh
1358                 a5 <- get bh
1359                 a6 <- get bh
1360                 a7 <- get bh
1361                 a8 <- get bh
1362                 a9 <- get bh
1363                 a10 <- get bh
1364                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1365
1366 instance Binary IfaceClassOp where
1367    put_ bh (IfaceClassOp n def ty) = do
1368         put_ bh (occNameFS n)
1369         put_ bh def
1370         put_ bh ty
1371    get bh = do
1372         n <- get bh
1373         def <- get bh
1374         ty <- get bh
1375         occ <- return $! mkOccNameFS varName n
1376         return (IfaceClassOp occ def ty)
1377
1378 instance Binary IfaceRule where
1379     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1380             put_ bh a1
1381             put_ bh a2
1382             put_ bh a3
1383             put_ bh a4
1384             put_ bh a5
1385             put_ bh a6
1386             put_ bh a7
1387     get bh = do
1388             a1 <- get bh
1389             a2 <- get bh
1390             a3 <- get bh
1391             a4 <- get bh
1392             a5 <- get bh
1393             a6 <- get bh
1394             a7 <- get bh
1395             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1396
1397 instance Binary IfaceAnnotation where
1398     put_ bh (IfaceAnnotation a1 a2) = do
1399         put_ bh a1
1400         put_ bh a2
1401     get bh = do
1402         a1 <- get bh
1403         a2 <- get bh
1404         return (IfaceAnnotation a1 a2)
1405
1406 instance Binary name => Binary (AnnTarget name) where
1407     put_ bh (NamedTarget a) = do
1408         putByte bh 0
1409         put_ bh a
1410     put_ bh (ModuleTarget a) = do
1411         putByte bh 1
1412         put_ bh a
1413     get bh = do
1414         h <- getByte bh
1415         case h of
1416           0 -> do a <- get bh
1417                   return (NamedTarget a)
1418           _ -> do a <- get bh
1419                   return (ModuleTarget a)
1420
1421 instance Binary IfaceVectInfo where
1422     put_ bh (IfaceVectInfo a1 a2 a3) = do
1423             put_ bh a1
1424             put_ bh a2
1425             put_ bh a3
1426     get bh = do
1427             a1 <- get bh
1428             a2 <- get bh
1429             a3 <- get bh
1430             return (IfaceVectInfo a1 a2 a3)
1431
1432