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