compiler/iface/BinIface.hs

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