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