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