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 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         let
 267                 us        = nsUniqs nc
 268                 uniq      = uniqFromSupply us
 269                 name      = mkExternalName uniq mod occ noSrcSpan
 270                 new_cache = extendNameCache cache mod occ name
 271         in
 272         case splitUniqSupply us of { (us',_) ->
 273         ( nc{ nsUniqs = us', nsNames = new_cache }, name )
 274         }
 275
 276 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 277 serialiseName bh name _ = do
 278   let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
 279   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 280
 281
 282 putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
 283 putName BinSymbolTable{
 284             bin_symtab_map = symtab_map_ref,
 285             bin_symtab_next = symtab_next }    bh name
 286   = do
 287     symtab_map <- readIORef symtab_map_ref
 288     case lookupUFM symtab_map name of
 289       Just (off,_) -> put_ bh (fromIntegral off :: Word32)
 290       Nothing -> do
 291          off <- readFastMutInt symtab_next
 292          writeFastMutInt symtab_next (off+1)
 293          writeIORef symtab_map_ref
 294              $! addToUFM symtab_map name (off,name)
 295          put_ bh (fromIntegral off :: Word32)
 296
 297
 298 data BinSymbolTable = BinSymbolTable {
 299         bin_symtab_next :: !FastMutInt, -- The next index to use
 300         bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
 301                                 -- indexed by Name
 302   }
 303
 304
 305 putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
 306 putFastString BinDictionary { bin_dict_next = j_r,
 307                               bin_dict_map  = out_r}  bh f
 308   = do
 309     out <- readIORef out_r
 310     let uniq = getUnique f
 311     case lookupUFM out uniq of
 312         Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
 313         Nothing -> do
 314            j <- readFastMutInt j_r
 315            put_ bh (fromIntegral j :: Word32)
 316            writeFastMutInt j_r (j + 1)
 317            writeIORef out_r $! addToUFM out uniq (j, f)
 318
 319
 320 data BinDictionary = BinDictionary {
 321         bin_dict_next :: !FastMutInt, -- The next index to use
 322         bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
 323                                 -- indexed by FastString
 324   }
 325
 326 -- -----------------------------------------------------------------------------
 327 -- All the binary instances
 328
 329 -- BasicTypes
 330 {-! for IPName derive: Binary !-}
 331 {-! for Fixity derive: Binary !-}
 332 {-! for FixityDirection derive: Binary !-}
 333 {-! for Boxity derive: Binary !-}
 334 {-! for StrictnessMark derive: Binary !-}
 335 {-! for Activation derive: Binary !-}
 336
 337 -- Demand
 338 {-! for Demand derive: Binary !-}
 339 {-! for Demands derive: Binary !-}
 340 {-! for DmdResult derive: Binary !-}
 341 {-! for StrictSig derive: Binary !-}
 342
 343 -- Class
 344 {-! for DefMeth derive: Binary !-}
 345
 346 -- HsTypes
 347 {-! for HsPred derive: Binary !-}
 348 {-! for HsType derive: Binary !-}
 349 {-! for TupCon derive: Binary !-}
 350 {-! for HsTyVarBndr derive: Binary !-}
 351
 352 -- HsCore
 353 {-! for UfExpr derive: Binary !-}
 354 {-! for UfConAlt derive: Binary !-}
 355 {-! for UfBinding derive: Binary !-}
 356 {-! for UfBinder derive: Binary !-}
 357 {-! for HsIdInfo derive: Binary !-}
 358 {-! for UfNote derive: Binary !-}
 359
 360 -- HsDecls
 361 {-! for ConDetails derive: Binary !-}
 362 {-! for BangType derive: Binary !-}
 363
 364 -- CostCentre
 365 {-! for IsCafCC derive: Binary !-}
 366 {-! for IsDupdCC derive: Binary !-}
 367 {-! for CostCentre derive: Binary !-}
 368
 369
 370
 371 -- ---------------------------------------------------------------------------
 372 -- Reading a binary interface into ParsedIface
 373
 374 instance Binary ModIface where
 375    put_ bh (ModIface {
 376                  mi_module    = mod,
 377                  mi_boot      = is_boot,
 378                  mi_iface_hash= iface_hash,
 379                  mi_mod_hash  = mod_hash,
 380                  mi_orphan    = orphan,
 381                  mi_finsts    = hasFamInsts,
 382                  mi_deps      = deps,
 383                  mi_usages    = usages,
 384                  mi_exports   = exports,
 385                  mi_exp_hash  = exp_hash,
 386                  mi_fixities  = fixities,
 387                  mi_warns     = warns,
 388                  mi_anns      = anns,
 389                  mi_decls     = decls,
 390                  mi_insts     = insts,
 391                  mi_fam_insts = fam_insts,
 392                  mi_rules     = rules,
 393                  mi_orphan_hash = orphan_hash,
 394                  mi_vect_info = vect_info,
 395                  mi_hpc       = hpc_info }) = do
 396         put_ bh mod
 397         put_ bh is_boot
 398         put_ bh iface_hash
 399         put_ bh mod_hash
 400         put_ bh orphan
 401         put_ bh hasFamInsts
 402         lazyPut bh deps
 403         lazyPut bh usages
 404         put_ bh exports
 405         put_ bh exp_hash
 406         put_ bh fixities
 407         lazyPut bh warns
 408         lazyPut bh anns
 409         put_ bh decls
 410         put_ bh insts
 411         put_ bh fam_insts
 412         lazyPut bh rules
 413         put_ bh orphan_hash
 414         put_ bh vect_info
 415         put_ bh hpc_info
 416
 417    get bh = do
 418         mod_name  <- get bh
 419         is_boot   <- get bh
 420         iface_hash <- get bh
 421         mod_hash  <- get bh
 422         orphan    <- get bh
 423         hasFamInsts <- get bh
 424         deps      <- lazyGet bh
 425         usages    <- {-# SCC "bin_usages" #-} lazyGet bh
 426         exports   <- {-# SCC "bin_exports" #-} get bh
 427         exp_hash  <- get bh
 428         fixities  <- {-# SCC "bin_fixities" #-} get bh
 429         warns     <- {-# SCC "bin_warns" #-} lazyGet bh
 430         anns      <- {-# SCC "bin_anns" #-} lazyGet bh
 431         decls     <- {-# SCC "bin_tycldecls" #-} get bh
 432         insts     <- {-# SCC "bin_insts" #-} get bh
 433         fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
 434         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 435         orphan_hash <- get bh
 436         vect_info <- get bh
 437         hpc_info  <- get bh
 438         return (ModIface {
 439                  mi_module    = mod_name,
 440                  mi_boot      = is_boot,
 441                  mi_iface_hash = iface_hash,
 442                  mi_mod_hash  = mod_hash,
 443                  mi_orphan    = orphan,
 444                  mi_finsts    = hasFamInsts,
 445                  mi_deps      = deps,
 446                  mi_usages    = usages,
 447                  mi_exports   = exports,
 448                  mi_exp_hash  = exp_hash,
 449                  mi_anns      = anns,
 450                  mi_fixities  = fixities,
 451                  mi_warns     = warns,
 452                  mi_decls     = decls,
 453                  mi_globals   = Nothing,
 454                  mi_insts     = insts,
 455                  mi_fam_insts = fam_insts,
 456                  mi_rules     = rules,
 457                  mi_orphan_hash = orphan_hash,
 458                  mi_vect_info = vect_info,
 459                  mi_hpc       = hpc_info,
 460                         -- And build the cached values
 461                  mi_warn_fn   = mkIfaceWarnCache warns,
 462                  mi_fix_fn    = mkIfaceFixCache fixities,
 463                  mi_hash_fn   = mkIfaceHashCache decls })
 464
 465 getWayDescr :: DynFlags -> String
 466 getWayDescr dflags
 467   | cGhcUnregisterised == "YES" = 'u':tag
 468   | otherwise                   = tag
 469   where tag = buildTag dflags
 470         -- if this is an unregisterised build, make sure our interfaces
 471         -- can't be used by a registerised build.
 472
 473 -------------------------------------------------------------------------
 474 --              Types from: HscTypes
 475 -------------------------------------------------------------------------
 476
 477 instance Binary Dependencies where
 478     put_ bh deps = do put_ bh (dep_mods deps)
 479                       put_ bh (dep_pkgs deps)
 480                       put_ bh (dep_orphs deps)
 481                       put_ bh (dep_finsts deps)
 482
 483     get bh = do ms <- get bh
 484                 ps <- get bh
 485                 os <- get bh
 486                 fis <- get bh
 487                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
 488                                dep_finsts = fis })
 489
 490 instance (Binary name) => Binary (GenAvailInfo name) where
 491     put_ bh (Avail aa) = do
 492             putByte bh 0
 493             put_ bh aa
 494     put_ bh (AvailTC ab ac) = do
 495             putByte bh 1
 496             put_ bh ab
 497             put_ bh ac
 498     get bh = do
 499             h <- getByte bh
 500             case h of
 501               0 -> do aa <- get bh
 502                       return (Avail aa)
 503               _ -> do ab <- get bh
 504                       ac <- get bh
 505                       return (AvailTC ab ac)
 506
 507 instance Binary Usage where
 508     put_ bh usg@UsagePackageModule{} = do
 509         putByte bh 0
 510         put_ bh (usg_mod usg)
 511         put_ bh (usg_mod_hash usg)
 512     put_ bh usg@UsageHomeModule{} = do
 513         putByte bh 1
 514         put_ bh (usg_mod_name usg)
 515         put_ bh (usg_mod_hash usg)
 516         put_ bh (usg_exports  usg)
 517         put_ bh (usg_entities usg)
 518
 519     get bh = do
 520         h <- getByte bh
 521         case h of
 522           0 -> do
 523             nm    <- get bh
 524             mod   <- get bh
 525             return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
 526           _ -> do
 527             nm    <- get bh
 528             mod   <- get bh
 529             exps  <- get bh
 530             ents  <- get bh
 531             return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
 532                             usg_exports = exps, usg_entities = ents }
 533
 534 instance Binary Warnings where
 535     put_ bh NoWarnings     = putByte bh 0
 536     put_ bh (WarnAll t) = do
 537             putByte bh 1
 538             put_ bh t
 539     put_ bh (WarnSome ts) = do
 540             putByte bh 2
 541             put_ bh ts
 542
 543     get bh = do
 544             h <- getByte bh
 545             case h of
 546               0 -> return NoWarnings
 547               1 -> do aa <- get bh
 548                       return (WarnAll aa)
 549               _ -> do aa <- get bh
 550                       return (WarnSome aa)
 551
 552 instance Binary WarningTxt where
 553     put_ bh (WarningTxt w) = do
 554             putByte bh 0
 555             put_ bh w
 556     put_ bh (DeprecatedTxt d) = do
 557             putByte bh 1
 558             put_ bh d
 559
 560     get bh = do
 561             h <- getByte bh
 562             case h of
 563               0 -> do w <- get bh
 564                       return (WarningTxt w)
 565               _ -> do d <- get bh
 566                       return (DeprecatedTxt d)
 567
 568 -------------------------------------------------------------------------
 569 --              Types from: BasicTypes
 570 -------------------------------------------------------------------------
 571
 572 instance Binary Activation where
 573     put_ bh NeverActive = do
 574             putByte bh 0
 575     put_ bh AlwaysActive = do
 576             putByte bh 1
 577     put_ bh (ActiveBefore aa) = do
 578             putByte bh 2
 579             put_ bh aa
 580     put_ bh (ActiveAfter ab) = do
 581             putByte bh 3
 582             put_ bh ab
 583     get bh = do
 584             h <- getByte bh
 585             case h of
 586               0 -> do return NeverActive
 587               1 -> do return AlwaysActive
 588               2 -> do aa <- get bh
 589                       return (ActiveBefore aa)
 590               _ -> do ab <- get bh
 591                       return (ActiveAfter ab)
 592
 593 instance Binary RuleMatchInfo where
 594     put_ bh FunLike = putByte bh 0
 595     put_ bh ConLike = putByte bh 1
 596     get bh = do
 597             h <- getByte bh
 598             if h == 1 then return ConLike
 599                       else return FunLike
 600
 601 instance Binary InlinePragma where
 602     put_ bh (InlinePragma a b c d) = do
 603             put_ bh a
 604             put_ bh b
 605             put_ bh c
 606             put_ bh d
 607
 608     get bh = do
 609            a <- get bh
 610            b <- get bh
 611            c <- get bh
 612            d <- get bh
 613            return (InlinePragma a b c d)
 614
 615 instance Binary HsBang where
 616     put_ bh HsNoBang        = putByte bh 0
 617     put_ bh HsStrict        = putByte bh 1
 618     put_ bh HsUnpack        = putByte bh 2
 619     put_ bh HsUnpackFailed  = putByte bh 3
 620     get bh = do
 621             h <- getByte bh
 622             case h of
 623               0 -> do return HsNoBang
 624               1 -> do return HsStrict
 625               2 -> do return HsUnpack
 626               _ -> do return HsUnpackFailed
 627
 628 instance Binary Boxity where
 629     put_ bh Boxed   = putByte bh 0
 630     put_ bh Unboxed = putByte bh 1
 631     get bh = do
 632             h <- getByte bh
 633             case h of
 634               0 -> do return Boxed
 635               _ -> do return Unboxed
 636
 637 instance Binary TupCon where
 638     put_ bh (TupCon ab ac) = do
 639             put_ bh ab
 640             put_ bh ac
 641     get bh = do
 642           ab <- get bh
 643           ac <- get bh
 644           return (TupCon ab ac)
 645
 646 instance Binary RecFlag where
 647     put_ bh Recursive = do
 648             putByte bh 0
 649     put_ bh NonRecursive = do
 650             putByte bh 1
 651     get bh = do
 652             h <- getByte bh
 653             case h of
 654               0 -> do return Recursive
 655               _ -> do return NonRecursive
 656
 657 instance Binary DefMethSpec where
 658     put_ bh NoDM      = putByte bh 0
 659     put_ bh VanillaDM = putByte bh 1
 660     put_ bh GenericDM = putByte bh 2
 661     get bh = do
 662             h <- getByte bh
 663             case h of
 664               0 -> return NoDM
 665               1 -> return VanillaDM
 666               _ -> return GenericDM
 667
 668 instance Binary FixityDirection where
 669     put_ bh InfixL = do
 670             putByte bh 0
 671     put_ bh InfixR = do
 672             putByte bh 1
 673     put_ bh InfixN = do
 674             putByte bh 2
 675     get bh = do
 676             h <- getByte bh
 677             case h of
 678               0 -> do return InfixL
 679               1 -> do return InfixR
 680               _ -> do return InfixN
 681
 682 instance Binary Fixity where
 683     put_ bh (Fixity aa ab) = do
 684             put_ bh aa
 685             put_ bh ab
 686     get bh = do
 687           aa <- get bh
 688           ab <- get bh
 689           return (Fixity aa ab)
 690
 691 instance (Binary name) => Binary (IPName name) where
 692     put_ bh (IPName aa) = put_ bh aa
 693     get bh = do aa <- get bh
 694                 return (IPName aa)
 695
 696 -------------------------------------------------------------------------
 697 --              Types from: Demand
 698 -------------------------------------------------------------------------
 699
 700 instance Binary DmdType where
 701         -- Ignore DmdEnv when spitting out the DmdType
 702   put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
 703   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 704
 705 instance Binary Demand where
 706     put_ bh Top = do
 707             putByte bh 0
 708     put_ bh Abs = do
 709             putByte bh 1
 710     put_ bh (Call aa) = do
 711             putByte bh 2
 712             put_ bh aa
 713     put_ bh (Eval ab) = do
 714             putByte bh 3
 715             put_ bh ab
 716     put_ bh (Defer ac) = do
 717             putByte bh 4
 718             put_ bh ac
 719     put_ bh (Box ad) = do
 720             putByte bh 5
 721             put_ bh ad
 722     put_ bh Bot = do
 723             putByte bh 6
 724     get bh = do
 725             h <- getByte bh
 726             case h of
 727               0 -> do return Top
 728               1 -> do return Abs
 729               2 -> do aa <- get bh
 730                       return (Call aa)
 731               3 -> do ab <- get bh
 732                       return (Eval ab)
 733               4 -> do ac <- get bh
 734                       return (Defer ac)
 735               5 -> do ad <- get bh
 736                       return (Box ad)
 737               _ -> do return Bot
 738
 739 instance Binary Demands where
 740     put_ bh (Poly aa) = do
 741             putByte bh 0
 742             put_ bh aa
 743     put_ bh (Prod ab) = do
 744             putByte bh 1
 745             put_ bh ab
 746     get bh = do
 747             h <- getByte bh
 748             case h of
 749               0 -> do aa <- get bh
 750                       return (Poly aa)
 751               _ -> do ab <- get bh
 752                       return (Prod ab)
 753
 754 instance Binary DmdResult where
 755     put_ bh TopRes = do
 756             putByte bh 0
 757     put_ bh RetCPR = do
 758             putByte bh 1
 759     put_ bh BotRes = do
 760             putByte bh 2
 761     get bh = do
 762             h <- getByte bh
 763             case h of
 764               0 -> do return TopRes
 765               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 766                                         -- The wrapper was generated for CPR in
 767                                         -- the imported module!
 768               _ -> do return BotRes
 769
 770 instance Binary StrictSig where
 771     put_ bh (StrictSig aa) = do
 772             put_ bh aa
 773     get bh = do
 774           aa <- get bh
 775           return (StrictSig aa)
 776
 777
 778 -------------------------------------------------------------------------
 779 --              Types from: CostCentre
 780 -------------------------------------------------------------------------
 781
 782 instance Binary IsCafCC where
 783     put_ bh CafCC = do
 784             putByte bh 0
 785     put_ bh NotCafCC = do
 786             putByte bh 1
 787     get bh = do
 788             h <- getByte bh
 789             case h of
 790               0 -> do return CafCC
 791               _ -> do return NotCafCC
 792
 793 instance Binary IsDupdCC where
 794     put_ bh OriginalCC = do
 795             putByte bh 0
 796     put_ bh DupdCC = do
 797             putByte bh 1
 798     get bh = do
 799             h <- getByte bh
 800             case h of
 801               0 -> do return OriginalCC
 802               _ -> do return DupdCC
 803
 804 instance Binary CostCentre where
 805     put_ bh NoCostCentre = do
 806             putByte bh 0
 807     put_ bh (NormalCC aa ab ac ad) = do
 808             putByte bh 1
 809             put_ bh aa
 810             put_ bh ab
 811             put_ bh ac
 812             put_ bh ad
 813     put_ bh (AllCafsCC ae) = do
 814             putByte bh 2
 815             put_ bh ae
 816     get bh = do
 817             h <- getByte bh
 818             case h of
 819               0 -> do return NoCostCentre
 820               1 -> do aa <- get bh
 821                       ab <- get bh
 822                       ac <- get bh
 823                       ad <- get bh
 824                       return (NormalCC aa ab ac ad)
 825               _ -> do ae <- get bh
 826                       return (AllCafsCC ae)
 827
 828 -------------------------------------------------------------------------
 829 --              IfaceTypes and friends
 830 -------------------------------------------------------------------------
 831
 832 instance Binary IfaceBndr where
 833     put_ bh (IfaceIdBndr aa) = do
 834             putByte bh 0
 835             put_ bh aa
 836     put_ bh (IfaceTvBndr ab) = do
 837             putByte bh 1
 838             put_ bh ab
 839     get bh = do
 840             h <- getByte bh
 841             case h of
 842               0 -> do aa <- get bh
 843                       return (IfaceIdBndr aa)
 844               _ -> do ab <- get bh
 845                       return (IfaceTvBndr ab)
 846
 847 instance Binary IfaceLetBndr where
 848     put_ bh (IfLetBndr a b c) = do
 849             put_ bh a
 850             put_ bh b
 851             put_ bh c
 852     get bh = do a <- get bh
 853                 b <- get bh
 854                 c <- get bh
 855                 return (IfLetBndr a b c)
 856
 857 instance Binary IfaceType where
 858     put_ bh (IfaceForAllTy aa ab) = do
 859             putByte bh 0
 860             put_ bh aa
 861             put_ bh ab
 862     put_ bh (IfaceTyVar ad) = do
 863             putByte bh 1
 864             put_ bh ad
 865     put_ bh (IfaceAppTy ae af) = do
 866             putByte bh 2
 867             put_ bh ae
 868             put_ bh af
 869     put_ bh (IfaceFunTy ag ah) = do
 870             putByte bh 3
 871             put_ bh ag
 872             put_ bh ah
 873     put_ bh (IfacePredTy aq) = do
 874             putByte bh 5
 875             put_ bh aq
 876
 877         -- Simple compression for common cases of TyConApp
 878     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 879     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 880     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 881     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 882         -- Unit tuple and pairs
 883     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 884     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 885         -- Kind cases
 886     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 887     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 888     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 889     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 890     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 891     put_ bh (IfaceTyConApp (IfaceAnyTc k) [])          = do { putByte bh 17; put_ bh k }
 892
 893         -- Generic cases
 894
 895     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 896     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 897
 898     get bh = do
 899             h <- getByte bh
 900             case h of
 901               0 -> do aa <- get bh
 902                       ab <- get bh
 903                       return (IfaceForAllTy aa ab)
 904               1 -> do ad <- get bh
 905                       return (IfaceTyVar ad)
 906               2 -> do ae <- get bh
 907                       af <- get bh
 908                       return (IfaceAppTy ae af)
 909               3 -> do ag <- get bh
 910                       ah <- get bh
 911                       return (IfaceFunTy ag ah)
 912               5 -> do ap <- get bh
 913                       return (IfacePredTy ap)
 914
 915                 -- Now the special cases for TyConApp
 916               6 -> return (IfaceTyConApp IfaceIntTc [])
 917               7 -> return (IfaceTyConApp IfaceCharTc [])
 918               8 -> return (IfaceTyConApp IfaceBoolTc [])
 919               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 920               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 921               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 922               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 923               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 924               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 925               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 926               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 927               17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
 928
 929               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 930               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 931
 932 instance Binary IfaceTyCon where
 933         -- Int,Char,Bool can't show up here because they can't not be saturated
 934
 935    put_ bh IfaceIntTc         = putByte bh 1
 936    put_ bh IfaceBoolTc        = putByte bh 2
 937    put_ bh IfaceCharTc        = putByte bh 3
 938    put_ bh IfaceListTc        = putByte bh 4
 939    put_ bh IfacePArrTc        = putByte bh 5
 940    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 941    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 942    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 943    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 944    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 945    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 946    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 947    put_ bh (IfaceAnyTc k)     = do { putByte bh 13; put_ bh k }
 948
 949    get bh = do
 950         h <- getByte bh
 951         case h of
 952           1 -> return IfaceIntTc
 953           2 -> return IfaceBoolTc
 954           3 -> return IfaceCharTc
 955           4 -> return IfaceListTc
 956           5 -> return IfacePArrTc
 957           6 -> return IfaceLiftedTypeKindTc
 958           7 -> return IfaceOpenTypeKindTc
 959           8 -> return IfaceUnliftedTypeKindTc
 960           9 -> return IfaceUbxTupleKindTc
 961           10 -> return IfaceArgTypeKindTc
 962           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 963           12 -> do { ext <- get bh; return (IfaceTc ext) }
 964           _  -> do { k <- get bh; return (IfaceAnyTc k) }
 965
 966 instance Binary IfacePredType where
 967     put_ bh (IfaceClassP aa ab) = do
 968             putByte bh 0
 969             put_ bh aa
 970             put_ bh ab
 971     put_ bh (IfaceIParam ac ad) = do
 972             putByte bh 1
 973             put_ bh ac
 974             put_ bh ad
 975     put_ bh (IfaceEqPred ac ad) = do
 976             putByte bh 2
 977             put_ bh ac
 978             put_ bh ad
 979     get bh = do
 980             h <- getByte bh
 981             case h of
 982               0 -> do aa <- get bh
 983                       ab <- get bh
 984                       return (IfaceClassP aa ab)
 985               1 -> do ac <- get bh
 986                       ad <- get bh
 987                       return (IfaceIParam ac ad)
 988               2 -> do ac <- get bh
 989                       ad <- get bh
 990                       return (IfaceEqPred ac ad)
 991               _ -> panic ("get IfacePredType " ++ show h)
 992
 993 -------------------------------------------------------------------------
 994 --              IfaceExpr and friends
 995 -------------------------------------------------------------------------
 996
 997 instance Binary IfaceExpr where
 998     put_ bh (IfaceLcl aa) = do
 999             putByte bh 0
1000             put_ bh aa
1001     put_ bh (IfaceType ab) = do
1002             putByte bh 1
1003             put_ bh ab
1004     put_ bh (IfaceTuple ac ad) = do
1005             putByte bh 2
1006             put_ bh ac
1007             put_ bh ad
1008     put_ bh (IfaceLam ae af) = do
1009             putByte bh 3
1010             put_ bh ae
1011             put_ bh af
1012     put_ bh (IfaceApp ag ah) = do
1013             putByte bh 4
1014             put_ bh ag
1015             put_ bh ah
1016 -- gaw 2004
1017     put_ bh (IfaceCase ai aj al ak) = do
1018             putByte bh 5
1019             put_ bh ai
1020             put_ bh aj
1021 -- gaw 2004
1022             put_ bh al
1023             put_ bh ak
1024     put_ bh (IfaceLet al am) = do
1025             putByte bh 6
1026             put_ bh al
1027             put_ bh am
1028     put_ bh (IfaceNote an ao) = do
1029             putByte bh 7
1030             put_ bh an
1031             put_ bh ao
1032     put_ bh (IfaceLit ap) = do
1033             putByte bh 8
1034             put_ bh ap
1035     put_ bh (IfaceFCall as at) = do
1036             putByte bh 9
1037             put_ bh as
1038             put_ bh at
1039     put_ bh (IfaceExt aa) = do
1040             putByte bh 10
1041             put_ bh aa
1042     put_ bh (IfaceCast ie ico) = do
1043             putByte bh 11
1044             put_ bh ie
1045             put_ bh ico
1046     put_ bh (IfaceTick m ix) = do
1047             putByte bh 12
1048             put_ bh m
1049             put_ bh ix
1050     get bh = do
1051             h <- getByte bh
1052             case h of
1053               0 -> do aa <- get bh
1054                       return (IfaceLcl aa)
1055               1 -> do ab <- get bh
1056                       return (IfaceType ab)
1057               2 -> do ac <- get bh
1058                       ad <- get bh
1059                       return (IfaceTuple ac ad)
1060               3 -> do ae <- get bh
1061                       af <- get bh
1062                       return (IfaceLam ae af)
1063               4 -> do ag <- get bh
1064                       ah <- get bh
1065                       return (IfaceApp ag ah)
1066               5 -> do ai <- get bh
1067                       aj <- get bh
1068 -- gaw 2004
1069                       al <- get bh
1070                       ak <- get bh
1071 -- gaw 2004
1072                       return (IfaceCase ai aj al ak)
1073               6 -> do al <- get bh
1074                       am <- get bh
1075                       return (IfaceLet al am)
1076               7 -> do an <- get bh
1077                       ao <- get bh
1078                       return (IfaceNote an ao)
1079               8 -> do ap <- get bh
1080                       return (IfaceLit ap)
1081               9 -> do as <- get bh
1082                       at <- get bh
1083                       return (IfaceFCall as at)
1084               10 -> do aa <- get bh
1085                        return (IfaceExt aa)
1086               11 -> do ie <- get bh
1087                        ico <- get bh
1088                        return (IfaceCast ie ico)
1089               12 -> do m <- get bh
1090                        ix <- get bh
1091                        return (IfaceTick m ix)
1092               _ -> panic ("get IfaceExpr " ++ show h)
1093
1094 instance Binary IfaceConAlt where
1095     put_ bh IfaceDefault = do
1096             putByte bh 0
1097     put_ bh (IfaceDataAlt aa) = do
1098             putByte bh 1
1099             put_ bh aa
1100     put_ bh (IfaceTupleAlt ab) = do
1101             putByte bh 2
1102             put_ bh ab
1103     put_ bh (IfaceLitAlt ac) = do
1104             putByte bh 3
1105             put_ bh ac
1106     get bh = do
1107             h <- getByte bh
1108             case h of
1109               0 -> do return IfaceDefault
1110               1 -> do aa <- get bh
1111                       return (IfaceDataAlt aa)
1112               2 -> do ab <- get bh
1113                       return (IfaceTupleAlt ab)
1114               _ -> do ac <- get bh
1115                       return (IfaceLitAlt ac)
1116
1117 instance Binary IfaceBinding where
1118     put_ bh (IfaceNonRec aa ab) = do
1119             putByte bh 0
1120             put_ bh aa
1121             put_ bh ab
1122     put_ bh (IfaceRec ac) = do
1123             putByte bh 1
1124             put_ bh ac
1125     get bh = do
1126             h <- getByte bh
1127             case h of
1128               0 -> do aa <- get bh
1129                       ab <- get bh
1130                       return (IfaceNonRec aa ab)
1131               _ -> do ac <- get bh
1132                       return (IfaceRec ac)
1133
1134 instance Binary IfaceIdDetails where
1135     put_ bh IfVanillaId      = putByte bh 0
1136     put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b }
1137     put_ bh IfDFunId         = putByte bh 2
1138     get bh = do
1139             h <- getByte bh
1140             case h of
1141               0 -> return IfVanillaId
1142               1 -> do a <- get bh
1143                       b <- get bh
1144                       return (IfRecSelId a b)
1145               _ -> return IfDFunId
1146
1147 instance Binary IfaceIdInfo where
1148     put_ bh NoInfo = putByte bh 0
1149     put_ bh (HasInfo i) = do
1150             putByte bh 1
1151             lazyPut bh i                        -- NB lazyPut
1152
1153     get bh = do
1154             h <- getByte bh
1155             case h of
1156               0 -> return NoInfo
1157               _ -> do info <- lazyGet bh        -- NB lazyGet
1158                       return (HasInfo info)
1159
1160 instance Binary IfaceInfoItem where
1161     put_ bh (HsArity aa) = do
1162             putByte bh 0
1163             put_ bh aa
1164     put_ bh (HsStrictness ab) = do
1165             putByte bh 1
1166             put_ bh ab
1167     put_ bh (HsUnfold lb ad) = do
1168             putByte bh 2
1169             put_ bh lb
1170             put_ bh ad
1171     put_ bh (HsInline ad) = do
1172             putByte bh 3
1173             put_ bh ad
1174     put_ bh HsNoCafRefs = do
1175             putByte bh 4
1176     get bh = do
1177             h <- getByte bh
1178             case h of
1179               0 -> do aa <- get bh
1180                       return (HsArity aa)
1181               1 -> do ab <- get bh
1182                       return (HsStrictness ab)
1183               2 -> do lb <- get bh
1184                       ad <- get bh
1185                       return (HsUnfold lb ad)
1186               3 -> do ad <- get bh
1187                       return (HsInline ad)
1188               _ -> do return HsNoCafRefs
1189
1190 instance Binary IfaceUnfolding where
1191     put_ bh (IfCoreUnfold e) = do
1192         putByte bh 0
1193         put_ bh e
1194     put_ bh (IfInlineRule a b c d) = do
1195         putByte bh 1
1196         put_ bh a
1197         put_ bh b
1198         put_ bh c
1199         put_ bh d
1200     put_ bh (IfWrapper a n) = do
1201         putByte bh 2
1202         put_ bh a
1203         put_ bh n
1204     put_ bh (IfDFunUnfold as) = do
1205         putByte bh 3
1206         put_ bh as
1207     put_ bh (IfCompulsory e) = do
1208         putByte bh 4
1209         put_ bh e
1210     get bh = do
1211         h <- getByte bh
1212         case h of
1213           0 -> do e <- get bh
1214                   return (IfCoreUnfold e)
1215           1 -> do a <- get bh
1216                   b <- get bh
1217                   c <- get bh
1218                   d <- get bh
1219                   return (IfInlineRule a b c d)
1220           2 -> do a <- get bh
1221                   n <- get bh
1222                   return (IfWrapper a n)
1223           3 -> do as <- get bh
1224                   return (IfDFunUnfold as)
1225           _ -> do e <- get bh
1226                   return (IfCompulsory e)
1227
1228 instance Binary IfaceNote where
1229     put_ bh (IfaceSCC aa) = do
1230             putByte bh 0
1231             put_ bh aa
1232     put_ bh (IfaceCoreNote s) = do
1233             putByte bh 4
1234             put_ bh s
1235     get bh = do
1236             h <- getByte bh
1237             case h of
1238               0 -> do aa <- get bh
1239                       return (IfaceSCC aa)
1240               4 -> do ac <- get bh
1241                       return (IfaceCoreNote ac)
1242               _ -> panic ("get IfaceNote " ++ show h)
1243
1244 -------------------------------------------------------------------------
1245 --              IfaceDecl and friends
1246 -------------------------------------------------------------------------
1247
1248 -- A bit of magic going on here: there's no need to store the OccName
1249 -- for a decl on the disk, since we can infer the namespace from the
1250 -- context; however it is useful to have the OccName in the IfaceDecl
1251 -- to avoid re-building it in various places.  So we build the OccName
1252 -- when de-serialising.
1253
1254 instance Binary IfaceDecl where
1255     put_ bh (IfaceId name ty details idinfo) = do
1256             putByte bh 0
1257             put_ bh (occNameFS name)
1258             put_ bh ty
1259             put_ bh details
1260             put_ bh idinfo
1261     put_ _ (IfaceForeign _ _) =
1262         error "Binary.put_(IfaceDecl): IfaceForeign"
1263     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1264             putByte bh 2
1265             put_ bh (occNameFS a1)
1266             put_ bh a2
1267             put_ bh a3
1268             put_ bh a4
1269             put_ bh a5
1270             put_ bh a6
1271             put_ bh a7
1272             put_ bh a8
1273     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1274             putByte bh 3
1275             put_ bh (occNameFS a1)
1276             put_ bh a2
1277             put_ bh a3
1278             put_ bh a4
1279             put_ bh a5
1280     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1281             putByte bh 4
1282             put_ bh a1
1283             put_ bh (occNameFS a2)
1284             put_ bh a3
1285             put_ bh a4
1286             put_ bh a5
1287             put_ bh a6
1288             put_ bh a7
1289     get bh = do
1290             h <- getByte bh
1291             case h of
1292               0 -> do name    <- get bh
1293                       ty      <- get bh
1294                       details <- get bh
1295                       idinfo  <- get bh
1296                       occ <- return $! mkOccNameFS varName name
1297                       return (IfaceId occ ty details idinfo)
1298               1 -> error "Binary.get(TyClDecl): ForeignType"
1299               2 -> do
1300                     a1 <- get bh
1301                     a2 <- get bh
1302                     a3 <- get bh
1303                     a4 <- get bh
1304                     a5 <- get bh
1305                     a6 <- get bh
1306                     a7 <- get bh
1307                     a8 <- get bh
1308                     occ <- return $! mkOccNameFS tcName a1
1309                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1310               3 -> do
1311                     a1 <- get bh
1312                     a2 <- get bh
1313                     a3 <- get bh
1314                     a4 <- get bh
1315                     a5 <- get bh
1316                     occ <- return $! mkOccNameFS tcName a1
1317                     return (IfaceSyn occ a2 a3 a4 a5)
1318               _ -> do
1319                     a1 <- get bh
1320                     a2 <- get bh
1321                     a3 <- get bh
1322                     a4 <- get bh
1323                     a5 <- get bh
1324                     a6 <- get bh
1325                     a7 <- get bh
1326                     occ <- return $! mkOccNameFS clsName a2
1327                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1328
1329 instance Binary IfaceInst where
1330     put_ bh (IfaceInst cls tys dfun flag orph) = do
1331             put_ bh cls
1332             put_ bh tys
1333             put_ bh dfun
1334             put_ bh flag
1335             put_ bh orph
1336     get bh = do cls  <- get bh
1337                 tys  <- get bh
1338                 dfun <- get bh
1339                 flag <- get bh
1340                 orph <- get bh
1341                 return (IfaceInst cls tys dfun flag orph)
1342
1343 instance Binary IfaceFamInst where
1344     put_ bh (IfaceFamInst fam tys tycon) = do
1345             put_ bh fam
1346             put_ bh tys
1347             put_ bh tycon
1348     get bh = do fam   <- get bh
1349                 tys   <- get bh
1350                 tycon <- get bh
1351                 return (IfaceFamInst fam tys tycon)
1352
1353 instance Binary OverlapFlag where
1354     put_ bh NoOverlap  = putByte bh 0
1355     put_ bh OverlapOk  = putByte bh 1
1356     put_ bh Incoherent = putByte bh 2
1357     get bh = do h <- getByte bh
1358                 case h of
1359                   0 -> return NoOverlap
1360                   1 -> return OverlapOk
1361                   2 -> return Incoherent
1362                   _ -> panic ("get OverlapFlag " ++ show h)
1363
1364 instance Binary IfaceConDecls where
1365     put_ bh IfAbstractTyCon = putByte bh 0
1366     put_ bh IfOpenDataTyCon = putByte bh 1
1367     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1368                                   ; put_ bh cs }
1369     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1370                                   ; put_ bh c }
1371     get bh = do
1372             h <- getByte bh
1373             case h of
1374               0 -> return IfAbstractTyCon
1375               1 -> return IfOpenDataTyCon
1376               2 -> do cs <- get bh
1377                       return (IfDataTyCon cs)
1378               _ -> do aa <- get bh
1379                       return (IfNewTyCon aa)
1380
1381 instance Binary IfaceConDecl where
1382     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1383             put_ bh a1
1384             put_ bh a2
1385             put_ bh a3
1386             put_ bh a4
1387             put_ bh a5
1388             put_ bh a6
1389             put_ bh a7
1390             put_ bh a8
1391             put_ bh a9
1392             put_ bh a10
1393     get bh = do a1 <- get bh
1394                 a2 <- get bh
1395                 a3 <- get bh
1396                 a4 <- get bh
1397                 a5 <- get bh
1398                 a6 <- get bh
1399                 a7 <- get bh
1400                 a8 <- get bh
1401                 a9 <- get bh
1402                 a10 <- get bh
1403                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1404
1405 instance Binary IfaceClassOp where
1406    put_ bh (IfaceClassOp n def ty) = do
1407         put_ bh (occNameFS n)
1408         put_ bh def
1409         put_ bh ty
1410    get bh = do
1411         n <- get bh
1412         def <- get bh
1413         ty <- get bh
1414         occ <- return $! mkOccNameFS varName n
1415         return (IfaceClassOp occ def ty)
1416
1417 instance Binary IfaceRule where
1418     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1419             put_ bh a1
1420             put_ bh a2
1421             put_ bh a3
1422             put_ bh a4
1423             put_ bh a5
1424             put_ bh a6
1425             put_ bh a7
1426     get bh = do
1427             a1 <- get bh
1428             a2 <- get bh
1429             a3 <- get bh
1430             a4 <- get bh
1431             a5 <- get bh
1432             a6 <- get bh
1433             a7 <- get bh
1434             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1435
1436 instance Binary IfaceAnnotation where
1437     put_ bh (IfaceAnnotation a1 a2) = do
1438         put_ bh a1
1439         put_ bh a2
1440     get bh = do
1441         a1 <- get bh
1442         a2 <- get bh
1443         return (IfaceAnnotation a1 a2)
1444
1445 instance Binary name => Binary (AnnTarget name) where
1446     put_ bh (NamedTarget a) = do
1447         putByte bh 0
1448         put_ bh a
1449     put_ bh (ModuleTarget a) = do
1450         putByte bh 1
1451         put_ bh a
1452     get bh = do
1453         h <- getByte bh
1454         case h of
1455           0 -> do a <- get bh
1456                   return (NamedTarget a)
1457           _ -> do a <- get bh
1458                   return (ModuleTarget a)
1459
1460 instance Binary IfaceVectInfo where
1461     put_ bh (IfaceVectInfo a1 a2 a3) = do
1462             put_ bh a1
1463             put_ bh a2
1464             put_ bh a3
1465     get bh = do
1466             a1 <- get bh
1467             a2 <- get bh
1468             a3 <- get bh
1469             return (IfaceVectInfo a1 a2 a3)
1470
1471