PageRenderTime 82ms CodeModel.GetById 19ms app.highlight 48ms RepoModel.GetById 1ms app.codeStats 1ms

/compiler/iface/BinIface.hs

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