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