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