compiler/iface/BinIface.hs

   1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
   3 --
   4 --  (c) The University of Glasgow 2002
   5 --
   6 -- Binary interface file support.
   7
   8 module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
   9
  10 #include "HsVersions.h"
  11
  12 import HscTypes
  13 import BasicTypes
  14 import NewDemand
  15 import IfaceSyn
  16 import VarEnv
  17 import InstEnv          ( OverlapFlag(..) )
  18 import Class            ( DefMeth(..) )
  19 import CostCentre
  20 import StaticFlags      ( opt_HiVersion, v_Build_tag )
  21 import Panic
  22 import Binary
  23 import Util
  24 import Config           ( cGhcUnregisterised )
  25
  26 import DATA_IOREF
  27 import EXCEPTION        ( throwDyn )
  28 import Monad            ( when )
  29 import Outputable
  30
  31 #include "HsVersions.h"
  32
  33 -- ---------------------------------------------------------------------------
  34 writeBinIface :: FilePath -> ModIface -> IO ()
  35 writeBinIface hi_path mod_iface
  36   = putBinFileWithDict hi_path mod_iface
  37
  38 readBinIface :: FilePath -> IO ModIface
  39 readBinIface hi_path = getBinFileWithDict hi_path
  40
  41
  42 -- %*********************************************************
  43 -- %*                                                       *
  44 --              All the Binary instances
  45 -- %*                                                       *
  46 -- %*********************************************************
  47
  48 -- BasicTypes
  49 {-! for IPName derive: Binary !-}
  50 {-! for Fixity derive: Binary !-}
  51 {-! for FixityDirection derive: Binary !-}
  52 {-! for Boxity derive: Binary !-}
  53 {-! for StrictnessMark derive: Binary !-}
  54 {-! for Activation derive: Binary !-}
  55
  56 -- NewDemand
  57 {-! for Demand derive: Binary !-}
  58 {-! for Demands derive: Binary !-}
  59 {-! for DmdResult derive: Binary !-}
  60 {-! for StrictSig derive: Binary !-}
  61
  62 -- Class
  63 {-! for DefMeth derive: Binary !-}
  64
  65 -- HsTypes
  66 {-! for HsPred derive: Binary !-}
  67 {-! for HsType derive: Binary !-}
  68 {-! for TupCon derive: Binary !-}
  69 {-! for HsTyVarBndr derive: Binary !-}
  70
  71 -- HsCore
  72 {-! for UfExpr derive: Binary !-}
  73 {-! for UfConAlt derive: Binary !-}
  74 {-! for UfBinding derive: Binary !-}
  75 {-! for UfBinder derive: Binary !-}
  76 {-! for HsIdInfo derive: Binary !-}
  77 {-! for UfNote derive: Binary !-}
  78
  79 -- HsDecls
  80 {-! for ConDetails derive: Binary !-}
  81 {-! for BangType derive: Binary !-}
  82
  83 -- CostCentre
  84 {-! for IsCafCC derive: Binary !-}
  85 {-! for IsDupdCC derive: Binary !-}
  86 {-! for CostCentre derive: Binary !-}
  87
  88
  89
  90 -- ---------------------------------------------------------------------------
  91 -- Reading a binary interface into ParsedIface
  92
  93 instance Binary ModIface where
  94    put_ bh (ModIface {
  95                  mi_module    = mod,
  96                  mi_boot      = is_boot,
  97                  mi_mod_vers  = mod_vers,
  98                  mi_orphan    = orphan,
  99                  mi_deps      = deps,
 100                  mi_usages    = usages,
 101                  mi_exports   = exports,
 102                  mi_exp_vers  = exp_vers,
 103                  mi_fixities  = fixities,
 104                  mi_deprecs   = deprecs,
 105                  mi_decls     = decls,
 106                  mi_insts     = insts,
 107                  mi_fam_insts = fam_insts,
 108                  mi_rules     = rules,
 109                  mi_rule_vers = rule_vers }) = do
 110         put_ bh (show opt_HiVersion)
 111         way_descr <- getWayDescr
 112         put  bh way_descr
 113         put_ bh mod
 114         put_ bh is_boot
 115         put_ bh mod_vers
 116         put_ bh orphan
 117         lazyPut bh deps
 118         lazyPut bh usages
 119         put_ bh exports
 120         put_ bh exp_vers
 121         put_ bh fixities
 122         lazyPut bh deprecs
 123         put_ bh decls
 124         put_ bh insts
 125         put_ bh fam_insts
 126         lazyPut bh rules
 127         put_ bh rule_vers
 128
 129    get bh = do
 130         check_ver  <- get bh
 131         let our_ver = show opt_HiVersion
 132         when (check_ver /= our_ver) $
 133            -- use userError because this will be caught by readIface
 134            -- which will emit an error msg containing the iface module name.
 135            throwDyn (ProgramError (
 136                 "mismatched interface file versions: expected "
 137                 ++ our_ver ++ ", found " ++ check_ver))
 138
 139         check_way <- get bh
 140         ignore_way <- readIORef v_IgnoreHiWay
 141         way_descr <- getWayDescr
 142         when (not ignore_way && check_way /= way_descr) $
 143            -- use userError because this will be caught by readIface
 144            -- which will emit an error msg containing the iface module name.
 145            throwDyn (ProgramError (
 146                 "mismatched interface file ways: expected "
 147                 ++ way_descr ++ ", found " ++ check_way))
 148
 149         mod_name  <- get bh
 150         is_boot   <- get bh
 151         mod_vers  <- get bh
 152         orphan    <- get bh
 153         deps      <- lazyGet bh
 154         usages    <- {-# SCC "bin_usages" #-} lazyGet bh
 155         exports   <- {-# SCC "bin_exports" #-} get bh
 156         exp_vers  <- get bh
 157         fixities  <- {-# SCC "bin_fixities" #-} get bh
 158         deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
 159         decls     <- {-# SCC "bin_tycldecls" #-} get bh
 160         insts     <- {-# SCC "bin_insts" #-} get bh
 161         fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
 162         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 163         rule_vers <- get bh
 164         return (ModIface {
 165                  mi_module    = mod_name,
 166                  mi_boot      = is_boot,
 167                  mi_mod_vers  = mod_vers,
 168                  mi_orphan    = orphan,
 169                  mi_deps      = deps,
 170                  mi_usages    = usages,
 171                  mi_exports   = exports,
 172                  mi_exp_vers  = exp_vers,
 173                  mi_fixities  = fixities,
 174                  mi_deprecs   = deprecs,
 175                  mi_decls     = decls,
 176                  mi_globals   = Nothing,
 177                  mi_insts     = insts,
 178                  mi_fam_insts = fam_insts,
 179                  mi_rules     = rules,
 180                  mi_rule_vers = rule_vers,
 181                         -- And build the cached values
 182                  mi_dep_fn    = mkIfaceDepCache deprecs,
 183                  mi_fix_fn    = mkIfaceFixCache fixities,
 184                  mi_ver_fn    = mkIfaceVerCache decls })
 185
 186 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
 187
 188 getWayDescr :: IO String
 189 getWayDescr = do
 190   tag <- readIORef v_Build_tag
 191   if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
 192         -- if this is an unregisterised build, make sure our interfaces
 193         -- can't be used by a registerised build.
 194
 195 -------------------------------------------------------------------------
 196 --              Types from: HscTypes
 197 -------------------------------------------------------------------------
 198
 199 instance Binary Dependencies where
 200     put_ bh deps = do put_ bh (dep_mods deps)
 201                       put_ bh (dep_pkgs deps)
 202                       put_ bh (dep_orphs deps)
 203
 204     get bh = do ms <- get bh
 205                 ps <- get bh
 206                 os <- get bh
 207                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
 208
 209 instance (Binary name) => Binary (GenAvailInfo name) where
 210     put_ bh (Avail aa) = do
 211             putByte bh 0
 212             put_ bh aa
 213     put_ bh (AvailTC ab ac) = do
 214             putByte bh 1
 215             put_ bh ab
 216             put_ bh ac
 217     get bh = do
 218             h <- getByte bh
 219             case h of
 220               0 -> do aa <- get bh
 221                       return (Avail aa)
 222               _ -> do ab <- get bh
 223                       ac <- get bh
 224                       return (AvailTC ab ac)
 225
 226 instance Binary Usage where
 227     put_ bh usg = do
 228         put_ bh (usg_name     usg)
 229         put_ bh (usg_mod      usg)
 230         put_ bh (usg_exports  usg)
 231         put_ bh (usg_entities usg)
 232         put_ bh (usg_rules    usg)
 233
 234     get bh = do
 235         nm    <- get bh
 236         mod   <- get bh
 237         exps  <- get bh
 238         ents  <- get bh
 239         rules <- get bh
 240         return (Usage { usg_name = nm, usg_mod = mod,
 241                         usg_exports = exps, usg_entities = ents,
 242                         usg_rules = rules })
 243
 244 instance Binary a => Binary (Deprecs a) where
 245     put_ bh NoDeprecs     = putByte bh 0
 246     put_ bh (DeprecAll t) = do
 247             putByte bh 1
 248             put_ bh t
 249     put_ bh (DeprecSome ts) = do
 250             putByte bh 2
 251             put_ bh ts
 252
 253     get bh = do
 254             h <- getByte bh
 255             case h of
 256               0 -> return NoDeprecs
 257               1 -> do aa <- get bh
 258                       return (DeprecAll aa)
 259               _ -> do aa <- get bh
 260                       return (DeprecSome aa)
 261
 262 -------------------------------------------------------------------------
 263 --              Types from: BasicTypes
 264 -------------------------------------------------------------------------
 265
 266 instance Binary Activation where
 267     put_ bh NeverActive = do
 268             putByte bh 0
 269     put_ bh AlwaysActive = do
 270             putByte bh 1
 271     put_ bh (ActiveBefore aa) = do
 272             putByte bh 2
 273             put_ bh aa
 274     put_ bh (ActiveAfter ab) = do
 275             putByte bh 3
 276             put_ bh ab
 277     get bh = do
 278             h <- getByte bh
 279             case h of
 280               0 -> do return NeverActive
 281               1 -> do return AlwaysActive
 282               2 -> do aa <- get bh
 283                       return (ActiveBefore aa)
 284               _ -> do ab <- get bh
 285                       return (ActiveAfter ab)
 286
 287 instance Binary StrictnessMark where
 288     put_ bh MarkedStrict = do
 289             putByte bh 0
 290     put_ bh MarkedUnboxed = do
 291             putByte bh 1
 292     put_ bh NotMarkedStrict = do
 293             putByte bh 2
 294     get bh = do
 295             h <- getByte bh
 296             case h of
 297               0 -> do return MarkedStrict
 298               1 -> do return MarkedUnboxed
 299               _ -> do return NotMarkedStrict
 300
 301 instance Binary Boxity where
 302     put_ bh Boxed = do
 303             putByte bh 0
 304     put_ bh Unboxed = do
 305             putByte bh 1
 306     get bh = do
 307             h <- getByte bh
 308             case h of
 309               0 -> do return Boxed
 310               _ -> do return Unboxed
 311
 312 instance Binary TupCon where
 313     put_ bh (TupCon ab ac) = do
 314             put_ bh ab
 315             put_ bh ac
 316     get bh = do
 317           ab <- get bh
 318           ac <- get bh
 319           return (TupCon ab ac)
 320
 321 instance Binary RecFlag where
 322     put_ bh Recursive = do
 323             putByte bh 0
 324     put_ bh NonRecursive = do
 325             putByte bh 1
 326     get bh = do
 327             h <- getByte bh
 328             case h of
 329               0 -> do return Recursive
 330               _ -> do return NonRecursive
 331
 332 instance Binary DefMeth where
 333     put_ bh NoDefMeth  = putByte bh 0
 334     put_ bh DefMeth    = putByte bh 1
 335     put_ bh GenDefMeth = putByte bh 2
 336     get bh = do
 337             h <- getByte bh
 338             case h of
 339               0 -> return NoDefMeth
 340               1 -> return DefMeth
 341               _ -> return GenDefMeth
 342
 343 instance Binary FixityDirection where
 344     put_ bh InfixL = do
 345             putByte bh 0
 346     put_ bh InfixR = do
 347             putByte bh 1
 348     put_ bh InfixN = do
 349             putByte bh 2
 350     get bh = do
 351             h <- getByte bh
 352             case h of
 353               0 -> do return InfixL
 354               1 -> do return InfixR
 355               _ -> do return InfixN
 356
 357 instance Binary Fixity where
 358     put_ bh (Fixity aa ab) = do
 359             put_ bh aa
 360             put_ bh ab
 361     get bh = do
 362           aa <- get bh
 363           ab <- get bh
 364           return (Fixity aa ab)
 365
 366 instance (Binary name) => Binary (IPName name) where
 367     put_ bh (IPName aa) = put_ bh aa
 368     get bh = do aa <- get bh
 369                 return (IPName aa)
 370
 371 -------------------------------------------------------------------------
 372 --              Types from: Demand
 373 -------------------------------------------------------------------------
 374
 375 instance Binary DmdType where
 376         -- Ignore DmdEnv when spitting out the DmdType
 377   put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
 378   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 379
 380 instance Binary Demand where
 381     put_ bh Top = do
 382             putByte bh 0
 383     put_ bh Abs = do
 384             putByte bh 1
 385     put_ bh (Call aa) = do
 386             putByte bh 2
 387             put_ bh aa
 388     put_ bh (Eval ab) = do
 389             putByte bh 3
 390             put_ bh ab
 391     put_ bh (Defer ac) = do
 392             putByte bh 4
 393             put_ bh ac
 394     put_ bh (Box ad) = do
 395             putByte bh 5
 396             put_ bh ad
 397     put_ bh Bot = do
 398             putByte bh 6
 399     get bh = do
 400             h <- getByte bh
 401             case h of
 402               0 -> do return Top
 403               1 -> do return Abs
 404               2 -> do aa <- get bh
 405                       return (Call aa)
 406               3 -> do ab <- get bh
 407                       return (Eval ab)
 408               4 -> do ac <- get bh
 409                       return (Defer ac)
 410               5 -> do ad <- get bh
 411                       return (Box ad)
 412               _ -> do return Bot
 413
 414 instance Binary Demands where
 415     put_ bh (Poly aa) = do
 416             putByte bh 0
 417             put_ bh aa
 418     put_ bh (Prod ab) = do
 419             putByte bh 1
 420             put_ bh ab
 421     get bh = do
 422             h <- getByte bh
 423             case h of
 424               0 -> do aa <- get bh
 425                       return (Poly aa)
 426               _ -> do ab <- get bh
 427                       return (Prod ab)
 428
 429 instance Binary DmdResult where
 430     put_ bh TopRes = do
 431             putByte bh 0
 432     put_ bh RetCPR = do
 433             putByte bh 1
 434     put_ bh BotRes = do
 435             putByte bh 2
 436     get bh = do
 437             h <- getByte bh
 438             case h of
 439               0 -> do return TopRes
 440               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 441                                         -- The wrapper was generated for CPR in
 442                                         -- the imported module!
 443               _ -> do return BotRes
 444
 445 instance Binary StrictSig where
 446     put_ bh (StrictSig aa) = do
 447             put_ bh aa
 448     get bh = do
 449           aa <- get bh
 450           return (StrictSig aa)
 451
 452
 453 -------------------------------------------------------------------------
 454 --              Types from: CostCentre
 455 -------------------------------------------------------------------------
 456
 457 instance Binary IsCafCC where
 458     put_ bh CafCC = do
 459             putByte bh 0
 460     put_ bh NotCafCC = do
 461             putByte bh 1
 462     get bh = do
 463             h <- getByte bh
 464             case h of
 465               0 -> do return CafCC
 466               _ -> do return NotCafCC
 467
 468 instance Binary IsDupdCC where
 469     put_ bh OriginalCC = do
 470             putByte bh 0
 471     put_ bh DupdCC = do
 472             putByte bh 1
 473     get bh = do
 474             h <- getByte bh
 475             case h of
 476               0 -> do return OriginalCC
 477               _ -> do return DupdCC
 478
 479 instance Binary CostCentre where
 480     put_ bh NoCostCentre = do
 481             putByte bh 0
 482     put_ bh (NormalCC aa ab ac ad) = do
 483             putByte bh 1
 484             put_ bh aa
 485             put_ bh ab
 486             put_ bh ac
 487             put_ bh ad
 488     put_ bh (AllCafsCC ae) = do
 489             putByte bh 2
 490             put_ bh ae
 491     get bh = do
 492             h <- getByte bh
 493             case h of
 494               0 -> do return NoCostCentre
 495               1 -> do aa <- get bh
 496                       ab <- get bh
 497                       ac <- get bh
 498                       ad <- get bh
 499                       return (NormalCC aa ab ac ad)
 500               _ -> do ae <- get bh
 501                       return (AllCafsCC ae)
 502
 503 -------------------------------------------------------------------------
 504 --              IfaceTypes and friends
 505 -------------------------------------------------------------------------
 506
 507 instance Binary IfaceExtName where
 508     put_ bh (ExtPkg mod occ) = do
 509             putByte bh 0
 510             put_ bh mod
 511             put_ bh occ
 512     put_ bh (HomePkg mod occ vers) = do
 513             putByte bh 1
 514             put_ bh mod
 515             put_ bh occ
 516             put_ bh vers
 517     put_ bh (LocalTop occ) = do
 518             putByte bh 2
 519             put_ bh occ
 520     put_ bh (LocalTopSub occ _) = do    -- Write LocalTopSub just like LocalTop
 521             putByte bh 2
 522             put_ bh occ
 523
 524     get bh = do
 525             h <- getByte bh
 526             case h of
 527               0 -> do mod <- get bh
 528                       occ <- get bh
 529                       return (ExtPkg mod occ)
 530               1 -> do mod <- get bh
 531                       occ <- get bh
 532                       vers <- get bh
 533                       return (HomePkg mod occ vers)
 534               _ -> do occ <- get bh
 535                       return (LocalTop occ)
 536
 537 instance Binary IfaceBndr where
 538     put_ bh (IfaceIdBndr aa) = do
 539             putByte bh 0
 540             put_ bh aa
 541     put_ bh (IfaceTvBndr ab) = do
 542             putByte bh 1
 543             put_ bh ab
 544     get bh = do
 545             h <- getByte bh
 546             case h of
 547               0 -> do aa <- get bh
 548                       return (IfaceIdBndr aa)
 549               _ -> do ab <- get bh
 550                       return (IfaceTvBndr ab)
 551
 552 instance Binary IfaceType where
 553     put_ bh (IfaceForAllTy aa ab) = do
 554             putByte bh 0
 555             put_ bh aa
 556             put_ bh ab
 557     put_ bh (IfaceTyVar ad) = do
 558             putByte bh 1
 559             put_ bh ad
 560     put_ bh (IfaceAppTy ae af) = do
 561             putByte bh 2
 562             put_ bh ae
 563             put_ bh af
 564     put_ bh (IfaceFunTy ag ah) = do
 565             putByte bh 3
 566             put_ bh ag
 567             put_ bh ah
 568     put_ bh (IfacePredTy aq) = do
 569             putByte bh 5
 570             put_ bh aq
 571
 572         -- Simple compression for common cases of TyConApp
 573     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 574     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 575     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 576     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 577         -- Unit tuple and pairs
 578     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 579     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 580         -- Kind cases
 581     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 582     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 583     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 584     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 585     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 586
 587         -- Generic cases
 588
 589     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 590     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 591
 592     get bh = do
 593             h <- getByte bh
 594             case h of
 595               0 -> do aa <- get bh
 596                       ab <- get bh
 597                       return (IfaceForAllTy aa ab)
 598               1 -> do ad <- get bh
 599                       return (IfaceTyVar ad)
 600               2 -> do ae <- get bh
 601                       af <- get bh
 602                       return (IfaceAppTy ae af)
 603               3 -> do ag <- get bh
 604                       ah <- get bh
 605                       return (IfaceFunTy ag ah)
 606               5 -> do ap <- get bh
 607                       return (IfacePredTy ap)
 608
 609                 -- Now the special cases for TyConApp
 610               6 -> return (IfaceTyConApp IfaceIntTc [])
 611               7 -> return (IfaceTyConApp IfaceCharTc [])
 612               8 -> return (IfaceTyConApp IfaceBoolTc [])
 613               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 614               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 615               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 616               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 617               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 618               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 619               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 620               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 621
 622               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 623               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 624
 625 instance Binary IfaceTyCon where
 626         -- Int,Char,Bool can't show up here because they can't not be saturated
 627
 628    put_ bh IfaceIntTc         = putByte bh 1
 629    put_ bh IfaceBoolTc        = putByte bh 2
 630    put_ bh IfaceCharTc        = putByte bh 3
 631    put_ bh IfaceListTc        = putByte bh 4
 632    put_ bh IfacePArrTc        = putByte bh 5
 633    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 634    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 635    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 636    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 637    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 638    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 639    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 640
 641    get bh = do
 642         h <- getByte bh
 643         case h of
 644           1 -> return IfaceIntTc
 645           2 -> return IfaceBoolTc
 646           3 -> return IfaceCharTc
 647           4 -> return IfaceListTc
 648           5 -> return IfacePArrTc
 649           6 -> return IfaceLiftedTypeKindTc
 650           7 -> return IfaceOpenTypeKindTc
 651           8 -> return IfaceUnliftedTypeKindTc
 652           9 -> return IfaceUbxTupleKindTc
 653           10 -> return IfaceArgTypeKindTc
 654           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 655           _ -> do { ext <- get bh; return (IfaceTc ext) }
 656
 657 instance Binary IfacePredType where
 658     put_ bh (IfaceClassP aa ab) = do
 659             putByte bh 0
 660             put_ bh aa
 661             put_ bh ab
 662     put_ bh (IfaceIParam ac ad) = do
 663             putByte bh 1
 664             put_ bh ac
 665             put_ bh ad
 666     put_ bh (IfaceEqPred ac ad) = do
 667             putByte bh 2
 668             put_ bh ac
 669             put_ bh ad
 670     get bh = do
 671             h <- getByte bh
 672             case h of
 673               0 -> do aa <- get bh
 674                       ab <- get bh
 675                       return (IfaceClassP aa ab)
 676               1 -> do ac <- get bh
 677                       ad <- get bh
 678                       return (IfaceIParam ac ad)
 679               2 -> do ac <- get bh
 680                       ad <- get bh
 681                       return (IfaceEqPred ac ad)
 682
 683 -------------------------------------------------------------------------
 684 --              IfaceExpr and friends
 685 -------------------------------------------------------------------------
 686
 687 instance Binary IfaceExpr where
 688     put_ bh (IfaceLcl aa) = do
 689             putByte bh 0
 690             put_ bh aa
 691     put_ bh (IfaceType ab) = do
 692             putByte bh 1
 693             put_ bh ab
 694     put_ bh (IfaceTuple ac ad) = do
 695             putByte bh 2
 696             put_ bh ac
 697             put_ bh ad
 698     put_ bh (IfaceLam ae af) = do
 699             putByte bh 3
 700             put_ bh ae
 701             put_ bh af
 702     put_ bh (IfaceApp ag ah) = do
 703             putByte bh 4
 704             put_ bh ag
 705             put_ bh ah
 706 -- gaw 2004
 707     put_ bh (IfaceCase ai aj al ak) = do
 708             putByte bh 5
 709             put_ bh ai
 710             put_ bh aj
 711 -- gaw 2004
 712             put_ bh al
 713             put_ bh ak
 714     put_ bh (IfaceLet al am) = do
 715             putByte bh 6
 716             put_ bh al
 717             put_ bh am
 718     put_ bh (IfaceNote an ao) = do
 719             putByte bh 7
 720             put_ bh an
 721             put_ bh ao
 722     put_ bh (IfaceLit ap) = do
 723             putByte bh 8
 724             put_ bh ap
 725     put_ bh (IfaceFCall as at) = do
 726             putByte bh 9
 727             put_ bh as
 728             put_ bh at
 729     put_ bh (IfaceExt aa) = do
 730             putByte bh 10
 731             put_ bh aa
 732     put_ bh (IfaceCast ie ico) = do
 733             putByte bh 11
 734             put_ bh ie
 735             put_ bh ico
 736     get bh = do
 737             h <- getByte bh
 738             case h of
 739               0 -> do aa <- get bh
 740                       return (IfaceLcl aa)
 741               1 -> do ab <- get bh
 742                       return (IfaceType ab)
 743               2 -> do ac <- get bh
 744                       ad <- get bh
 745                       return (IfaceTuple ac ad)
 746               3 -> do ae <- get bh
 747                       af <- get bh
 748                       return (IfaceLam ae af)
 749               4 -> do ag <- get bh
 750                       ah <- get bh
 751                       return (IfaceApp ag ah)
 752               5 -> do ai <- get bh
 753                       aj <- get bh
 754 -- gaw 2004
 755                       al <- get bh
 756                       ak <- get bh
 757 -- gaw 2004
 758                       return (IfaceCase ai aj al ak)
 759               6 -> do al <- get bh
 760                       am <- get bh
 761                       return (IfaceLet al am)
 762               7 -> do an <- get bh
 763                       ao <- get bh
 764                       return (IfaceNote an ao)
 765               8 -> do ap <- get bh
 766                       return (IfaceLit ap)
 767               9 -> do as <- get bh
 768                       at <- get bh
 769                       return (IfaceFCall as at)
 770               10 -> do aa <- get bh
 771                        return (IfaceExt aa)
 772               11 -> do ie <- get bh
 773                        ico <- get bh
 774                        return (IfaceCast ie ico)
 775
 776 instance Binary IfaceConAlt where
 777     put_ bh IfaceDefault = do
 778             putByte bh 0
 779     put_ bh (IfaceDataAlt aa) = do
 780             putByte bh 1
 781             put_ bh aa
 782     put_ bh (IfaceTupleAlt ab) = do
 783             putByte bh 2
 784             put_ bh ab
 785     put_ bh (IfaceLitAlt ac) = do
 786             putByte bh 3
 787             put_ bh ac
 788     get bh = do
 789             h <- getByte bh
 790             case h of
 791               0 -> do return IfaceDefault
 792               1 -> do aa <- get bh
 793                       return (IfaceDataAlt aa)
 794               2 -> do ab <- get bh
 795                       return (IfaceTupleAlt ab)
 796               _ -> do ac <- get bh
 797                       return (IfaceLitAlt ac)
 798
 799 instance Binary IfaceBinding where
 800     put_ bh (IfaceNonRec aa ab) = do
 801             putByte bh 0
 802             put_ bh aa
 803             put_ bh ab
 804     put_ bh (IfaceRec ac) = do
 805             putByte bh 1
 806             put_ bh ac
 807     get bh = do
 808             h <- getByte bh
 809             case h of
 810               0 -> do aa <- get bh
 811                       ab <- get bh
 812                       return (IfaceNonRec aa ab)
 813               _ -> do ac <- get bh
 814                       return (IfaceRec ac)
 815
 816 instance Binary IfaceIdInfo where
 817     put_ bh NoInfo = putByte bh 0
 818     put_ bh (HasInfo i) = do
 819             putByte bh 1
 820             lazyPut bh i                        -- NB lazyPut
 821
 822     get bh = do
 823             h <- getByte bh
 824             case h of
 825               0 -> return NoInfo
 826               _ -> do info <- lazyGet bh        -- NB lazyGet
 827                       return (HasInfo info)
 828
 829 instance Binary IfaceInfoItem where
 830     put_ bh (HsArity aa) = do
 831             putByte bh 0
 832             put_ bh aa
 833     put_ bh (HsStrictness ab) = do
 834             putByte bh 1
 835             put_ bh ab
 836     put_ bh (HsUnfold ad) = do
 837             putByte bh 2
 838             put_ bh ad
 839     put_ bh (HsInline ad) = do
 840             putByte bh 3
 841             put_ bh ad
 842     put_ bh HsNoCafRefs = do
 843             putByte bh 4
 844     put_ bh (HsWorker ae af) = do
 845             putByte bh 5
 846             put_ bh ae
 847             put_ bh af
 848     get bh = do
 849             h <- getByte bh
 850             case h of
 851               0 -> do aa <- get bh
 852                       return (HsArity aa)
 853               1 -> do ab <- get bh
 854                       return (HsStrictness ab)
 855               2 -> do ad <- get bh
 856                       return (HsUnfold ad)
 857               3 -> do ad <- get bh
 858                       return (HsInline ad)
 859               4 -> do return HsNoCafRefs
 860               _ -> do ae <- get bh
 861                       af <- get bh
 862                       return (HsWorker ae af)
 863
 864 instance Binary IfaceNote where
 865     put_ bh (IfaceSCC aa) = do
 866             putByte bh 0
 867             put_ bh aa
 868     put_ bh IfaceInlineMe = do
 869             putByte bh 3
 870     put_ bh (IfaceCoreNote s) = do
 871             putByte bh 4
 872             put_ bh s
 873     get bh = do
 874             h <- getByte bh
 875             case h of
 876               0 -> do aa <- get bh
 877                       return (IfaceSCC aa)
 878               3 -> do return IfaceInlineMe
 879               4 -> do ac <- get bh
 880                       return (IfaceCoreNote ac)
 881
 882
 883 -------------------------------------------------------------------------
 884 --              IfaceDecl and friends
 885 -------------------------------------------------------------------------
 886
 887 instance Binary IfaceDecl where
 888     put_ bh (IfaceId name ty idinfo) = do
 889             putByte bh 0
 890             put_ bh name
 891             put_ bh ty
 892             put_ bh idinfo
 893     put_ bh (IfaceForeign ae af) =
 894         error "Binary.put_(IfaceDecl): IfaceForeign"
 895     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
 896             putByte bh 2
 897             put_ bh a1
 898             put_ bh a2
 899             put_ bh a3
 900             put_ bh a4
 901             put_ bh a5
 902             put_ bh a6
 903             put_ bh a7
 904             put_ bh a8
 905     put_ bh (IfaceSyn aq ar as at) = do
 906             putByte bh 3
 907             put_ bh aq
 908             put_ bh ar
 909             put_ bh as
 910             put_ bh at
 911     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
 912             putByte bh 4
 913             put_ bh a1
 914             put_ bh a2
 915             put_ bh a3
 916             put_ bh a4
 917             put_ bh a5
 918             put_ bh a6
 919             put_ bh a7
 920     get bh = do
 921             h <- getByte bh
 922             case h of
 923               0 -> do name   <- get bh
 924                       ty     <- get bh
 925                       idinfo <- get bh
 926                       return (IfaceId name ty idinfo)
 927               1 -> error "Binary.get(TyClDecl): ForeignType"
 928               2 -> do
 929                     a1 <- get bh
 930                     a2 <- get bh
 931                     a3 <- get bh
 932                     a4 <- get bh
 933                     a5 <- get bh
 934                     a6 <- get bh
 935                     a7 <- get bh
 936                     a8 <- get bh
 937                     return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
 938               3 -> do
 939                     aq <- get bh
 940                     ar <- get bh
 941                     as <- get bh
 942                     at <- get bh
 943                     return (IfaceSyn aq ar as at)
 944               _ -> do
 945                     a1 <- get bh
 946                     a2 <- get bh
 947                     a3 <- get bh
 948                     a4 <- get bh
 949                     a5 <- get bh
 950                     a6 <- get bh
 951                     a7 <- get bh
 952                     return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
 953
 954 instance Binary IfaceInst where
 955     put_ bh (IfaceInst cls tys dfun flag orph) = do
 956             put_ bh cls
 957             put_ bh tys
 958             put_ bh dfun
 959             put_ bh flag
 960             put_ bh orph
 961     get bh = do cls  <- get bh
 962                 tys  <- get bh
 963                 dfun <- get bh
 964                 flag <- get bh
 965                 orph <- get bh
 966                 return (IfaceInst cls tys dfun flag orph)
 967
 968 instance Binary IfaceFamInst where
 969     put_ bh (IfaceFamInst fam tys tycon) = do
 970             put_ bh fam
 971             put_ bh tys
 972             put_ bh tycon
 973     get bh = do fam   <- get bh
 974                 tys   <- get bh
 975                 tycon <- get bh
 976                 return (IfaceFamInst fam tys tycon)
 977
 978 instance Binary OverlapFlag where
 979     put_ bh NoOverlap  = putByte bh 0
 980     put_ bh OverlapOk  = putByte bh 1
 981     put_ bh Incoherent = putByte bh 2
 982     get bh = do h <- getByte bh
 983                 case h of
 984                   0 -> return NoOverlap
 985                   1 -> return OverlapOk
 986                   2 -> return Incoherent
 987
 988 instance Binary IfaceConDecls where
 989     put_ bh IfAbstractTyCon = putByte bh 0
 990     put_ bh IfOpenDataTyCon = putByte bh 1
 991     put_ bh IfOpenNewTyCon = putByte bh 2
 992     put_ bh (IfDataTyCon cs) = do { putByte bh 3
 993                                   ; put_ bh cs }
 994     put_ bh (IfNewTyCon c)  = do { putByte bh 4
 995                                   ; put_ bh c }
 996     get bh = do
 997             h <- getByte bh
 998             case h of
 999               0 -> return IfAbstractTyCon
1000               1 -> return IfOpenDataTyCon
1001               2 -> return IfOpenNewTyCon
1002               3 -> do cs <- get bh
1003                       return (IfDataTyCon cs)
1004               _ -> do aa <- get bh
1005                       return (IfNewTyCon aa)
1006
1007 instance Binary IfaceConDecl where
1008     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1009             put_ bh a1
1010             put_ bh a2
1011             put_ bh a3
1012             put_ bh a4
1013             put_ bh a5
1014             put_ bh a6
1015             put_ bh a7
1016             put_ bh a8
1017             put_ bh a9
1018     get bh = do a1 <- get bh
1019                 a2 <- get bh
1020                 a3 <- get bh
1021                 a4 <- get bh
1022                 a5 <- get bh
1023                 a6 <- get bh
1024                 a7 <- get bh
1025                 a8 <- get bh
1026                 a9 <- get bh
1027                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1028
1029 instance Binary IfaceClassOp where
1030    put_ bh (IfaceClassOp n def ty) = do
1031         put_ bh n
1032         put_ bh def
1033         put_ bh ty
1034    get bh = do
1035         n <- get bh
1036         def <- get bh
1037         ty <- get bh
1038         return (IfaceClassOp n def ty)
1039
1040 instance Binary IfaceRule where
1041     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1042             put_ bh a1
1043             put_ bh a2
1044             put_ bh a3
1045             put_ bh a4
1046             put_ bh a5
1047             put_ bh a6
1048             put_ bh a7
1049     get bh = do
1050             a1 <- get bh
1051             a2 <- get bh
1052             a3 <- get bh
1053             a4 <- get bh
1054             a5 <- get bh
1055             a6 <- get bh
1056             a7 <- get bh
1057             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1058
1059