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     get bh = do
 893             h <- getByte bh
 894             case h of
 895               0 -> do aa <- get bh
 896                       return (IfaceLcl aa)
 897               1 -> do ab <- get bh
 898                       return (IfaceType ab)
 899               2 -> do ac <- get bh
 900                       ad <- get bh
 901                       return (IfaceTuple ac ad)
 902               3 -> do ae <- get bh
 903                       af <- get bh
 904                       return (IfaceLam ae af)
 905               4 -> do ag <- get bh
 906                       ah <- get bh
 907                       return (IfaceApp ag ah)
 908               5 -> do ai <- get bh
 909                       aj <- get bh
 910 -- gaw 2004
 911                       al <- get bh
 912                       ak <- get bh
 913 -- gaw 2004
 914                       return (IfaceCase ai aj al ak)
 915               6 -> do al <- get bh
 916                       am <- get bh
 917                       return (IfaceLet al am)
 918               7 -> do an <- get bh
 919                       ao <- get bh
 920                       return (IfaceNote an ao)
 921               8 -> do ap <- get bh
 922                       return (IfaceLit ap)
 923               9 -> do as <- get bh
 924                       at <- get bh
 925                       return (IfaceFCall as at)
 926               10 -> do aa <- get bh
 927                        return (IfaceExt aa)
 928               11 -> do ie <- get bh
 929                        ico <- get bh
 930                        return (IfaceCast ie ico)
 931
 932 instance Binary IfaceConAlt where
 933     put_ bh IfaceDefault = do
 934             putByte bh 0
 935     put_ bh (IfaceDataAlt aa) = do
 936             putByte bh 1
 937             put_ bh aa
 938     put_ bh (IfaceTupleAlt ab) = do
 939             putByte bh 2
 940             put_ bh ab
 941     put_ bh (IfaceLitAlt ac) = do
 942             putByte bh 3
 943             put_ bh ac
 944     get bh = do
 945             h <- getByte bh
 946             case h of
 947               0 -> do return IfaceDefault
 948               1 -> do aa <- get bh
 949                       return (IfaceDataAlt aa)
 950               2 -> do ab <- get bh
 951                       return (IfaceTupleAlt ab)
 952               _ -> do ac <- get bh
 953                       return (IfaceLitAlt ac)
 954
 955 instance Binary IfaceBinding where
 956     put_ bh (IfaceNonRec aa ab) = do
 957             putByte bh 0
 958             put_ bh aa
 959             put_ bh ab
 960     put_ bh (IfaceRec ac) = do
 961             putByte bh 1
 962             put_ bh ac
 963     get bh = do
 964             h <- getByte bh
 965             case h of
 966               0 -> do aa <- get bh
 967                       ab <- get bh
 968                       return (IfaceNonRec aa ab)
 969               _ -> do ac <- get bh
 970                       return (IfaceRec ac)
 971
 972 instance Binary IfaceIdInfo where
 973     put_ bh NoInfo = putByte bh 0
 974     put_ bh (HasInfo i) = do
 975             putByte bh 1
 976             lazyPut bh i                        -- NB lazyPut
 977
 978     get bh = do
 979             h <- getByte bh
 980             case h of
 981               0 -> return NoInfo
 982               _ -> do info <- lazyGet bh        -- NB lazyGet
 983                       return (HasInfo info)
 984
 985 instance Binary IfaceInfoItem where
 986     put_ bh (HsArity aa) = do
 987             putByte bh 0
 988             put_ bh aa
 989     put_ bh (HsStrictness ab) = do
 990             putByte bh 1
 991             put_ bh ab
 992     put_ bh (HsUnfold ad) = do
 993             putByte bh 2
 994             put_ bh ad
 995     put_ bh (HsInline ad) = do
 996             putByte bh 3
 997             put_ bh ad
 998     put_ bh HsNoCafRefs = do
 999             putByte bh 4
