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