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