1000     put_ bh (HsWorker ae af) = do
1001             putByte bh 5
1002             put_ bh ae
1003             put_ bh af
1004     get bh = do
1005             h <- getByte bh
1006             case h of
1007               0 -> do aa <- get bh
1008                       return (HsArity aa)
1009               1 -> do ab <- get bh
1010                       return (HsStrictness ab)
1011               2 -> do ad <- get bh
1012                       return (HsUnfold ad)
1013               3 -> do ad <- get bh
1014                       return (HsInline ad)
1015               4 -> do return HsNoCafRefs
1016               _ -> do ae <- get bh
1017                       af <- get bh
1018                       return (HsWorker ae af)
1019
1020 instance Binary IfaceNote where
1021     put_ bh (IfaceSCC aa) = do
1022             putByte bh 0
1023             put_ bh aa
1024     put_ bh IfaceInlineMe = do
1025             putByte bh 3
1026     put_ bh (IfaceCoreNote s) = do
1027             putByte bh 4
1028             put_ bh s
1029     get bh = do
1030             h <- getByte bh
1031             case h of
1032               0 -> do aa <- get bh
1033                       return (IfaceSCC aa)
1034               3 -> do return IfaceInlineMe
1035               4 -> do ac <- get bh
1036                       return (IfaceCoreNote ac)
1037
1038 -------------------------------------------------------------------------
1039 --              IfaceDecl and friends
1040 -------------------------------------------------------------------------
1041
1042 -- A bit of magic going on here: there's no need to store the OccName
1043 -- for a decl on the disk, since we can infer the namespace from the
1044 -- context; however it is useful to have the OccName in the IfaceDecl
1045 -- to avoid re-building it in various places.  So we build the OccName
1046 -- when de-serialising.
1047
1048 instance Binary IfaceDecl where
1049     put_ bh (IfaceId name ty idinfo) = do
1050             putByte bh 0
1051             put_ bh (occNameFS name)
1052             put_ bh ty
1053             put_ bh idinfo
1054     put_ bh (IfaceForeign ae af) =
1055         error "Binary.put_(IfaceDecl): IfaceForeign"
1056     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1057             putByte bh 2
1058             put_ bh (occNameFS a1)
1059             put_ bh a2
1060             put_ bh a3
1061             put_ bh a4
1062             put_ bh a5
1063             put_ bh a6
1064             put_ bh a7
1065             put_ bh a8
1066     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1067             putByte bh 3
1068             put_ bh (occNameFS a1)
1069             put_ bh a2
1070             put_ bh a3
1071             put_ bh a4
1072             put_ bh a5
1073     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1074             putByte bh 4
1075             put_ bh a1
1076             put_ bh (occNameFS a2)
1077             put_ bh a3
1078             put_ bh a4
1079             put_ bh a5
1080             put_ bh a6
1081             put_ bh a7
1082     get bh = do
1083             h <- getByte bh
1084             case h of
1085               0 -> do name   <- get bh
1086                       ty     <- get bh
1087                       idinfo <- get bh
1088                       occ <- return $! mkOccNameFS varName name
1089                       return (IfaceId occ ty idinfo)
1090               1 -> error "Binary.get(TyClDecl): ForeignType"
1091               2 -> do
1092                     a1 <- get bh
1093                     a2 <- get bh
1094                     a3 <- get bh
1095                     a4 <- get bh
1096                     a5 <- get bh
1097                     a6 <- get bh
1098                     a7 <- get bh
1099                     a8 <- get bh
1100                     occ <- return $! mkOccNameFS tcName a1
1101                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1102               3 -> do
1103                     a1 <- get bh
1104                     a2 <- get bh
1105                     a3 <- get bh
1106                     a4 <- get bh
1107                     a5 <- get bh
1108                     occ <- return $! mkOccNameFS tcName a1
1109                     return (IfaceSyn occ a2 a3 a4 a5)
1110               _ -> do
1111                     a1 <- get bh
1112                     a2 <- get bh
1113                     a3 <- get bh
1114                     a4 <- get bh
1115                     a5 <- get bh
1116                     a6 <- get bh
1117                     a7 <- get bh
1118                     occ <- return $! mkOccNameFS clsName a2
1119                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1120
1121 instance Binary IfaceInst where
1122     put_ bh (IfaceInst cls tys dfun flag orph) = do
1123             put_ bh cls
1124             put_ bh tys
1125             put_ bh dfun
1126             put_ bh flag
1127             put_ bh orph
1128     get bh = do cls  <- get bh
1129                 tys  <- get bh
1130                 dfun <- get bh
1131                 flag <- get bh
1132                 orph <- get bh
1133                 return (IfaceInst cls tys dfun flag orph)
1134
1135 instance Binary IfaceFamInst where
1136     put_ bh (IfaceFamInst fam tys tycon) = do
1137             put_ bh fam
1138             put_ bh tys
1139             put_ bh tycon
1140     get bh = do fam   <- get bh
1141                 tys   <- get bh
1142                 tycon <- get bh
1143                 return (IfaceFamInst fam tys tycon)
1144
1145 instance Binary OverlapFlag where
1146     put_ bh NoOverlap  = putByte bh 0
1147     put_ bh OverlapOk  = putByte bh 1
1148     put_ bh Incoherent = putByte bh 2
1149     get bh = do h <- getByte bh
1150                 case h of
1151                   0 -> return NoOverlap
1152                   1 -> return OverlapOk
1153                   2 -> return Incoherent
1154
1155 instance Binary IfaceConDecls where
1156     put_ bh IfAbstractTyCon = putByte bh 0
1157     put_ bh IfOpenDataTyCon = putByte bh 1
1158     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1159                                   ; put_ bh cs }
1160     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1161                                   ; put_ bh c }
1162     get bh = do
1163             h <- getByte bh
1164             case h of
1165               0 -> return IfAbstractTyCon
1166               1 -> return IfOpenDataTyCon
1167               2 -> do cs <- get bh
1168                       return (IfDataTyCon cs)
1169               _ -> do aa <- get bh
1170                       return (IfNewTyCon aa)
1171
1172 instance Binary IfaceConDecl where
1173     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1174             put_ bh a1
1175             put_ bh a2
1176             put_ bh a3
1177             put_ bh a4
1178             put_ bh a5
1179             put_ bh a6
1180             put_ bh a7
1181             put_ bh a8
1182             put_ bh a9
1183     get bh = do a1 <- get bh
1184                 a2 <- get bh
1185                 a3 <- get bh
1186                 a4 <- get bh
1187                 a5 <- get bh
1188                 a6 <- get bh
1189                 a7 <- get bh
1190                 a8 <- get bh
1191                 a9 <- get bh
1192                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1193
1194 instance Binary IfaceClassOp where
1195    put_ bh (IfaceClassOp n def ty) = do
1196         put_ bh (occNameFS n)
1197         put_ bh def
1198         put_ bh ty
1199    get bh = do
1200         n <- get bh
1201         def <- get bh
1202         ty <- get bh
1203         occ <- return $! mkOccNameFS varName n
1204         return (IfaceClassOp occ def ty)
1205
1206 instance Binary IfaceRule where
1207     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1208             put_ bh a1
1209             put_ bh a2
1210             put_ bh a3
1211             put_ bh a4
1212             put_ bh a5
1213             put_ bh a6
1214             put_ bh a7
1215     get bh = do
1216             a1 <- get bh
1217             a2 <- get bh
1218             a3 <- get bh
1219             a4 <- get bh
1220             a5 <- get bh
1221             a6 <- get bh
1222             a7 <- get bh
1223             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1224
1225 instance Binary IfaceVectInfo where
1226     put_ bh (IfaceVectInfo a1 a2 a3) = do
1227             put_ bh a1
1228             put_ bh a2
1229             put_ bh a3
1230     get bh = do
1231             a1 <- get bh
1232             a2 <- get bh
1233             a3 <- get bh
1234             return (IfaceVectInfo a1 a2 a3)
1235
1236