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