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 IfaceLetBndr where
 694     put_ bh (IfLetBndr a b c) = do
 695             put_ bh a
 696             put_ bh b
 697             put_ bh c
 698     get bh = do a <- get bh
 699                 b <- get bh
 700                 c <- get bh
 701                 return (IfLetBndr a b c)
 702
 703 instance Binary IfaceType where
 704     put_ bh (IfaceForAllTy aa ab) = do
 705             putByte bh 0
 706             put_ bh aa
 707             put_ bh ab
 708     put_ bh (IfaceTyVar ad) = do
 709             putByte bh 1
 710             put_ bh ad
 711     put_ bh (IfaceAppTy ae af) = do
 712             putByte bh 2
 713             put_ bh ae
 714             put_ bh af
 715     put_ bh (IfaceFunTy ag ah) = do
 716             putByte bh 3
 717             put_ bh ag
 718             put_ bh ah
 719     put_ bh (IfacePredTy aq) = do
 720             putByte bh 5
 721             put_ bh aq
 722
 723         -- Simple compression for common cases of TyConApp
 724     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 725     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 726     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 727     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 728         -- Unit tuple and pairs
 729     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 730     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 731         -- Kind cases
 732     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 733     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 734     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 735     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 736     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 737
 738         -- Generic cases
 739
 740     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 741     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 742
 743     get bh = do
 744             h <- getByte bh
 745             case h of
 746               0 -> do aa <- get bh
 747                       ab <- get bh
 748                       return (IfaceForAllTy aa ab)
 749               1 -> do ad <- get bh
 750                       return (IfaceTyVar ad)
 751               2 -> do ae <- get bh
 752                       af <- get bh
 753                       return (IfaceAppTy ae af)
 754               3 -> do ag <- get bh
 755                       ah <- get bh
 756                       return (IfaceFunTy ag ah)
 757               5 -> do ap <- get bh
 758                       return (IfacePredTy ap)
 759
 760                 -- Now the special cases for TyConApp
 761               6 -> return (IfaceTyConApp IfaceIntTc [])
 762               7 -> return (IfaceTyConApp IfaceCharTc [])
 763               8 -> return (IfaceTyConApp IfaceBoolTc [])
 764               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 765               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 766               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 767               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 768               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 769               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 770               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 771               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 772
 773               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 774               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 775
 776 instance Binary IfaceTyCon where
 777         -- Int,Char,Bool can't show up here because they can't not be saturated
 778
 779    put_ bh IfaceIntTc         = putByte bh 1
 780    put_ bh IfaceBoolTc        = putByte bh 2
 781    put_ bh IfaceCharTc        = putByte bh 3
 782    put_ bh IfaceListTc        = putByte bh 4
 783    put_ bh IfacePArrTc        = putByte bh 5
 784    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 785    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 786    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 787    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 788    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 789    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 790    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 791
 792    get bh = do
 793         h <- getByte bh
 794         case h of
 795           1 -> return IfaceIntTc
 796           2 -> return IfaceBoolTc
 797           3 -> return IfaceCharTc
 798           4 -> return IfaceListTc
 799           5 -> return IfacePArrTc
 800           6 -> return IfaceLiftedTypeKindTc
 801           7 -> return IfaceOpenTypeKindTc
 802           8 -> return IfaceUnliftedTypeKindTc
 803           9 -> return IfaceUbxTupleKindTc
 804           10 -> return IfaceArgTypeKindTc
 805           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 806           _ -> do { ext <- get bh; return (IfaceTc ext) }
 807
 808 instance Binary IfacePredType where
 809     put_ bh (IfaceClassP aa ab) = do
 810             putByte bh 0
 811             put_ bh aa
 812             put_ bh ab
 813     put_ bh (IfaceIParam ac ad) = do
 814             putByte bh 1
 815             put_ bh ac
 816             put_ bh ad
 817     put_ bh (IfaceEqPred ac ad) = do
 818             putByte bh 2
 819             put_ bh ac
 820             put_ bh ad
 821     get bh = do
 822             h <- getByte bh
 823             case h of
 824               0 -> do aa <- get bh
 825                       ab <- get bh
 826                       return (IfaceClassP aa ab)
 827               1 -> do ac <- get bh
 828                       ad <- get bh
 829                       return (IfaceIParam ac ad)
 830               2 -> do ac <- get bh
 831                       ad <- get bh
 832                       return (IfaceEqPred ac ad)
 833
 834 -------------------------------------------------------------------------
 835 --              IfaceExpr and friends
 836 -------------------------------------------------------------------------
 837
 838 instance Binary IfaceExpr where
 839     put_ bh (IfaceLcl aa) = do
 840             putByte bh 0
 841             put_ bh aa
 842     put_ bh (IfaceType ab) = do
 843             putByte bh 1
 844             put_ bh ab
 845     put_ bh (IfaceTuple ac ad) = do
 846             putByte bh 2
 847             put_ bh ac
 848             put_ bh ad
 849     put_ bh (IfaceLam ae af) = do
 850             putByte bh 3
 851             put_ bh ae
 852             put_ bh af
 853     put_ bh (IfaceApp ag ah) = do
 854             putByte bh 4
 855             put_ bh ag
 856             put_ bh ah
 857 -- gaw 2004
 858     put_ bh (IfaceCase ai aj al ak) = do
 859             putByte bh 5
 860             put_ bh ai
 861             put_ bh aj
 862 -- gaw 2004
 863             put_ bh al
 864             put_ bh ak
 865     put_ bh (IfaceLet al am) = do
 866             putByte bh 6
 867             put_ bh al
 868             put_ bh am
 869     put_ bh (IfaceNote an ao) = do
 870             putByte bh 7
 871             put_ bh an
 872             put_ bh ao
 873     put_ bh (IfaceLit ap) = do
 874             putByte bh 8
 875             put_ bh ap
 876     put_ bh (IfaceFCall as at) = do
 877             putByte bh 9
 878             put_ bh as
 879             put_ bh at
 880     put_ bh (IfaceExt aa) = do
 881             putByte bh 10
 882             put_ bh aa
 883     put_ bh (IfaceCast ie ico) = do
 884             putByte bh 11
 885             put_ bh ie
 886             put_ bh ico
 887     get bh = do
 888             h <- getByte bh
 889             case h of
 890               0 -> do aa <- get bh
 891                       return (IfaceLcl aa)
 892               1 -> do ab <- get bh
 893                       return (IfaceType ab)
 894               2 -> do ac <- get bh
 895                       ad <- get bh
 896                       return (IfaceTuple ac ad)
 897               3 -> do ae <- get bh
 898                       af <- get bh
 899                       return (IfaceLam ae af)
 900               4 -> do ag <- get bh
 901                       ah <- get bh
 902                       return (IfaceApp ag ah)
 903               5 -> do ai <- get bh
 904                       aj <- get bh
 905 -- gaw 2004
 906                       al <- get bh
 907                       ak <- get bh
 908 -- gaw 2004
 909                       return (IfaceCase ai aj al ak)
 910               6 -> do al <- get bh
 911                       am <- get bh
 912                       return (IfaceLet al am)
 913               7 -> do an <- get bh
 914                       ao <- get bh
 915                       return (IfaceNote an ao)
 916               8 -> do ap <- get bh
 917                       return (IfaceLit ap)
 918               9 -> do as <- get bh
 919                       at <- get bh
 920                       return (IfaceFCall as at)
 921               10 -> do aa <- get bh
 922                        return (IfaceExt aa)
 923               11 -> do ie <- get bh
 924                        ico <- get bh
 925                        return (IfaceCast ie ico)
 926
 927 instance Binary IfaceConAlt where
 928     put_ bh IfaceDefault = do
 929             putByte bh 0
 930     put_ bh (IfaceDataAlt aa) = do
 931             putByte bh 1
 932             put_ bh aa
 933     put_ bh (IfaceTupleAlt ab) = do
 934             putByte bh 2
 935             put_ bh ab
 936     put_ bh (IfaceLitAlt ac) = do
 937             putByte bh 3
 938             put_ bh ac
 939     get bh = do
 940             h <- getByte bh
 941             case h of
 942               0 -> do return IfaceDefault
 943               1 -> do aa <- get bh
 944                       return (IfaceDataAlt aa)
 945               2 -> do ab <- get bh
 946                       return (IfaceTupleAlt ab)
 947               _ -> do ac <- get bh
 948                       return (IfaceLitAlt ac)
 949
 950 instance Binary IfaceBinding where
 951     put_ bh (IfaceNonRec aa ab) = do
 952             putByte bh 0
 953             put_ bh aa
 954             put_ bh ab
 955     put_ bh (IfaceRec ac) = do
 956             putByte bh 1
 957             put_ bh ac
 958     get bh = do
 959             h <- getByte bh
 960             case h of
 961               0 -> do aa <- get bh
 962                       ab <- get bh
 963                       return (IfaceNonRec aa ab)
 964               _ -> do ac <- get bh
 965                       return (IfaceRec ac)
 966
 967 instance Binary IfaceIdInfo where
 968     put_ bh NoInfo = putByte bh 0
 969     put_ bh (HasInfo i) = do
 970             putByte bh 1
 971             lazyPut bh i                        -- NB lazyPut
 972
 973     get bh = do
 974             h <- getByte bh
 975             case h of
 976               0 -> return NoInfo
 977               _ -> do info <- lazyGet bh        -- NB lazyGet
 978                       return (HasInfo info)
 979
 980 instance Binary IfaceInfoItem where
 981     put_ bh (HsArity aa) = do
 982             putByte bh 0
 983             put_ bh aa
 984     put_ bh (HsStrictness ab) = do
 985             putByte bh 1
 986             put_ bh ab
 987     put_ bh (HsUnfold ad) = do
 988             putByte bh 2
 989             put_ bh ad
 990     put_ bh (HsInline ad) = do
 991             putByte bh 3
 992             put_ bh ad
 993     put_ bh HsNoCafRefs = do
 994             putByte bh 4
 995     put_ bh (HsWorker ae af) = do
 996             putByte bh 5
 997             put_ bh ae
 998             put_ bh af
 999     get bh = do
