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