compiler/iface/BinIface.hs

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