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_deps      = deps,
 255                  mi_usages    = usages,
 256                  mi_exports   = exports,
 257                  mi_exp_vers  = exp_vers,
 258                  mi_fixities  = fixities,
 259                  mi_deprecs   = deprecs,
 260                  mi_decls     = decls,
 261                  mi_insts     = insts,
 262                  mi_fam_insts = fam_insts,
 263                  mi_rules     = rules,
 264                  mi_rule_vers = rule_vers }) = do
 265         put_ bh (show opt_HiVersion)
 266         way_descr <- getWayDescr
 267         put  bh way_descr
 268         put_ bh mod
 269         put_ bh is_boot
 270         put_ bh mod_vers
 271         put_ bh orphan
 272         lazyPut bh deps
 273         lazyPut bh usages
 274         put_ bh exports
 275         put_ bh exp_vers
 276         put_ bh fixities
 277         lazyPut bh deprecs
 278         put_ bh decls
 279         put_ bh insts
 280         put_ bh fam_insts
 281         lazyPut bh rules
 282         put_ bh rule_vers
 283
 284    get bh = do
 285         check_ver  <- get bh
 286         let our_ver = show opt_HiVersion
 287         when (check_ver /= our_ver) $
 288            -- use userError because this will be caught by readIface
 289            -- which will emit an error msg containing the iface module name.
 290            throwDyn (ProgramError (
 291                 "mismatched interface file versions: expected "
 292                 ++ our_ver ++ ", found " ++ check_ver))
 293
 294         check_way <- get bh
 295         ignore_way <- readIORef v_IgnoreHiWay
 296         way_descr <- getWayDescr
 297         when (not ignore_way && check_way /= way_descr) $
 298            -- use userError because this will be caught by readIface
 299            -- which will emit an error msg containing the iface module name.
 300            throwDyn (ProgramError (
 301                 "mismatched interface file ways: expected "
 302                 ++ way_descr ++ ", found " ++ check_way))
 303
 304         mod_name  <- get bh
 305         is_boot   <- get bh
 306         mod_vers  <- get bh
 307         orphan    <- get bh
 308         deps      <- lazyGet bh
 309         usages    <- {-# SCC "bin_usages" #-} lazyGet bh
 310         exports   <- {-# SCC "bin_exports" #-} get bh
 311         exp_vers  <- get bh
 312         fixities  <- {-# SCC "bin_fixities" #-} get bh
 313         deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
 314         decls     <- {-# SCC "bin_tycldecls" #-} get bh
 315         insts     <- {-# SCC "bin_insts" #-} get bh
 316         fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
 317         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 318         rule_vers <- get bh
 319         return (ModIface {
 320                  mi_module    = mod_name,
 321                  mi_boot      = is_boot,
 322                  mi_mod_vers  = mod_vers,
 323                  mi_orphan    = orphan,
 324                  mi_deps      = deps,
 325                  mi_usages    = usages,
 326                  mi_exports   = exports,
 327                  mi_exp_vers  = exp_vers,
 328                  mi_fixities  = fixities,
 329                  mi_deprecs   = deprecs,
 330                  mi_decls     = decls,
 331                  mi_globals   = Nothing,
 332                  mi_insts     = insts,
 333                  mi_fam_insts = fam_insts,
 334                  mi_rules     = rules,
 335                  mi_rule_vers = rule_vers,
 336                         -- And build the cached values
 337                  mi_dep_fn    = mkIfaceDepCache deprecs,
 338                  mi_fix_fn    = mkIfaceFixCache fixities,
 339                  mi_ver_fn    = mkIfaceVerCache decls })
 340
 341 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
 342
 343 getWayDescr :: IO String
 344 getWayDescr = do
 345   tag <- readIORef v_Build_tag
 346   if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
 347         -- if this is an unregisterised build, make sure our interfaces
 348         -- can't be used by a registerised build.
 349
 350 -------------------------------------------------------------------------
 351 --              Types from: HscTypes
 352 -------------------------------------------------------------------------
 353
 354 instance Binary Dependencies where
 355     put_ bh deps = do put_ bh (dep_mods deps)
 356                       put_ bh (dep_pkgs deps)
 357                       put_ bh (dep_orphs deps)
 358
 359     get bh = do ms <- get bh
 360                 ps <- get bh
 361                 os <- get bh
 362                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
 363
 364 instance (Binary name) => Binary (GenAvailInfo name) where
 365     put_ bh (Avail aa) = do
 366             putByte bh 0
 367             put_ bh aa
 368     put_ bh (AvailTC ab ac) = do
 369             putByte bh 1
 370             put_ bh ab
 371             put_ bh ac
 372     get bh = do
 373             h <- getByte bh
 374             case h of
 375               0 -> do aa <- get bh
 376                       return (Avail aa)
 377               _ -> do ab <- get bh
 378                       ac <- get bh
 379                       return (AvailTC ab ac)
 380
 381 instance Binary Usage where
 382     put_ bh usg = do
 383         put_ bh (usg_name     usg)
 384         put_ bh (usg_mod      usg)
 385         put_ bh (usg_exports  usg)
 386         put_ bh (usg_entities usg)
 387         put_ bh (usg_rules    usg)
 388
 389     get bh = do
 390         nm    <- get bh
 391         mod   <- get bh
 392         exps  <- get bh
 393         ents  <- get bh
 394         rules <- get bh
 395         return (Usage { usg_name = nm, usg_mod = mod,
 396                         usg_exports = exps, usg_entities = ents,
 397                         usg_rules = rules })
 398
 399 instance Binary a => Binary (Deprecs a) where
 400     put_ bh NoDeprecs     = putByte bh 0
 401     put_ bh (DeprecAll t) = do
 402             putByte bh 1
 403             put_ bh t
 404     put_ bh (DeprecSome ts) = do
 405             putByte bh 2
 406             put_ bh ts
 407
 408     get bh = do
 409             h <- getByte bh
 410             case h of
 411               0 -> return NoDeprecs
 412               1 -> do aa <- get bh
 413                       return (DeprecAll aa)
 414               _ -> do aa <- get bh
 415                       return (DeprecSome aa)
 416
 417 -------------------------------------------------------------------------
 418 --              Types from: BasicTypes
 419 -------------------------------------------------------------------------
 420
 421 instance Binary Activation where
 422     put_ bh NeverActive = do
 423             putByte bh 0
 424     put_ bh AlwaysActive = do
 425             putByte bh 1
 426     put_ bh (ActiveBefore aa) = do
 427             putByte bh 2
 428             put_ bh aa
 429     put_ bh (ActiveAfter ab) = do
 430             putByte bh 3
 431             put_ bh ab
 432     get bh = do
 433             h <- getByte bh
 434             case h of
 435               0 -> do return NeverActive
 436               1 -> do return AlwaysActive
 437               2 -> do aa <- get bh
 438                       return (ActiveBefore aa)
 439               _ -> do ab <- get bh
 440                       return (ActiveAfter ab)
 441
 442 instance Binary StrictnessMark where
 443     put_ bh MarkedStrict = do
 444             putByte bh 0
 445     put_ bh MarkedUnboxed = do
 446             putByte bh 1
 447     put_ bh NotMarkedStrict = do
 448             putByte bh 2
 449     get bh = do
 450             h <- getByte bh
 451             case h of
 452               0 -> do return MarkedStrict
 453               1 -> do return MarkedUnboxed
 454               _ -> do return NotMarkedStrict
 455
 456 instance Binary Boxity where
 457     put_ bh Boxed = do
 458             putByte bh 0
 459     put_ bh Unboxed = do
 460             putByte bh 1
 461     get bh = do
 462             h <- getByte bh
 463             case h of
 464               0 -> do return Boxed
 465               _ -> do return Unboxed
 466
 467 instance Binary TupCon where
 468     put_ bh (TupCon ab ac) = do
 469             put_ bh ab
 470             put_ bh ac
 471     get bh = do
 472           ab <- get bh
 473           ac <- get bh
 474           return (TupCon ab ac)
 475
 476 instance Binary RecFlag where
 477     put_ bh Recursive = do
 478             putByte bh 0
 479     put_ bh NonRecursive = do
 480             putByte bh 1
 481     get bh = do
 482             h <- getByte bh
 483             case h of
 484               0 -> do return Recursive
 485               _ -> do return NonRecursive
 486
 487 instance Binary DefMeth where
 488     put_ bh NoDefMeth  = putByte bh 0
 489     put_ bh DefMeth    = putByte bh 1
 490     put_ bh GenDefMeth = putByte bh 2
 491     get bh = do
 492             h <- getByte bh
 493             case h of
 494               0 -> return NoDefMeth
 495               1 -> return DefMeth
 496               _ -> return GenDefMeth
 497
 498 instance Binary FixityDirection where
 499     put_ bh InfixL = do
 500             putByte bh 0
 501     put_ bh InfixR = do
 502             putByte bh 1
 503     put_ bh InfixN = do
 504             putByte bh 2
 505     get bh = do
 506             h <- getByte bh
 507             case h of
 508               0 -> do return InfixL
 509               1 -> do return InfixR
 510               _ -> do return InfixN
 511
 512 instance Binary Fixity where
 513     put_ bh (Fixity aa ab) = do
 514             put_ bh aa
 515             put_ bh ab
 516     get bh = do
 517           aa <- get bh
 518           ab <- get bh
 519           return (Fixity aa ab)
 520
 521 instance (Binary name) => Binary (IPName name) where
 522     put_ bh (IPName aa) = put_ bh aa
 523     get bh = do aa <- get bh
 524                 return (IPName aa)
 525
 526 -------------------------------------------------------------------------
 527 --              Types from: Demand
 528 -------------------------------------------------------------------------
 529
 530 instance Binary DmdType where
 531         -- Ignore DmdEnv when spitting out the DmdType
 532   put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
 533   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 534
 535 instance Binary Demand where
 536     put_ bh Top = do
 537             putByte bh 0
 538     put_ bh Abs = do
 539             putByte bh 1
 540     put_ bh (Call aa) = do
 541             putByte bh 2
 542             put_ bh aa
 543     put_ bh (Eval ab) = do
 544             putByte bh 3
 545             put_ bh ab
 546     put_ bh (Defer ac) = do
 547             putByte bh 4
 548             put_ bh ac
 549     put_ bh (Box ad) = do
 550             putByte bh 5
 551             put_ bh ad
 552     put_ bh Bot = do
 553             putByte bh 6
 554     get bh = do
 555             h <- getByte bh
 556             case h of
 557               0 -> do return Top
 558               1 -> do return Abs
 559               2 -> do aa <- get bh
 560                       return (Call aa)
 561               3 -> do ab <- get bh
 562                       return (Eval ab)
 563               4 -> do ac <- get bh
 564                       return (Defer ac)
 565               5 -> do ad <- get bh
 566                       return (Box ad)
 567               _ -> do return Bot
 568
 569 instance Binary Demands where
 570     put_ bh (Poly aa) = do
 571             putByte bh 0
 572             put_ bh aa
 573     put_ bh (Prod ab) = do
 574             putByte bh 1
 575             put_ bh ab
 576     get bh = do
 577             h <- getByte bh
 578             case h of
 579               0 -> do aa <- get bh
 580                       return (Poly aa)
 581               _ -> do ab <- get bh
 582                       return (Prod ab)
 583
 584 instance Binary DmdResult where
 585     put_ bh TopRes = do
 586             putByte bh 0
 587     put_ bh RetCPR = do
 588             putByte bh 1
 589     put_ bh BotRes = do
 590             putByte bh 2
 591     get bh = do
 592             h <- getByte bh
 593             case h of
 594               0 -> do return TopRes
 595               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 596                                         -- The wrapper was generated for CPR in
 597                                         -- the imported module!
 598               _ -> do return BotRes
 599
 600 instance Binary StrictSig where
 601     put_ bh (StrictSig aa) = do
 602             put_ bh aa
 603     get bh = do
 604           aa <- get bh
 605           return (StrictSig aa)
 606
 607
 608 -------------------------------------------------------------------------
 609 --              Types from: CostCentre
 610 -------------------------------------------------------------------------
 611
 612 instance Binary IsCafCC where
 613     put_ bh CafCC = do
 614             putByte bh 0
 615     put_ bh NotCafCC = do
 616             putByte bh 1
 617     get bh = do
 618             h <- getByte bh
 619             case h of
 620               0 -> do return CafCC
 621               _ -> do return NotCafCC
 622
 623 instance Binary IsDupdCC where
 624     put_ bh OriginalCC = do
 625             putByte bh 0
 626     put_ bh DupdCC = do
 627             putByte bh 1
 628     get bh = do
 629             h <- getByte bh
 630             case h of
 631               0 -> do return OriginalCC
 632               _ -> do return DupdCC
 633
 634 instance Binary CostCentre where
 635     put_ bh NoCostCentre = do
 636             putByte bh 0
 637     put_ bh (NormalCC aa ab ac ad) = do
 638             putByte bh 1
 639             put_ bh aa
 640             put_ bh ab
 641             put_ bh ac
 642             put_ bh ad
 643     put_ bh (AllCafsCC ae) = do
 644             putByte bh 2
 645             put_ bh ae
 646     get bh = do
 647             h <- getByte bh
 648             case h of
 649               0 -> do return NoCostCentre
 650               1 -> do aa <- get bh
 651                       ab <- get bh
 652                       ac <- get bh
 653                       ad <- get bh
 654                       return (NormalCC aa ab ac ad)
 655               _ -> do ae <- get bh
 656                       return (AllCafsCC ae)
 657
 658 -------------------------------------------------------------------------
 659 --              IfaceTypes and friends
 660 -------------------------------------------------------------------------
 661
 662 instance Binary IfaceBndr where
 663     put_ bh (IfaceIdBndr aa) = do
 664             putByte bh 0
 665             put_ bh aa
 666     put_ bh (IfaceTvBndr ab) = do
 667             putByte bh 1
 668             put_ bh ab
 669     get bh = do
 670             h <- getByte bh
 671             case h of
 672               0 -> do aa <- get bh
 673                       return (IfaceIdBndr aa)
 674               _ -> do ab <- get bh
 675                       return (IfaceTvBndr ab)
 676
 677 instance Binary IfaceType where
 678     put_ bh (IfaceForAllTy aa ab) = do
 679             putByte bh 0
 680             put_ bh aa
 681             put_ bh ab
 682     put_ bh (IfaceTyVar ad) = do
 683             putByte bh 1
 684             put_ bh ad
 685     put_ bh (IfaceAppTy ae af) = do
 686             putByte bh 2
 687             put_ bh ae
 688             put_ bh af
 689     put_ bh (IfaceFunTy ag ah) = do
 690             putByte bh 3
 691             put_ bh ag
 692             put_ bh ah
 693     put_ bh (IfacePredTy aq) = do
 694             putByte bh 5
 695             put_ bh aq
 696
 697         -- Simple compression for common cases of TyConApp
 698     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 699     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 700     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 701     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 702         -- Unit tuple and pairs
 703     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 704     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 705         -- Kind cases
 706     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 707     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 708     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 709     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 710     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 711
 712         -- Generic cases
 713
 714     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 715     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 716
 717     get bh = do
 718             h <- getByte bh
 719             case h of
 720               0 -> do aa <- get bh
 721                       ab <- get bh
 722                       return (IfaceForAllTy aa ab)
 723               1 -> do ad <- get bh
 724                       return (IfaceTyVar ad)
 725               2 -> do ae <- get bh
 726                       af <- get bh
 727                       return (IfaceAppTy ae af)
 728               3 -> do ag <- get bh
 729                       ah <- get bh
 730                       return (IfaceFunTy ag ah)
 731               5 -> do ap <- get bh
 732                       return (IfacePredTy ap)
 733
 734                 -- Now the special cases for TyConApp
 735               6 -> return (IfaceTyConApp IfaceIntTc [])
 736               7 -> return (IfaceTyConApp IfaceCharTc [])
 737               8 -> return (IfaceTyConApp IfaceBoolTc [])
 738               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 739               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 740               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 741               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 742               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 743               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 744               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 745               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 746
 747               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 748               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 749
 750 instance Binary IfaceTyCon where
 751         -- Int,Char,Bool can't show up here because they can't not be saturated
 752
 753    put_ bh IfaceIntTc         = putByte bh 1
 754    put_ bh IfaceBoolTc        = putByte bh 2
 755    put_ bh IfaceCharTc        = putByte bh 3
 756    put_ bh IfaceListTc        = putByte bh 4
 757    put_ bh IfacePArrTc        = putByte bh 5
 758    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 759    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 760    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 761    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 762    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 763    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 764    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 765
 766    get bh = do
 767         h <- getByte bh
 768         case h of
 769           1 -> return IfaceIntTc
 770           2 -> return IfaceBoolTc
 771           3 -> return IfaceCharTc
 772           4 -> return IfaceListTc
 773           5 -> return IfacePArrTc
 774           6 -> return IfaceLiftedTypeKindTc
 775           7 -> return IfaceOpenTypeKindTc
 776           8 -> return IfaceUnliftedTypeKindTc
 777           9 -> return IfaceUbxTupleKindTc
 778           10 -> return IfaceArgTypeKindTc
 779           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 780           _ -> do { ext <- get bh; return (IfaceTc ext) }
 781
 782 instance Binary IfacePredType where
 783     put_ bh (IfaceClassP aa ab) = do
 784             putByte bh 0
 785             put_ bh aa
 786             put_ bh ab
 787     put_ bh (IfaceIParam ac ad) = do
 788             putByte bh 1
 789             put_ bh ac
 790             put_ bh ad
 791     put_ bh (IfaceEqPred ac ad) = do
 792             putByte bh 2
 793             put_ bh ac
 794             put_ bh ad
 795     get bh = do
 796             h <- getByte bh
 797             case h of
 798               0 -> do aa <- get bh
 799                       ab <- get bh
 800                       return (IfaceClassP aa ab)
 801               1 -> do ac <- get bh
 802                       ad <- get bh
 803                       return (IfaceIParam ac ad)
 804               2 -> do ac <- get bh
 805                       ad <- get bh
 806                       return (IfaceEqPred ac ad)
 807
 808 -------------------------------------------------------------------------
 809 --              IfaceExpr and friends
 810 -------------------------------------------------------------------------
 811
 812 instance Binary IfaceExpr where
 813     put_ bh (IfaceLcl aa) = do
 814             putByte bh 0
 815             put_ bh aa
 816     put_ bh (IfaceType ab) = do
 817             putByte bh 1
 818             put_ bh ab
 819     put_ bh (IfaceTuple ac ad) = do
 820             putByte bh 2
 821             put_ bh ac
 822             put_ bh ad
 823     put_ bh (IfaceLam ae af) = do
 824             putByte bh 3
 825             put_ bh ae
 826             put_ bh af
 827     put_ bh (IfaceApp ag ah) = do
 828             putByte bh 4
 829             put_ bh ag
 830             put_ bh ah
 831 -- gaw 2004
 832     put_ bh (IfaceCase ai aj al ak) = do
 833             putByte bh 5
 834             put_ bh ai
 835             put_ bh aj
 836 -- gaw 2004
 837             put_ bh al
 838             put_ bh ak
 839     put_ bh (IfaceLet al am) = do
 840             putByte bh 6
 841             put_ bh al
 842             put_ bh am
 843     put_ bh (IfaceNote an ao) = do
 844             putByte bh 7
 845             put_ bh an
 846             put_ bh ao
 847     put_ bh (IfaceLit ap) = do
 848             putByte bh 8
 849             put_ bh ap
 850     put_ bh (IfaceFCall as at) = do
 851             putByte bh 9
 852             put_ bh as
 853             put_ bh at
 854     put_ bh (IfaceExt aa) = do
 855             putByte bh 10
 856             put_ bh aa
 857     put_ bh (IfaceCast ie ico) = do
 858             putByte bh 11
 859             put_ bh ie
 860             put_ bh ico
 861     get bh = do
 862             h <- getByte bh
 863             case h of
 864               0 -> do aa <- get bh
 865                       return (IfaceLcl aa)
 866               1 -> do ab <- get bh
 867                       return (IfaceType ab)
 868               2 -> do ac <- get bh
 869                       ad <- get bh
 870                       return (IfaceTuple ac ad)
 871               3 -> do ae <- get bh
 872                       af <- get bh
 873                       return (IfaceLam ae af)
 874               4 -> do ag <- get bh
 875                       ah <- get bh
 876                       return (IfaceApp ag ah)
 877               5 -> do ai <- get bh
 878                       aj <- get bh
 879 -- gaw 2004
 880                       al <- get bh
 881                       ak <- get bh
 882 -- gaw 2004
 883                       return (IfaceCase ai aj al ak)
 884               6 -> do al <- get bh
 885                       am <- get bh
 886                       return (IfaceLet al am)
 887               7 -> do an <- get bh
 888                       ao <- get bh
 889                       return (IfaceNote an ao)
 890               8 -> do ap <- get bh
 891                       return (IfaceLit ap)
 892               9 -> do as <- get bh
 893                       at <- get bh
 894                       return (IfaceFCall as at)
 895               10 -> do aa <- get bh
 896                        return (IfaceExt aa)
 897               11 -> do ie <- get bh
 898                        ico <- get bh
 899                        return (IfaceCast ie ico)
 900
 901 instance Binary IfaceConAlt where
 902     put_ bh IfaceDefault = do
 903             putByte bh 0
 904     put_ bh (IfaceDataAlt aa) = do
 905             putByte bh 1
 906             put_ bh aa
 907     put_ bh (IfaceTupleAlt ab) = do
 908             putByte bh 2
 909             put_ bh ab
 910     put_ bh (IfaceLitAlt ac) = do
 911             putByte bh 3
 912             put_ bh ac
 913     get bh = do
 914             h <- getByte bh
 915             case h of
 916               0 -> do return IfaceDefault
 917               1 -> do aa <- get bh
 918                       return (IfaceDataAlt aa)
 919               2 -> do ab <- get bh
 920                       return (IfaceTupleAlt ab)
 921               _ -> do ac <- get bh
 922                       return (IfaceLitAlt ac)
 923
 924 instance Binary IfaceBinding where
 925     put_ bh (IfaceNonRec aa ab) = do
 926             putByte bh 0
 927             put_ bh aa
 928             put_ bh ab
 929     put_ bh (IfaceRec ac) = do
 930             putByte bh 1
 931             put_ bh ac
 932     get bh = do
 933             h <- getByte bh
 934             case h of
 935               0 -> do aa <- get bh
 936                       ab <- get bh
 937                       return (IfaceNonRec aa ab)
 938               _ -> do ac <- get bh
 939                       return (IfaceRec ac)
 940
 941 instance Binary IfaceIdInfo where
 942     put_ bh NoInfo = putByte bh 0
 943     put_ bh (HasInfo i) = do
 944             putByte bh 1
 945             lazyPut bh i                        -- NB lazyPut
 946
 947     get bh = do
 948             h <- getByte bh
 949             case h of
 950               0 -> return NoInfo
 951               _ -> do info <- lazyGet bh        -- NB lazyGet
 952                       return (HasInfo info)
 953
 954 instance Binary IfaceInfoItem where
 955     put_ bh (HsArity aa) = do
 956             putByte bh 0
 957             put_ bh aa
 958     put_ bh (HsStrictness ab) = do
 959             putByte bh 1
 960             put_ bh ab
 961     put_ bh (HsUnfold ad) = do
 962             putByte bh 2
 963             put_ bh ad
 964     put_ bh (HsInline ad) = do
 965             putByte bh 3
 966             put_ bh ad
 967     put_ bh HsNoCafRefs = do
 968             putByte bh 4
 969     put_ bh (HsWorker ae af) = do
 970             putByte bh 5
 971             put_ bh ae
 972             put_ bh af
 973     get bh = do
 974             h <- getByte bh
 975             case h of
 976               0 -> do aa <- get bh
 977                       return (HsArity aa)
 978               1 -> do ab <- get bh
 979                       return (HsStrictness ab)
 980               2 -> do ad <- get bh
 981                       return (HsUnfold ad)
 982               3 -> do ad <- get bh
 983                       return (HsInline ad)
 984               4 -> do return HsNoCafRefs
 985               _ -> do ae <- get bh
 986                       af <- get bh
 987                       return (HsWorker ae af)
 988
 989 instance Binary IfaceNote where
 990     put_ bh (IfaceSCC aa) = do
 991             putByte bh 0
 992             put_ bh aa
 993     put_ bh IfaceInlineMe = do
 994             putByte bh 3
 995     put_ bh (IfaceCoreNote s) = do
 996             putByte bh 4
 997             put_ bh s
 998     get bh = do
 999             h <- getByte bh
1000             case h of
1001               0 -> do aa <- get bh
1002                       return (IfaceSCC aa)
1003               3 -> do return IfaceInlineMe
1004               4 -> do ac <- get bh
1005                       return (IfaceCoreNote ac)
1006
1007
1008 -------------------------------------------------------------------------
1009 --              IfaceDecl and friends
1010 -------------------------------------------------------------------------
1011
1012 -- A bit of magic going on here: there's no need to store the OccName
1013 -- for a decl on the disk, since we can infer the namespace from the
1014 -- context; however it is useful to have the OccName in the IfaceDecl
1015 -- to avoid re-building it in various places.  So we build the OccName
1016 -- when de-serialising.
1017
1018 instance Binary IfaceDecl where
1019     put_ bh (IfaceId name ty idinfo) = do
1020             putByte bh 0
1021             put_ bh (occNameFS name)
1022             put_ bh ty
1023             put_ bh idinfo
1024     put_ bh (IfaceForeign ae af) =
1025         error "Binary.put_(IfaceDecl): IfaceForeign"
1026     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1027             putByte bh 2
1028             put_ bh (occNameFS a1)
1029             put_ bh a2
1030             put_ bh a3
1031             put_ bh a4
1032             put_ bh a5
1033             put_ bh a6
1034             put_ bh a7
1035             put_ bh a8
1036     put_ bh (IfaceSyn aq ar as at) = do
1037             putByte bh 3
1038             put_ bh (occNameFS aq)
1039             put_ bh ar
1040             put_ bh as
1041             put_ bh at
1042     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1043             putByte bh 4
1044             put_ bh a1
1045             put_ bh (occNameFS a2)
1046             put_ bh a3
1047             put_ bh a4
1048             put_ bh a5
1049             put_ bh a6
1050             put_ bh a7
1051     get bh = do
1052             h <- getByte bh
1053             case h of
1054               0 -> do name   <- get bh
1055                       ty     <- get bh
1056                       idinfo <- get bh
1057                       occ <- return $! mkOccNameFS varName name
1058                       return (IfaceId occ ty idinfo)
1059               1 -> error "Binary.get(TyClDecl): ForeignType"
1060               2 -> do
1061                     a1 <- get bh
1062                     a2 <- get bh
1063                     a3 <- get bh
1064                     a4 <- get bh
1065                     a5 <- get bh
1066                     a6 <- get bh
1067                     a7 <- get bh
1068                     a8 <- get bh
1069                     occ <- return $! mkOccNameFS tcName a1
1070                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1071               3 -> do
1072                     aq <- get bh
1073                     ar <- get bh
1074                     as <- get bh
1075                     at <- get bh
1076                     occ <- return $! mkOccNameFS tcName aq
1077                     return (IfaceSyn occ ar as at)
1078               _ -> do
1079                     a1 <- get bh
1080                     a2 <- get bh
1081                     a3 <- get bh
1082                     a4 <- get bh
1083                     a5 <- get bh
1084                     a6 <- get bh
1085                     a7 <- get bh
1086                     occ <- return $! mkOccNameFS clsName a2
1087                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1088
1089 instance Binary IfaceInst where
1090     put_ bh (IfaceInst cls tys dfun flag orph) = do
1091             put_ bh cls
1092             put_ bh tys
1093             put_ bh dfun
1094             put_ bh flag
1095             put_ bh orph
1096     get bh = do cls  <- get bh
1097                 tys  <- get bh
1098                 dfun <- get bh
1099                 flag <- get bh
1100                 orph <- get bh
1101                 return (IfaceInst cls tys dfun flag orph)
1102
1103 instance Binary IfaceFamInst where
1104     put_ bh (IfaceFamInst fam tys tycon) = do
1105             put_ bh fam
1106             put_ bh tys
1107             put_ bh tycon
1108     get bh = do fam   <- get bh
1109                 tys   <- get bh
1110                 tycon <- get bh
1111                 return (IfaceFamInst fam tys tycon)
1112
1113 instance Binary OverlapFlag where
1114     put_ bh NoOverlap  = putByte bh 0
1115     put_ bh OverlapOk  = putByte bh 1
1116     put_ bh Incoherent = putByte bh 2
1117     get bh = do h <- getByte bh
1118                 case h of
1119                   0 -> return NoOverlap
1120                   1 -> return OverlapOk
1121                   2 -> return Incoherent
1122
1123 instance Binary IfaceConDecls where
1124     put_ bh IfAbstractTyCon = putByte bh 0
1125     put_ bh IfOpenDataTyCon = putByte bh 1
1126     put_ bh IfOpenNewTyCon = putByte bh 2
1127     put_ bh (IfDataTyCon cs) = do { putByte bh 3
1128                                   ; put_ bh cs }
1129     put_ bh (IfNewTyCon c)  = do { putByte bh 4
1130                                   ; put_ bh c }
1131     get bh = do
1132             h <- getByte bh
1133             case h of
1134               0 -> return IfAbstractTyCon
1135               1 -> return IfOpenDataTyCon
1136               2 -> return IfOpenNewTyCon
1137               3 -> do cs <- get bh
1138                       return (IfDataTyCon cs)
1139               _ -> do aa <- get bh
1140                       return (IfNewTyCon aa)
1141
1142 instance Binary IfaceConDecl where
1143     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1144             put_ bh a1
1145             put_ bh a2
1146             put_ bh a3
1147             put_ bh a4
1148             put_ bh a5
1149             put_ bh a6
1150             put_ bh a7
1151             put_ bh a8
1152             put_ bh a9
1153     get bh = do a1 <- get bh
1154                 a2 <- get bh
1155                 a3 <- get bh
1156                 a4 <- get bh
1157                 a5 <- get bh
1158                 a6 <- get bh
1159                 a7 <- get bh
1160                 a8 <- get bh
1161                 a9 <- get bh
1162                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1163
1164 instance Binary IfaceClassOp where
1165    put_ bh (IfaceClassOp n def ty) = do
1166         put_ bh (occNameFS n)
1167         put_ bh def
1168         put_ bh ty
1169    get bh = do
1170         n <- get bh
1171         def <- get bh
1172         ty <- get bh
1173         occ <- return $! mkOccNameFS varName n
1174         return (IfaceClassOp occ def ty)
1175
1176 instance Binary IfaceRule where
1177     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1178             put_ bh a1
1179             put_ bh a2
1180             put_ bh a3
1181             put_ bh a4
1182             put_ bh a5
1183             put_ bh a6
1184             put_ bh a7
1185     get bh = do
1186             a1 <- get bh
1187             a2 <- get bh
1188             a3 <- get bh
1189             a4 <- get bh
1190             a5 <- get bh
1191             a6 <- get bh
1192             a7 <- get bh
1193             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1194
1195