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