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