compiler/iface/BinIface.hs

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