compiler/iface/BinIface.hs

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