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