compiler/iface/BinIface.hs

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