1000             h <- getByte bh
1001             case h of
1002               0 -> do aa <- get bh
1003                       return (HsArity aa)
1004               1 -> do ab <- get bh
1005                       return (HsStrictness ab)
1006               2 -> do ad <- get bh
1007                       return (HsUnfold ad)
1008               3 -> do ad <- get bh
1009                       return (HsInline ad)
1010               4 -> do return HsNoCafRefs
1011               _ -> do ae <- get bh
1012                       af <- get bh
1013                       return (HsWorker ae af)
1014
1015 instance Binary IfaceNote where
1016     put_ bh (IfaceSCC aa) = do
1017             putByte bh 0
1018             put_ bh aa
1019     put_ bh IfaceInlineMe = do
1020             putByte bh 3
1021     put_ bh (IfaceCoreNote s) = do
1022             putByte bh 4
1023             put_ bh s
1024     get bh = do
1025             h <- getByte bh
1026             case h of
1027               0 -> do aa <- get bh
1028                       return (IfaceSCC aa)
1029               3 -> do return IfaceInlineMe
1030               4 -> do ac <- get bh
1031                       return (IfaceCoreNote ac)
1032
1033 -------------------------------------------------------------------------
1034 --              IfaceDecl and friends
1035 -------------------------------------------------------------------------
1036
1037 -- A bit of magic going on here: there's no need to store the OccName
1038 -- for a decl on the disk, since we can infer the namespace from the
1039 -- context; however it is useful to have the OccName in the IfaceDecl
1040 -- to avoid re-building it in various places.  So we build the OccName
1041 -- when de-serialising.
1042
1043 instance Binary IfaceDecl where
1044     put_ bh (IfaceId name ty idinfo) = do
1045             putByte bh 0
1046             put_ bh (occNameFS name)
1047             put_ bh ty
1048             put_ bh idinfo
1049     put_ bh (IfaceForeign ae af) =
1050         error "Binary.put_(IfaceDecl): IfaceForeign"
1051     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1052             putByte bh 2
1053             put_ bh (occNameFS a1)
1054             put_ bh a2
1055             put_ bh a3
1056             put_ bh a4
1057             put_ bh a5
1058             put_ bh a6
1059             put_ bh a7
1060             put_ bh a8
1061     put_ bh (IfaceSyn aq ar as at) = do
1062             putByte bh 3
1063             put_ bh (occNameFS aq)
1064             put_ bh ar
1065             put_ bh as
1066             put_ bh at
1067     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1068             putByte bh 4
1069             put_ bh a1
1070             put_ bh (occNameFS a2)
1071             put_ bh a3
1072             put_ bh a4
1073             put_ bh a5
1074             put_ bh a6
1075             put_ bh a7
1076     get bh = do
1077             h <- getByte bh
1078             case h of
1079               0 -> do name   <- get bh
1080                       ty     <- get bh
1081                       idinfo <- get bh
1082                       occ <- return $! mkOccNameFS varName name
1083                       return (IfaceId occ ty idinfo)
1084               1 -> error "Binary.get(TyClDecl): ForeignType"
1085               2 -> do
1086                     a1 <- get bh
1087                     a2 <- get bh
1088                     a3 <- get bh
1089                     a4 <- get bh
1090                     a5 <- get bh
1091                     a6 <- get bh
1092                     a7 <- get bh
1093                     a8 <- get bh
1094                     occ <- return $! mkOccNameFS tcName a1
1095                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1096               3 -> do
1097                     aq <- get bh
1098                     ar <- get bh
1099                     as <- get bh
1100                     at <- get bh
1101                     occ <- return $! mkOccNameFS tcName aq
1102                     return (IfaceSyn occ ar as at)
1103               _ -> do
1104                     a1 <- get bh
1105                     a2 <- get bh
1106                     a3 <- get bh
1107                     a4 <- get bh
1108                     a5 <- get bh
1109                     a6 <- get bh
1110                     a7 <- get bh
1111                     occ <- return $! mkOccNameFS clsName a2
1112                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1113
1114 instance Binary IfaceInst where
1115     put_ bh (IfaceInst cls tys dfun flag orph) = do
1116             put_ bh cls
1117             put_ bh tys
1118             put_ bh dfun
1119             put_ bh flag
1120             put_ bh orph
1121     get bh = do cls  <- get bh
1122                 tys  <- get bh
1123                 dfun <- get bh
1124                 flag <- get bh
1125                 orph <- get bh
1126                 return (IfaceInst cls tys dfun flag orph)
1127
1128 instance Binary IfaceFamInst where
1129     put_ bh (IfaceFamInst fam tys tycon) = do
1130             put_ bh fam
1131             put_ bh tys
1132             put_ bh tycon
1133     get bh = do fam   <- get bh
1134                 tys   <- get bh
1135                 tycon <- get bh
1136                 return (IfaceFamInst fam tys tycon)
1137
1138 instance Binary OverlapFlag where
1139     put_ bh NoOverlap  = putByte bh 0
1140     put_ bh OverlapOk  = putByte bh 1
1141     put_ bh Incoherent = putByte bh 2
1142     get bh = do h <- getByte bh
1143                 case h of
1144                   0 -> return NoOverlap
1145                   1 -> return OverlapOk
1146                   2 -> return Incoherent
1147
1148 instance Binary IfaceConDecls where
1149     put_ bh IfAbstractTyCon = putByte bh 0
1150     put_ bh IfOpenDataTyCon = putByte bh 1
1151     put_ bh IfOpenNewTyCon = putByte bh 2
1152     put_ bh (IfDataTyCon cs) = do { putByte bh 3
1153                                   ; put_ bh cs }
1154     put_ bh (IfNewTyCon c)  = do { putByte bh 4
1155                                   ; put_ bh c }
1156     get bh = do
1157             h <- getByte bh
1158             case h of
1159               0 -> return IfAbstractTyCon
1160               1 -> return IfOpenDataTyCon
1161               2 -> return IfOpenNewTyCon
1162               3 -> do cs <- get bh
1163                       return (IfDataTyCon cs)
1164               _ -> do aa <- get bh
1165                       return (IfNewTyCon aa)
1166
1167 instance Binary IfaceConDecl where
1168     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1169             put_ bh a1
1170             put_ bh a2
1171             put_ bh a3
1172             put_ bh a4
1173             put_ bh a5
1174             put_ bh a6
1175             put_ bh a7
1176             put_ bh a8
1177             put_ bh a9
1178     get bh = do a1 <- get bh
1179                 a2 <- get bh
1180                 a3 <- get bh
1181                 a4 <- get bh
1182                 a5 <- get bh
1183                 a6 <- get bh
1184                 a7 <- get bh
1185                 a8 <- get bh
1186                 a9 <- get bh
1187                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1188
1189 instance Binary IfaceClassOp where
1190    put_ bh (IfaceClassOp n def ty) = do
1191         put_ bh (occNameFS n)
1192         put_ bh def
1193         put_ bh ty
1194    get bh = do
1195         n <- get bh
1196         def <- get bh
1197         ty <- get bh
1198         occ <- return $! mkOccNameFS varName n
1199         return (IfaceClassOp occ def ty)
1200
1201 instance Binary IfaceRule where
1202     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1203             put_ bh a1
1204             put_ bh a2
1205             put_ bh a3
1206             put_ bh a4
1207             put_ bh a5
1208             put_ bh a6
1209             put_ bh a7
1210     get bh = do
1211             a1 <- get bh
1212             a2 <- get bh
1213             a3 <- get bh
1214             a4 <- get bh
1215             a5 <- get bh
1216             a6 <- get bh
1217             a7 <- get bh
1218             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1219
1220