compiler/iface/BinIface.hs

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